Imported Upstream version 8.0pl1upstream/8.0pl1

1332 files changed, 312651 insertions, 0 deletions

diff --git a/.depend b/.depend
new file mode 100644
index 00000000..5ac89a4e
--- /dev/null
+++ b/.depend
@@ -0,0 +1,3387 @@
+ide/config_parser.cmi: lib/util.cmi 
+ide/coq.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    kernel/term.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+interp/constrextern.cmi: kernel/environ.cmi library/impargs.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \
+    interp/symbols.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+interp/constrintern.cmi: parsing/coqast.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/impargs.cmi library/libnames.cmi \
+    kernel/names.cmi pretyping/pattern.cmi pretyping/rawterm.cmi \
+    kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi 
+interp/coqlib.cmi: library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi kernel/term.cmi 
+interp/genarg.cmi: pretyping/evd.cmi library/libnames.cmi kernel/names.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi \
+    lib/util.cmi 
+interp/modintern.cmi: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi interp/topconstr.cmi 
+interp/ppextend.cmi: kernel/names.cmi lib/pp.cmi 
+interp/reserve.cmi: kernel/names.cmi pretyping/rawterm.cmi lib/util.cmi 
+interp/symbols.cmi: lib/bignat.cmi pretyping/classops.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \
+    interp/ppextend.cmi pretyping/rawterm.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+interp/syntax_def.cmi: kernel/names.cmi pretyping/rawterm.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+interp/topconstr.cmi: lib/bignat.cmi lib/dyn.cmi library/libnames.cmi \
+    kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi \
+    lib/util.cmi 
+kernel/closure.cmi: kernel/environ.cmi kernel/esubst.cmi kernel/names.cmi \
+    lib/pp.cmi kernel/term.cmi 
+kernel/conv_oracle.cmi: kernel/closure.cmi kernel/names.cmi 
+kernel/cooking.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/names.cmi kernel/term.cmi kernel/univ.cmi 
+kernel/declarations.cmi: kernel/names.cmi lib/rtree.cmi kernel/sign.cmi \
+    kernel/term.cmi kernel/univ.cmi 
+kernel/entries.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi 
+kernel/environ.cmi: kernel/declarations.cmi kernel/names.cmi kernel/sign.cmi \
+    kernel/term.cmi kernel/univ.cmi 
+kernel/esubst.cmi: lib/util.cmi 
+kernel/indtypes.cmi: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/names.cmi kernel/term.cmi kernel/typeops.cmi \
+    kernel/univ.cmi 
+kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/names.cmi kernel/term.cmi kernel/univ.cmi 
+kernel/modops.cmi: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/names.cmi kernel/univ.cmi lib/util.cmi 
+kernel/mod_typing.cmi: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi 
+kernel/names.cmi: lib/pp.cmi lib/predicate.cmi 
+kernel/reduction.cmi: kernel/environ.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi 
+kernel/safe_typing.cmi: kernel/cooking.cmi kernel/declarations.cmi \
+    kernel/entries.cmi kernel/environ.cmi kernel/names.cmi kernel/term.cmi \
+    kernel/univ.cmi 
+kernel/sign.cmi: kernel/names.cmi kernel/term.cmi 
+kernel/subtyping.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/univ.cmi 
+kernel/term.cmi: kernel/esubst.cmi kernel/names.cmi kernel/univ.cmi 
+kernel/term_typing.cmi: kernel/cooking.cmi kernel/declarations.cmi \
+    kernel/entries.cmi kernel/environ.cmi kernel/inductive.cmi \
+    kernel/names.cmi kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi 
+kernel/type_errors.cmi: kernel/environ.cmi kernel/names.cmi kernel/term.cmi 
+kernel/typeops.cmi: kernel/entries.cmi kernel/environ.cmi kernel/names.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/univ.cmi 
+kernel/univ.cmi: kernel/names.cmi lib/pp.cmi 
+lib/bignat.cmi: lib/pp.cmi 
+lib/pp.cmi: lib/pp_control.cmi 
+library/declare.cmi: kernel/cooking.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi library/dischargedhypsmap.cmi kernel/entries.cmi \
+    kernel/indtypes.cmi library/libnames.cmi library/libobject.cmi \
+    kernel/names.cmi library/nametab.cmi kernel/safe_typing.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/univ.cmi 
+library/declaremods.cmi: kernel/entries.cmi kernel/environ.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    kernel/names.cmi lib/pp.cmi kernel/safe_typing.cmi lib/util.cmi 
+library/dischargedhypsmap.cmi: kernel/environ.cmi library/libnames.cmi \
+    library/nametab.cmi kernel/term.cmi 
+library/global.cmi: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/indtypes.cmi library/libnames.cmi \
+    kernel/names.cmi kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi 
+library/goptions.cmi: library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi kernel/term.cmi lib/util.cmi 
+library/impargs.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi kernel/term.cmi interp/topconstr.cmi 
+library/lib.cmi: library/libnames.cmi library/libobject.cmi kernel/names.cmi \
+    library/summary.cmi lib/util.cmi 
+library/libnames.cmi: kernel/names.cmi lib/pp.cmi lib/predicate.cmi \
+    kernel/term.cmi lib/util.cmi 
+library/libobject.cmi: library/libnames.cmi kernel/names.cmi 
+library/library.cmi: library/libnames.cmi library/libobject.cmi \
+    kernel/names.cmi lib/pp.cmi lib/system.cmi lib/util.cmi 
+library/nameops.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi 
+library/nametab.cmi: library/libnames.cmi kernel/names.cmi lib/pp.cmi \
+    lib/util.cmi 
+lib/rtree.cmi: lib/pp.cmi 
+lib/system.cmi: lib/pp.cmi 
+lib/util.cmi: lib/compat.cmo lib/pp.cmi 
+parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi lib/pp.cmi interp/topconstr.cmi \
+    lib/util.cmi 
+parsing/coqast.cmi: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \
+    lib/util.cmi 
+parsing/egrammar.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \
+    interp/genarg.cmi kernel/names.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/esyntax.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \
+    lib/pp.cmi interp/ppextend.cmi interp/symbols.cmi interp/topconstr.cmi 
+parsing/extend.cmi: parsing/ast.cmi parsing/coqast.cmi interp/genarg.cmi \
+    kernel/names.cmi lib/pp.cmi interp/ppextend.cmi interp/topconstr.cmi \
+    lib/util.cmi 
+parsing/g_minicoq.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/term.cmi 
+parsing/lexer.cmi: lib/pp.cmi lib/util.cmi 
+parsing/pcoq.cmi: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \
+    library/decl_kinds.cmo parsing/extend.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/ppconstr.cmi: parsing/coqast.cmi kernel/environ.cmi \
+    parsing/extend.cmi library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+parsing/pptactic.cmi: interp/genarg.cmi library/libnames.cmi lib/pp.cmi \
+    pretyping/pretyping.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo kernel/term.cmi interp/topconstr.cmi lib/util.cmi 
+parsing/prettyp.cmi: pretyping/classops.cmi kernel/environ.cmi \
+    library/impargs.cmi library/lib.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi pretyping/reductionops.cmi \
+    kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi 
+parsing/printer.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi 
+parsing/printmod.cmi: kernel/names.cmi lib/pp.cmi 
+parsing/search.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi kernel/term.cmi 
+parsing/termast.cmi: parsing/coqast.cmi kernel/environ.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi 
+pretyping/cases.cmi: kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi 
+pretyping/cbv.cmi: kernel/closure.cmi kernel/environ.cmi kernel/esubst.cmi \
+    kernel/names.cmi kernel/term.cmi 
+pretyping/classops.cmi: library/decl_kinds.cmo kernel/environ.cmi \
+    pretyping/evd.cmi library/libnames.cmi library/libobject.cmi \
+    kernel/names.cmi library/nametab.cmi lib/pp.cmi kernel/term.cmi 
+pretyping/coercion.cmi: kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/evd.cmi kernel/names.cmi pretyping/rawterm.cmi kernel/sign.cmi \
+    kernel/term.cmi lib/util.cmi 
+pretyping/detyping.cmi: kernel/environ.cmi kernel/names.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi 
+pretyping/evarconv.cmi: kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi 
+pretyping/evarutil.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi lib/util.cmi 
+pretyping/evd.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi 
+pretyping/indrec.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi \
+    kernel/term.cmi 
+pretyping/inductiveops.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi 
+pretyping/instantiate.cmi: kernel/environ.cmi pretyping/evd.cmi \
+    kernel/names.cmi kernel/sign.cmi kernel/term.cmi 
+pretyping/matching.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    pretyping/pattern.cmi kernel/term.cmi pretyping/termops.cmi 
+pretyping/pattern.cmi: kernel/environ.cmi library/libnames.cmi \
+    kernel/names.cmi library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \
+    kernel/sign.cmi kernel/term.cmi 
+pretyping/pretype_errors.cmi: kernel/environ.cmi pretyping/evd.cmi \
+    pretyping/inductiveops.cmi kernel/names.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi lib/util.cmi 
+pretyping/pretyping.cmi: lib/dyn.cmi kernel/environ.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi kernel/names.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi 
+pretyping/rawterm.cmi: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \
+    lib/util.cmi 
+pretyping/recordops.cmi: pretyping/classops.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi kernel/names.cmi \
+    library/nametab.cmi kernel/term.cmi 
+pretyping/reductionops.cmi: kernel/closure.cmi kernel/environ.cmi \
+    pretyping/evd.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi 
+pretyping/retyping.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    pretyping/pattern.cmi kernel/term.cmi pretyping/termops.cmi 
+pretyping/tacred.cmi: kernel/closure.cmi kernel/environ.cmi pretyping/evd.cmi \
+    library/libnames.cmi kernel/names.cmi pretyping/rawterm.cmi \
+    pretyping/reductionops.cmi kernel/term.cmi 
+pretyping/termops.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi 
+pretyping/typing.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/term.cmi 
+proofs/clenv.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    lib/pp.cmi pretyping/pretyping.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi 
+proofs/evar_refiner.cmi: kernel/environ.cmi pretyping/evd.cmi \
+    kernel/names.cmi proofs/proof_type.cmi proofs/refiner.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo kernel/term.cmi interp/topconstr.cmi 
+proofs/logic.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi kernel/term.cmi 
+proofs/pfedit.cmi: library/decl_kinds.cmo kernel/entries.cmi \
+    kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+proofs/proof_trees.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi kernel/term.cmi \
+    lib/util.cmi 
+proofs/proof_type.cmi: kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    kernel/term.cmi lib/util.cmi 
+proofs/refiner.cmi: pretyping/evd.cmi lib/pp.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi kernel/sign.cmi proofs/tacexpr.cmo kernel/term.cmi \
+    pretyping/termops.cmi 
+proofs/tacmach.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \
+    lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi proofs/refiner.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \
+    pretyping/termops.cmi interp/topconstr.cmi 
+proofs/tactic_debug.cmi: kernel/environ.cmi kernel/names.cmi \
+    pretyping/pattern.cmi lib/pp.cmi proofs/proof_type.cmi proofs/tacexpr.cmo \
+    kernel/term.cmi 
+tactics/auto.cmi: tactics/btermdn.cmi proofs/clenv.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/libnames.cmi kernel/names.cmi \
+    pretyping/pattern.cmi lib/pp.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi kernel/term.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+tactics/autorewrite.cmi: proofs/tacexpr.cmo proofs/tacmach.cmi \
+    kernel/term.cmi 
+tactics/btermdn.cmi: pretyping/pattern.cmi kernel/term.cmi 
+tactics/contradiction.cmi: kernel/names.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi 
+tactics/dhyp.cmi: kernel/names.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    interp/topconstr.cmi toplevel/vernacexpr.cmo 
+tactics/eauto.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo kernel/term.cmi 
+tactics/elim.cmi: interp/genarg.cmi kernel/names.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi proofs/tacmach.cmi tactics/tacticals.cmi \
+    kernel/term.cmi 
+tactics/equality.cmi: kernel/environ.cmi pretyping/evd.cmi \
+    tactics/hipattern.cmi kernel/names.cmi pretyping/pattern.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi 
+tactics/extraargs.cmi: parsing/pcoq.cmi proofs/proof_type.cmi \
+    proofs/tacexpr.cmo kernel/term.cmi interp/topconstr.cmi 
+tactics/extratactics.cmi: interp/genarg.cmi kernel/names.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/term.cmi 
+tactics/hiddentac.cmi: interp/genarg.cmi kernel/names.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \
+    kernel/term.cmi 
+tactics/hipattern.cmi: interp/coqlib.cmi pretyping/evd.cmi kernel/names.cmi \
+    pretyping/pattern.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi lib/util.cmi 
+tactics/inv.cmi: interp/genarg.cmi kernel/names.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi 
+tactics/leminv.cmi: kernel/names.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi 
+tactics/nbtermdn.cmi: tactics/btermdn.cmi pretyping/pattern.cmi \
+    kernel/term.cmi 
+tactics/refine.cmi: pretyping/pretyping.cmi proofs/tacmach.cmi \
+    kernel/term.cmi 
+tactics/setoid_replace.cmi: kernel/names.cmi proofs/proof_type.cmi \
+    kernel/term.cmi interp/topconstr.cmi 
+tactics/tacinterp.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/environ.cmi \
+    pretyping/evd.cmi interp/genarg.cmi kernel/names.cmi library/nametab.cmi \
+    lib/pp.cmi proofs/proof_type.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    pretyping/tacred.cmi proofs/tactic_debug.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+tactics/tacticals.cmi: proofs/clenv.cmi interp/genarg.cmi kernel/names.cmi \
+    pretyping/pattern.cmi proofs/proof_type.cmi kernel/reduction.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi 
+tactics/tactics.cmi: proofs/clenv.cmi kernel/environ.cmi \
+    proofs/evar_refiner.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi \
+    interp/topconstr.cmi 
+tactics/termdn.cmi: pretyping/pattern.cmi kernel/term.cmi 
+toplevel/cerrors.cmi: lib/pp.cmi lib/util.cmi 
+toplevel/class.cmi: pretyping/classops.cmi library/decl_kinds.cmo \
+    library/declare.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi proofs/tacexpr.cmo kernel/term.cmi 
+toplevel/command.cmi: library/decl_kinds.cmo library/declare.cmi \
+    kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi \
+    library/libnames.cmi library/library.cmi kernel/names.cmi \
+    library/nametab.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    pretyping/tacred.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+toplevel/coqinit.cmi: kernel/names.cmi 
+toplevel/discharge.cmi: kernel/names.cmi 
+toplevel/fhimsg.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi 
+toplevel/himsg.cmi: pretyping/cases.cmi kernel/environ.cmi \
+    kernel/indtypes.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi kernel/type_errors.cmi 
+toplevel/metasyntax.cmi: pretyping/classops.cmi interp/constrintern.cmi \
+    parsing/extend.cmi library/libnames.cmi interp/ppextend.cmi \
+    interp/symbols.cmi proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+toplevel/mltop.cmi: library/libobject.cmi kernel/names.cmi 
+toplevel/protectedtoplevel.cmi: lib/pp.cmi 
+toplevel/record.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \
+    interp/topconstr.cmi toplevel/vernacexpr.cmo 
+toplevel/recordobj.cmi: library/libnames.cmi proofs/tacexpr.cmo 
+toplevel/searchisos.cmi: library/libobject.cmi kernel/names.cmi \
+    kernel/term.cmi 
+toplevel/toplevel.cmi: parsing/pcoq.cmi lib/pp.cmi 
+toplevel/vernacentries.cmi: kernel/environ.cmi pretyping/evd.cmi \
+    library/libnames.cmi kernel/names.cmi kernel/term.cmi \
+    interp/topconstr.cmi toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi 
+toplevel/vernacinterp.cmi: proofs/tacexpr.cmo 
+toplevel/vernac.cmi: parsing/pcoq.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+translate/ppconstrnew.cmi: parsing/coqast.cmi kernel/environ.cmi \
+    parsing/extend.cmi interp/genarg.cmi library/libnames.cmi \
+    kernel/names.cmi pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \
+    interp/ppextend.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    kernel/term.cmi interp/topconstr.cmi lib/util.cmi 
+translate/pptacticnew.cmi: kernel/environ.cmi interp/genarg.cmi \
+    kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi proofs/tacexpr.cmo \
+    interp/topconstr.cmi 
+translate/ppvernacnew.cmi: parsing/ast.cmi parsing/coqast.cmi \
+    kernel/environ.cmi parsing/extend.cmi interp/genarg.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi parsing/pcoq.cmi lib/pp.cmi parsing/ppconstr.cmi \
+    interp/ppextend.cmi parsing/pptactic.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+contrib/cc/ccalgo.cmi: kernel/names.cmi kernel/term.cmi 
+contrib/cc/ccproof.cmi: contrib/cc/ccalgo.cmi kernel/names.cmi 
+contrib/correctness/past.cmi: kernel/names.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+contrib/correctness/pcicenv.cmi: kernel/names.cmi kernel/sign.cmi \
+    kernel/term.cmi 
+contrib/correctness/pcic.cmi: pretyping/rawterm.cmi 
+contrib/correctness/pdb.cmi: kernel/names.cmi 
+contrib/correctness/peffect.cmi: kernel/names.cmi lib/pp.cmi 
+contrib/correctness/penv.cmi: library/libnames.cmi kernel/names.cmi \
+    kernel/term.cmi 
+contrib/correctness/perror.cmi: kernel/names.cmi lib/pp.cmi lib/util.cmi 
+contrib/correctness/pextract.cmi: kernel/names.cmi 
+contrib/correctness/pmisc.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+contrib/correctness/pmlize.cmi: kernel/names.cmi 
+contrib/correctness/pmonad.cmi: kernel/names.cmi kernel/term.cmi 
+contrib/correctness/pred.cmi: kernel/term.cmi 
+contrib/correctness/prename.cmi: kernel/names.cmi lib/pp.cmi 
+contrib/correctness/psyntax.cmi: parsing/pcoq.cmi interp/topconstr.cmi 
+contrib/correctness/ptactic.cmi: proofs/tacmach.cmi 
+contrib/correctness/ptype.cmi: kernel/names.cmi kernel/term.cmi 
+contrib/correctness/ptyping.cmi: kernel/names.cmi kernel/term.cmi \
+    interp/topconstr.cmi 
+contrib/correctness/putil.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi 
+contrib/correctness/pwp.cmi: kernel/term.cmi 
+contrib/extraction/common.cmi: contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi kernel/names.cmi 
+contrib/extraction/extract_env.cmi: library/libnames.cmi kernel/names.cmi 
+contrib/extraction/extraction.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    library/libnames.cmi contrib/extraction/miniml.cmi kernel/names.cmi \
+    kernel/term.cmi 
+contrib/extraction/haskell.cmi: contrib/extraction/miniml.cmi \
+    kernel/names.cmi lib/pp.cmi 
+contrib/extraction/miniml.cmi: library/libnames.cmi kernel/names.cmi \
+    lib/pp.cmi lib/util.cmi 
+contrib/extraction/mlutil.cmi: library/libnames.cmi \
+    contrib/extraction/miniml.cmi kernel/names.cmi kernel/term.cmi \
+    lib/util.cmi 
+contrib/extraction/modutil.cmi: kernel/declarations.cmi kernel/environ.cmi \
+    library/libnames.cmi contrib/extraction/miniml.cmi kernel/names.cmi 
+contrib/extraction/ocaml.cmi: library/libnames.cmi \
+    contrib/extraction/miniml.cmi kernel/names.cmi lib/pp.cmi 
+contrib/extraction/scheme.cmi: contrib/extraction/miniml.cmi kernel/names.cmi \
+    lib/pp.cmi 
+contrib/extraction/table.cmi: kernel/environ.cmi library/libnames.cmi \
+    contrib/extraction/miniml.cmi kernel/names.cmi kernel/term.cmi 
+contrib/first-order/formula.cmi: kernel/closure.cmi library/libnames.cmi \
+    kernel/names.cmi proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi \
+    kernel/term.cmi 
+contrib/first-order/ground.cmi: proofs/proof_type.cmi \
+    contrib/first-order/sequent.cmi proofs/tacmach.cmi 
+contrib/first-order/instances.cmi: contrib/first-order/formula.cmi \
+    library/libnames.cmi kernel/names.cmi contrib/first-order/rules.cmi \
+    contrib/first-order/sequent.cmi proofs/tacmach.cmi kernel/term.cmi \
+    contrib/first-order/unify.cmi 
+contrib/first-order/rules.cmi: library/libnames.cmi kernel/names.cmi \
+    contrib/first-order/sequent.cmi proofs/tacmach.cmi kernel/term.cmi 
+contrib/first-order/sequent.cmi: tactics/auto.cmi \
+    contrib/first-order/formula.cmi lib/heap.cmi library/libnames.cmi \
+    kernel/names.cmi proofs/proof_type.cmi proofs/tacmach.cmi kernel/term.cmi \
+    lib/util.cmi 
+contrib/first-order/unify.cmi: kernel/term.cmi 
+contrib/funind/tacinvutils.cmi: interp/coqlib.cmi tactics/equality.cmi \
+    pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \
+    tactics/refine.cmi tactics/tacinterp.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi 
+contrib/interface/blast.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi 
+contrib/interface/dad.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi interp/topconstr.cmi 
+contrib/interface/debug_tac.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi 
+contrib/interface/name_to_ast.cmi: parsing/coqast.cmi library/libnames.cmi \
+    toplevel/vernacexpr.cmo 
+contrib/interface/pbp.cmi: kernel/names.cmi proofs/proof_type.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi 
+contrib/interface/showproof.cmi: contrib/interface/ascent.cmi \
+    proofs/clenv.cmi parsing/coqast.cmi kernel/declarations.cmi \
+    kernel/environ.cmi pretyping/evd.cmi kernel/inductive.cmi \
+    kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \
+    contrib/interface/showproof_ct.cmo kernel/sign.cmi kernel/term.cmi \
+    contrib/interface/translate.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacinterp.cmi 
+contrib/interface/translate.cmi: contrib/interface/ascent.cmi \
+    kernel/environ.cmi pretyping/evd.cmi proofs/proof_type.cmi \
+    kernel/term.cmi 
+contrib/interface/vtp.cmi: contrib/interface/ascent.cmi 
+contrib/interface/xlate.cmi: contrib/interface/ascent.cmi kernel/names.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi toplevel/vernacexpr.cmo 
+contrib/jprover/jall.cmi: contrib/jprover/jlogic.cmi \
+    contrib/jprover/jterm.cmi contrib/jprover/opname.cmi 
+contrib/jprover/jlogic.cmi: contrib/jprover/jterm.cmi 
+contrib/jprover/jterm.cmi: contrib/jprover/opname.cmi 
+contrib/xml/doubleTypeInference.cmi: contrib/xml/acic.cmo kernel/environ.cmi \
+    pretyping/evd.cmi kernel/names.cmi kernel/term.cmi 
+contrib/xml/xmlcommand.cmi: contrib/xml/acic.cmo pretyping/evd.cmi \
+    library/libnames.cmi contrib/xml/proof2aproof.cmo proofs/proof_type.cmi \
+    kernel/term.cmi contrib/xml/xml.cmi 
+ide/utils/configwin.cmi: ide/utils/uoptions.cmi 
+tools/coqdoc/output.cmi: tools/coqdoc/index.cmi 
+tools/coqdoc/pretty.cmi: tools/coqdoc/index.cmi 
+config/coq_config.cmo: config/coq_config.cmi 
+config/coq_config.cmx: config/coq_config.cmi 
+dev/db_printers.cmo: kernel/names.cmi lib/pp.cmi 
+dev/db_printers.cmx: kernel/names.cmx lib/pp.cmx 
+dev/top_printers.cmo: parsing/ast.cmi toplevel/cerrors.cmi proofs/clenv.cmi \
+    kernel/closure.cmi interp/constrextern.cmi kernel/declarations.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/libnames.cmi \
+    library/libobject.cmi library/nameops.cmi kernel/names.cmi lib/pp.cmi \
+    parsing/pptactic.cmi parsing/printer.cmi proofs/proof_trees.cmi \
+    proofs/refiner.cmi kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/univ.cmi 
+dev/top_printers.cmx: parsing/ast.cmx toplevel/cerrors.cmx proofs/clenv.cmx \
+    kernel/closure.cmx interp/constrextern.cmx kernel/declarations.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/libnames.cmx \
+    library/libobject.cmx library/nameops.cmx kernel/names.cmx lib/pp.cmx \
+    parsing/pptactic.cmx parsing/printer.cmx proofs/proof_trees.cmx \
+    proofs/refiner.cmx kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/univ.cmx 
+doc/parse.cmo: parsing/ast.cmi 
+doc/parse.cmx: parsing/ast.cmx 
+ide/blaster_window.cmo: ide/coq.cmi ide/ideutils.cmi 
+ide/blaster_window.cmx: ide/coq.cmx ide/ideutils.cmx 
+ide/command_windows.cmo: ide/coq.cmi ide/coq_commands.cmo ide/ideutils.cmi \
+    ide/command_windows.cmi 
+ide/command_windows.cmx: ide/coq.cmx ide/coq_commands.cmx ide/ideutils.cmx \
+    ide/command_windows.cmi 
+ide/config_lexer.cmo: ide/config_parser.cmi lib/util.cmi 
+ide/config_lexer.cmx: ide/config_parser.cmx lib/util.cmx 
+ide/config_parser.cmo: lib/util.cmi ide/config_parser.cmi 
+ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi 
+ide/coqide.cmo: ide/blaster_window.cmo ide/command_windows.cmi ide/coq.cmi \
+    ide/coq_commands.cmo ide/find_phrase.cmo ide/highlight.cmo \
+    ide/ideutils.cmi proofs/pfedit.cmi ide/preferences.cmi lib/system.cmi \
+    ide/undo.cmi lib/util.cmi toplevel/vernacexpr.cmo ide/coqide.cmi 
+ide/coqide.cmx: ide/blaster_window.cmx ide/command_windows.cmx ide/coq.cmx \
+    ide/coq_commands.cmx ide/find_phrase.cmx ide/highlight.cmx \
+    ide/ideutils.cmx proofs/pfedit.cmx ide/preferences.cmx lib/system.cmx \
+    ide/undo.cmx lib/util.cmx toplevel/vernacexpr.cmx ide/coqide.cmi 
+ide/coq.cmo: toplevel/cerrors.cmi config/coq_config.cmi toplevel/coqtop.cmi \
+    kernel/declarations.cmi kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/evd.cmi library/global.cmi tactics/hipattern.cmi \
+    ide/ideutils.cmi library/lib.cmi library/libnames.cmi library/library.cmi \
+    toplevel/mltop.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_trees.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    library/states.cmi tactics/tacinterp.cmi proofs/tacmach.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi toplevel/vernac.cmi \
+    toplevel/vernacentries.cmi toplevel/vernacexpr.cmo ide/coq.cmi 
+ide/coq.cmx: toplevel/cerrors.cmx config/coq_config.cmx toplevel/coqtop.cmx \
+    kernel/declarations.cmx kernel/environ.cmx pretyping/evarutil.cmx \
+    pretyping/evd.cmx library/global.cmx tactics/hipattern.cmx \
+    ide/ideutils.cmx library/lib.cmx library/libnames.cmx library/library.cmx \
+    toplevel/mltop.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \
+    proofs/proof_trees.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    library/states.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx toplevel/vernac.cmx \
+    toplevel/vernacentries.cmx toplevel/vernacexpr.cmx ide/coq.cmi 
+ide/coq_tactics.cmo: ide/coq_tactics.cmi 
+ide/coq_tactics.cmx: ide/coq_tactics.cmi 
+ide/find_phrase.cmo: ide/ideutils.cmi 
+ide/find_phrase.cmx: ide/ideutils.cmx 
+ide/highlight.cmo: ide/ideutils.cmi 
+ide/highlight.cmx: ide/ideutils.cmx 
+ide/ideutils.cmo: config/coq_config.cmi lib/options.cmi lib/pp_control.cmi \
+    ide/preferences.cmi ide/utf8_convert.cmo ide/ideutils.cmi 
+ide/ideutils.cmx: config/coq_config.cmx lib/options.cmx lib/pp_control.cmx \
+    ide/preferences.cmx ide/utf8_convert.cmx ide/ideutils.cmi 
+ide/preferences.cmo: ide/config_lexer.cmo ide/utils/configwin.cmi \
+    lib/system.cmi lib/util.cmi ide/preferences.cmi 
+ide/preferences.cmx: ide/config_lexer.cmx ide/utils/configwin.cmx \
+    lib/system.cmx lib/util.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/bignat.cmi pretyping/classops.cmi \
+    kernel/declarations.cmi pretyping/detyping.cmi kernel/environ.cmi \
+    library/global.cmi library/impargs.cmi kernel/inductive.cmi \
+    library/lib.cmi library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi pretyping/recordops.cmi interp/reserve.cmi \
+    kernel/sign.cmi interp/symbols.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi kernel/univ.cmi lib/util.cmi interp/constrextern.cmi 
+interp/constrextern.cmx: lib/bignat.cmx pretyping/classops.cmx \
+    kernel/declarations.cmx pretyping/detyping.cmx kernel/environ.cmx \
+    library/global.cmx library/impargs.cmx kernel/inductive.cmx \
+    library/lib.cmx library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx pretyping/recordops.cmx interp/reserve.cmx \
+    kernel/sign.cmx interp/symbols.cmx kernel/term.cmx pretyping/termops.cmx \
+    interp/topconstr.cmx kernel/univ.cmx lib/util.cmx interp/constrextern.cmi 
+interp/constrintern.cmo: lib/bignat.cmi kernel/declarations.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi \
+    library/impargs.cmi kernel/inductive.cmi parsing/lexer.cmi \
+    library/lib.cmi library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi pretyping/pretyping.cmi \
+    pretyping/rawterm.cmi pretyping/recordops.cmi interp/reserve.cmi \
+    pretyping/retyping.cmi kernel/sign.cmi interp/symbols.cmi \
+    interp/syntax_def.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi lib/util.cmi interp/constrintern.cmi 
+interp/constrintern.cmx: lib/bignat.cmx kernel/declarations.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx \
+    library/impargs.cmx kernel/inductive.cmx parsing/lexer.cmx \
+    library/lib.cmx library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx pretyping/pretyping.cmx \
+    pretyping/rawterm.cmx pretyping/recordops.cmx interp/reserve.cmx \
+    pretyping/retyping.cmx kernel/sign.cmx interp/symbols.cmx \
+    interp/syntax_def.cmx kernel/term.cmx pretyping/termops.cmx \
+    interp/topconstr.cmx lib/util.cmx interp/constrintern.cmi 
+interp/coqlib.cmo: interp/constrextern.cmi library/libnames.cmi \
+    kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    pretyping/pattern.cmi lib/pp.cmi kernel/term.cmi lib/util.cmi \
+    interp/coqlib.cmi 
+interp/coqlib.cmx: interp/constrextern.cmx library/libnames.cmx \
+    kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    pretyping/pattern.cmx lib/pp.cmx kernel/term.cmx lib/util.cmx \
+    interp/coqlib.cmi 
+interp/genarg.cmo: pretyping/evd.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi interp/genarg.cmi 
+interp/genarg.cmx: pretyping/evd.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx interp/genarg.cmi 
+interp/modintern.cmo: interp/constrintern.cmi kernel/entries.cmi \
+    pretyping/evd.cmi library/libnames.cmi kernel/modops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi interp/topconstr.cmi lib/util.cmi \
+    interp/modintern.cmi 
+interp/modintern.cmx: interp/constrintern.cmx kernel/entries.cmx \
+    pretyping/evd.cmx library/libnames.cmx kernel/modops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx interp/topconstr.cmx lib/util.cmx \
+    interp/modintern.cmi 
+interp/ppextend.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi \
+    interp/ppextend.cmi 
+interp/ppextend.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx \
+    interp/ppextend.cmi 
+interp/reserve.cmo: library/lib.cmi library/libobject.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi pretyping/rawterm.cmi \
+    library/summary.cmi lib/util.cmi interp/reserve.cmi 
+interp/reserve.cmx: library/lib.cmx library/libobject.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx pretyping/rawterm.cmx \
+    library/summary.cmx lib/util.cmx interp/reserve.cmi 
+interp/symbols.cmo: lib/bignat.cmi pretyping/classops.cmi library/global.cmi \
+    lib/gmap.cmi lib/gmapl.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi kernel/names.cmi library/nametab.cmi \
+    lib/options.cmi lib/pp.cmi interp/ppextend.cmi pretyping/rawterm.cmi \
+    pretyping/reductionops.cmi library/summary.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi interp/symbols.cmi 
+interp/symbols.cmx: lib/bignat.cmx pretyping/classops.cmx library/global.cmx \
+    lib/gmap.cmx lib/gmapl.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx kernel/names.cmx library/nametab.cmx \
+    lib/options.cmx lib/pp.cmx interp/ppextend.cmx pretyping/rawterm.cmx \
+    pretyping/reductionops.cmx library/summary.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx interp/symbols.cmi 
+interp/syntax_def.cmo: library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi library/summary.cmi interp/symbols.cmi \
+    interp/topconstr.cmi lib/util.cmi interp/syntax_def.cmi 
+interp/syntax_def.cmx: library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx library/summary.cmx interp/symbols.cmx \
+    interp/topconstr.cmx lib/util.cmx interp/syntax_def.cmi 
+interp/topconstr.cmo: lib/bignat.cmi lib/dyn.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi interp/topconstr.cmi 
+interp/topconstr.cmx: lib/bignat.cmx lib/dyn.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx interp/topconstr.cmi 
+kernel/closure.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/esubst.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \
+    lib/util.cmi kernel/closure.cmi 
+kernel/closure.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/esubst.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \
+    lib/util.cmx kernel/closure.cmi 
+kernel/conv_oracle.cmo: kernel/closure.cmi kernel/names.cmi \
+    kernel/conv_oracle.cmi 
+kernel/conv_oracle.cmx: kernel/closure.cmx kernel/names.cmx \
+    kernel/conv_oracle.cmi 
+kernel/cooking.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \
+    kernel/term.cmi lib/util.cmi kernel/cooking.cmi 
+kernel/cooking.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \
+    kernel/term.cmx lib/util.cmx kernel/cooking.cmi 
+kernel/declarations.cmo: kernel/names.cmi lib/rtree.cmi kernel/sign.cmi \
+    kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/declarations.cmi 
+kernel/declarations.cmx: kernel/names.cmx lib/rtree.cmx kernel/sign.cmx \
+    kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/declarations.cmi 
+kernel/entries.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi kernel/entries.cmi 
+kernel/entries.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/univ.cmx kernel/entries.cmi 
+kernel/environ.cmo: kernel/declarations.cmi kernel/names.cmi kernel/sign.cmi \
+    kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/environ.cmi 
+kernel/environ.cmx: kernel/declarations.cmx kernel/names.cmx kernel/sign.cmx \
+    kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/environ.cmi 
+kernel/esubst.cmo: lib/util.cmi kernel/esubst.cmi 
+kernel/esubst.cmx: lib/util.cmx kernel/esubst.cmi 
+kernel/indtypes.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \
+    kernel/reduction.cmi lib/rtree.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/typeops.cmi kernel/univ.cmi lib/util.cmi kernel/indtypes.cmi 
+kernel/indtypes.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx kernel/inductive.cmx kernel/names.cmx \
+    kernel/reduction.cmx lib/rtree.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/typeops.cmx kernel/univ.cmx lib/util.cmx kernel/indtypes.cmi 
+kernel/inductive.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/names.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi kernel/inductive.cmi 
+kernel/inductive.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/names.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx kernel/inductive.cmi 
+kernel/modops.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \
+    kernel/univ.cmi lib/util.cmi kernel/modops.cmi 
+kernel/modops.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \
+    kernel/univ.cmx lib/util.cmx kernel/modops.cmi 
+kernel/mod_typing.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/modops.cmi kernel/names.cmi \
+    kernel/reduction.cmi kernel/subtyping.cmi kernel/term_typing.cmi \
+    kernel/typeops.cmi kernel/univ.cmi lib/util.cmi kernel/mod_typing.cmi 
+kernel/mod_typing.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx kernel/modops.cmx kernel/names.cmx \
+    kernel/reduction.cmx kernel/subtyping.cmx kernel/term_typing.cmx \
+    kernel/typeops.cmx kernel/univ.cmx lib/util.cmx kernel/mod_typing.cmi 
+kernel/names.cmo: lib/hashcons.cmi lib/options.cmi lib/pp.cmi \
+    lib/predicate.cmi lib/util.cmi kernel/names.cmi 
+kernel/names.cmx: lib/hashcons.cmx lib/options.cmx lib/pp.cmx \
+    lib/predicate.cmx lib/util.cmx kernel/names.cmi 
+kernel/reduction.cmo: kernel/closure.cmi kernel/conv_oracle.cmi \
+    kernel/declarations.cmi kernel/environ.cmi kernel/esubst.cmi \
+    kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \
+    lib/util.cmi kernel/reduction.cmi 
+kernel/reduction.cmx: kernel/closure.cmx kernel/conv_oracle.cmx \
+    kernel/declarations.cmx kernel/environ.cmx kernel/esubst.cmx \
+    kernel/names.cmx kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \
+    lib/util.cmx kernel/reduction.cmi 
+kernel/safe_typing.cmo: kernel/cooking.cmi kernel/declarations.cmi \
+    kernel/entries.cmi kernel/environ.cmi kernel/indtypes.cmi \
+    kernel/inductive.cmi kernel/mod_typing.cmi kernel/modops.cmi \
+    kernel/names.cmi kernel/reduction.cmi kernel/sign.cmi \
+    kernel/subtyping.cmi kernel/term.cmi kernel/term_typing.cmi \
+    kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \
+    kernel/safe_typing.cmi 
+kernel/safe_typing.cmx: kernel/cooking.cmx kernel/declarations.cmx \
+    kernel/entries.cmx kernel/environ.cmx kernel/indtypes.cmx \
+    kernel/inductive.cmx kernel/mod_typing.cmx kernel/modops.cmx \
+    kernel/names.cmx kernel/reduction.cmx kernel/sign.cmx \
+    kernel/subtyping.cmx kernel/term.cmx kernel/term_typing.cmx \
+    kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \
+    kernel/safe_typing.cmi 
+kernel/sign.cmo: kernel/names.cmi kernel/term.cmi lib/util.cmi \
+    kernel/sign.cmi 
+kernel/sign.cmx: kernel/names.cmx kernel/term.cmx lib/util.cmx \
+    kernel/sign.cmi 
+kernel/subtyping.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/inductive.cmi kernel/modops.cmi kernel/names.cmi \
+    kernel/reduction.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \
+    kernel/subtyping.cmi 
+kernel/subtyping.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/inductive.cmx kernel/modops.cmx kernel/names.cmx \
+    kernel/reduction.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \
+    kernel/subtyping.cmi 
+kernel/term.cmo: kernel/esubst.cmi lib/hashcons.cmi kernel/names.cmi \
+    lib/pp.cmi kernel/univ.cmi lib/util.cmi kernel/term.cmi 
+kernel/term.cmx: kernel/esubst.cmx lib/hashcons.cmx kernel/names.cmx \
+    lib/pp.cmx kernel/univ.cmx lib/util.cmx kernel/term.cmi 
+kernel/term_typing.cmo: kernel/cooking.cmi kernel/declarations.cmi \
+    kernel/entries.cmi kernel/environ.cmi kernel/indtypes.cmi \
+    kernel/inductive.cmi kernel/names.cmi kernel/reduction.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \
+    kernel/univ.cmi lib/util.cmi kernel/term_typing.cmi 
+kernel/term_typing.cmx: kernel/cooking.cmx kernel/declarations.cmx \
+    kernel/entries.cmx kernel/environ.cmx kernel/indtypes.cmx \
+    kernel/inductive.cmx kernel/names.cmx kernel/reduction.cmx \
+    kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \
+    kernel/univ.cmx lib/util.cmx kernel/term_typing.cmi 
+kernel/type_errors.cmo: kernel/environ.cmi kernel/names.cmi \
+    kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/type_errors.cmi 
+kernel/type_errors.cmx: kernel/environ.cmx kernel/names.cmx \
+    kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/type_errors.cmi 
+kernel/typeops.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \
+    kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi kernel/typeops.cmi 
+kernel/typeops.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx kernel/inductive.cmx kernel/names.cmx \
+    kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx kernel/typeops.cmi 
+kernel/univ.cmo: lib/hashcons.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \
+    kernel/univ.cmi 
+kernel/univ.cmx: lib/hashcons.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \
+    kernel/univ.cmi 
+lib/bignat.cmo: lib/pp.cmi lib/bignat.cmi 
+lib/bignat.cmx: lib/pp.cmx lib/bignat.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 
+lib/dyn.cmx: lib/util.cmx lib/dyn.cmi 
+lib/edit.cmo: lib/bstack.cmi lib/pp.cmi lib/util.cmi lib/edit.cmi 
+lib/edit.cmx: lib/bstack.cmx lib/pp.cmx lib/util.cmx lib/edit.cmi 
+lib/explore.cmo: lib/explore.cmi 
+lib/explore.cmx: lib/explore.cmi 
+lib/gmapl.cmo: lib/gmap.cmi lib/util.cmi lib/gmapl.cmi 
+lib/gmapl.cmx: lib/gmap.cmx lib/util.cmx lib/gmapl.cmi 
+lib/gmap.cmo: lib/gmap.cmi 
+lib/gmap.cmx: lib/gmap.cmi 
+lib/gset.cmo: lib/gset.cmi 
+lib/gset.cmx: lib/gset.cmi 
+lib/hashcons.cmo: lib/hashcons.cmi 
+lib/hashcons.cmx: lib/hashcons.cmi 
+lib/heap.cmo: lib/heap.cmi 
+lib/heap.cmx: lib/heap.cmi 
+lib/options.cmo: lib/util.cmi lib/options.cmi 
+lib/options.cmx: lib/util.cmx lib/options.cmi 
+lib/pp_control.cmo: lib/pp_control.cmi 
+lib/pp_control.cmx: lib/pp_control.cmi 
+lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi 
+lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi 
+lib/predicate.cmo: lib/predicate.cmi 
+lib/predicate.cmx: lib/predicate.cmi 
+lib/profile.cmo: lib/profile.cmi 
+lib/profile.cmx: lib/profile.cmi 
+library/declare.cmo: library/decl_kinds.cmo kernel/declarations.cmi \
+    library/dischargedhypsmap.cmi kernel/entries.cmi kernel/environ.cmi \
+    library/global.cmi library/impargs.cmi kernel/indtypes.cmi \
+    kernel/inductive.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi kernel/reduction.cmi \
+    kernel/safe_typing.cmi kernel/sign.cmi library/summary.cmi \
+    interp/symbols.cmi kernel/term.cmi kernel/type_errors.cmi \
+    kernel/typeops.cmi kernel/univ.cmi lib/util.cmi library/declare.cmi 
+library/declare.cmx: library/decl_kinds.cmx kernel/declarations.cmx \
+    library/dischargedhypsmap.cmx kernel/entries.cmx kernel/environ.cmx \
+    library/global.cmx library/impargs.cmx kernel/indtypes.cmx \
+    kernel/inductive.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx kernel/reduction.cmx \
+    kernel/safe_typing.cmx kernel/sign.cmx library/summary.cmx \
+    interp/symbols.cmx kernel/term.cmx kernel/type_errors.cmx \
+    kernel/typeops.cmx kernel/univ.cmx lib/util.cmx library/declare.cmi 
+library/declaremods.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi library/global.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi kernel/mod_typing.cmi \
+    kernel/modops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \
+    kernel/subtyping.cmi library/summary.cmi lib/util.cmi \
+    library/declaremods.cmi 
+library/declaremods.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx library/global.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx kernel/mod_typing.cmx \
+    kernel/modops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \
+    kernel/subtyping.cmx library/summary.cmx lib/util.cmx \
+    library/declaremods.cmi 
+library/dischargedhypsmap.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/inductive.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi kernel/names.cmi library/nametab.cmi \
+    kernel/reduction.cmi library/summary.cmi kernel/term.cmi lib/util.cmi \
+    library/dischargedhypsmap.cmi 
+library/dischargedhypsmap.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/inductive.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx kernel/names.cmx library/nametab.cmx \
+    kernel/reduction.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \
+    library/dischargedhypsmap.cmi 
+library/global.cmo: kernel/environ.cmi kernel/inductive.cmi \
+    library/libnames.cmi kernel/names.cmi kernel/safe_typing.cmi \
+    kernel/sign.cmi library/summary.cmi kernel/term.cmi lib/util.cmi \
+    library/global.cmi 
+library/global.cmx: kernel/environ.cmx kernel/inductive.cmx \
+    library/libnames.cmx kernel/names.cmx kernel/safe_typing.cmx \
+    kernel/sign.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \
+    library/global.cmi 
+library/goptions.cmo: library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \
+    library/summary.cmi kernel/term.cmi lib/util.cmi library/goptions.cmi 
+library/goptions.cmx: library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \
+    library/summary.cmx kernel/term.cmx lib/util.cmx library/goptions.cmi 
+library/impargs.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    library/global.cmi kernel/inductive.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi kernel/reduction.cmi \
+    library/summary.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi lib/util.cmi library/impargs.cmi 
+library/impargs.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    library/global.cmx kernel/inductive.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx kernel/reduction.cmx \
+    library/summary.cmx kernel/term.cmx pretyping/termops.cmx \
+    interp/topconstr.cmx lib/util.cmx library/impargs.cmi 
+library/lib.cmo: library/libnames.cmi library/libobject.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi library/summary.cmi lib/util.cmi library/lib.cmi 
+library/lib.cmx: library/libnames.cmx library/libobject.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx library/summary.cmx lib/util.cmx library/lib.cmi 
+library/libnames.cmo: library/nameops.cmi kernel/names.cmi lib/pp.cmi \
+    lib/predicate.cmi kernel/term.cmi lib/util.cmi library/libnames.cmi 
+library/libnames.cmx: library/nameops.cmx kernel/names.cmx lib/pp.cmx \
+    lib/predicate.cmx kernel/term.cmx lib/util.cmx library/libnames.cmi 
+library/libobject.cmo: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \
+    lib/util.cmi library/libobject.cmi 
+library/libobject.cmx: lib/dyn.cmx library/libnames.cmx kernel/names.cmx \
+    lib/util.cmx library/libobject.cmi 
+library/library.cmo: library/declaremods.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \
+    kernel/safe_typing.cmi library/summary.cmi lib/system.cmi lib/util.cmi \
+    library/library.cmi 
+library/library.cmx: library/declaremods.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \
+    kernel/safe_typing.cmx library/summary.cmx lib/system.cmx lib/util.cmx \
+    library/library.cmi 
+library/nameops.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi \
+    library/nameops.cmi 
+library/nameops.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx \
+    library/nameops.cmi 
+library/nametab.cmo: kernel/declarations.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi lib/pp.cmi library/summary.cmi \
+    lib/util.cmi library/nametab.cmi 
+library/nametab.cmx: kernel/declarations.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx lib/pp.cmx library/summary.cmx \
+    lib/util.cmx library/nametab.cmi 
+library/states.cmo: library/lib.cmi library/library.cmi library/summary.cmi \
+    lib/system.cmi library/states.cmi 
+library/states.cmx: library/lib.cmx library/library.cmx library/summary.cmx \
+    lib/system.cmx library/states.cmi 
+library/summary.cmo: lib/dyn.cmi lib/pp.cmi lib/util.cmi library/summary.cmi 
+library/summary.cmx: lib/dyn.cmx lib/pp.cmx lib/util.cmx library/summary.cmi 
+lib/rtree.cmo: lib/pp.cmi lib/util.cmi lib/rtree.cmi 
+lib/rtree.cmx: lib/pp.cmx lib/util.cmx lib/rtree.cmi 
+lib/stamps.cmo: lib/stamps.cmi 
+lib/stamps.cmx: lib/stamps.cmi 
+lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi 
+lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi 
+lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi 
+lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi 
+lib/util.cmo: lib/compat.cmo lib/pp.cmi lib/util.cmi 
+lib/util.cmx: lib/compat.cmx lib/pp.cmx lib/util.cmi 
+parsing/argextend.cmo: parsing/ast.cmi interp/genarg.cmi parsing/pcoq.cmi \
+    parsing/q_coqast.cmo parsing/q_util.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/argextend.cmx: parsing/ast.cmx interp/genarg.cmx parsing/pcoq.cmx \
+    parsing/q_coqast.cmx parsing/q_util.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx 
+parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi lib/pp.cmi interp/topconstr.cmi \
+    lib/util.cmi parsing/ast.cmi 
+parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx interp/genarg.cmx \
+    library/libnames.cmx kernel/names.cmx lib/pp.cmx interp/topconstr.cmx \
+    lib/util.cmx parsing/ast.cmi 
+parsing/coqast.cmo: lib/dyn.cmi lib/hashcons.cmi library/libnames.cmi \
+    kernel/names.cmi lib/util.cmi parsing/coqast.cmi 
+parsing/coqast.cmx: lib/dyn.cmx lib/hashcons.cmx library/libnames.cmx \
+    kernel/names.cmx lib/util.cmx parsing/coqast.cmi 
+parsing/egrammar.cmo: parsing/ast.cmi lib/bignat.cmi parsing/extend.cmi \
+    interp/genarg.cmi parsing/lexer.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi library/summary.cmi proofs/tacexpr.cmo interp/topconstr.cmi \
+    lib/util.cmi toplevel/vernacexpr.cmo parsing/egrammar.cmi 
+parsing/egrammar.cmx: parsing/ast.cmx lib/bignat.cmx parsing/extend.cmx \
+    interp/genarg.cmx parsing/lexer.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx library/summary.cmx proofs/tacexpr.cmx interp/topconstr.cmx \
+    lib/util.cmx toplevel/vernacexpr.cmx parsing/egrammar.cmi 
+parsing/esyntax.cmo: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \
+    lib/gmap.cmi lib/gmapl.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi interp/ppextend.cmi \
+    interp/symbols.cmi interp/topconstr.cmi lib/util.cmi parsing/esyntax.cmi 
+parsing/esyntax.cmx: parsing/ast.cmx parsing/coqast.cmx parsing/extend.cmx \
+    lib/gmap.cmx lib/gmapl.cmx library/libnames.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx interp/ppextend.cmx \
+    interp/symbols.cmx interp/topconstr.cmx lib/util.cmx parsing/esyntax.cmi 
+parsing/extend.cmo: parsing/ast.cmi parsing/coqast.cmi interp/genarg.cmi \
+    parsing/lexer.cmi library/libnames.cmi kernel/names.cmi lib/options.cmi \
+    lib/pp.cmi interp/ppextend.cmi pretyping/rawterm.cmi interp/topconstr.cmi \
+    lib/util.cmi parsing/extend.cmi 
+parsing/extend.cmx: parsing/ast.cmx parsing/coqast.cmx interp/genarg.cmx \
+    parsing/lexer.cmx library/libnames.cmx kernel/names.cmx lib/options.cmx \
+    lib/pp.cmx interp/ppextend.cmx pretyping/rawterm.cmx interp/topconstr.cmx \
+    lib/util.cmx parsing/extend.cmi 
+parsing/g_basevernac.cmo: parsing/ast.cmi interp/constrintern.cmi \
+    parsing/coqast.cmi pretyping/evd.cmi parsing/extend.cmi \
+    library/global.cmi library/goptions.cmi parsing/lexer.cmi \
+    toplevel/metasyntax.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi interp/ppextend.cmi parsing/termast.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/g_basevernac.cmx: parsing/ast.cmx interp/constrintern.cmx \
+    parsing/coqast.cmx pretyping/evd.cmx parsing/extend.cmx \
+    library/global.cmx library/goptions.cmx parsing/lexer.cmx \
+    toplevel/metasyntax.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx interp/ppextend.cmx parsing/termast.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx 
+parsing/g_cases.cmo: parsing/g_constr.cmo library/libnames.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+parsing/g_cases.cmx: parsing/g_constr.cmx library/libnames.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx 
+parsing/g_constr.cmo: parsing/lexer.cmi library/libnames.cmi kernel/names.cmi \
+    lib/options.cmi pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi 
+parsing/g_constr.cmx: parsing/lexer.cmx library/libnames.cmx kernel/names.cmx \
+    lib/options.cmx pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx kernel/term.cmx interp/topconstr.cmx lib/util.cmx 
+parsing/g_constrnew.cmo: lib/bignat.cmi parsing/coqast.cmi parsing/lexer.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi \
+    lib/util.cmi 
+parsing/g_constrnew.cmx: lib/bignat.cmx parsing/coqast.cmx parsing/lexer.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx kernel/term.cmx interp/topconstr.cmx \
+    lib/util.cmx 
+parsing/g_ltac.cmo: parsing/ast.cmi interp/genarg.cmi library/libnames.cmi \
+    kernel/names.cmi lib/options.cmi pretyping/pattern.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \
+    lib/util.cmi toplevel/vernacexpr.cmo 
+parsing/g_ltac.cmx: parsing/ast.cmx interp/genarg.cmx library/libnames.cmx \
+    kernel/names.cmx lib/options.cmx pretyping/pattern.cmx parsing/pcoq.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \
+    lib/util.cmx toplevel/vernacexpr.cmx 
+parsing/g_ltacnew.cmo: parsing/ast.cmi interp/genarg.cmi kernel/names.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/g_ltacnew.cmx: parsing/ast.cmx interp/genarg.cmx kernel/names.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx \
+    proofs/tacexpr.cmx interp/topconstr.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx 
+parsing/g_minicoq.cmo: kernel/environ.cmi parsing/lexer.cmi kernel/names.cmi \
+    lib/pp.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \
+    parsing/g_minicoq.cmi 
+parsing/g_minicoq.cmx: kernel/environ.cmx parsing/lexer.cmx kernel/names.cmx \
+    lib/pp.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \
+    parsing/g_minicoq.cmi 
+parsing/g_module.cmo: parsing/ast.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi interp/topconstr.cmi lib/util.cmi 
+parsing/g_module.cmx: parsing/ast.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx interp/topconstr.cmx lib/util.cmx 
+parsing/g_natsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \
+    interp/coqlib.cmi parsing/esyntax.cmi parsing/extend.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi parsing/termast.cmi \
+    lib/util.cmi parsing/g_natsyntax.cmi 
+parsing/g_natsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \
+    interp/coqlib.cmx parsing/esyntax.cmx parsing/extend.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx parsing/termast.cmx \
+    lib/util.cmx parsing/g_natsyntax.cmi 
+parsing/g_prim.cmo: lib/bignat.cmi parsing/coqast.cmi library/libnames.cmi \
+    kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi \
+    interp/topconstr.cmi 
+parsing/g_prim.cmx: lib/bignat.cmx parsing/coqast.cmx library/libnames.cmx \
+    kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx \
+    interp/topconstr.cmx 
+parsing/g_primnew.cmo: lib/bignat.cmi parsing/coqast.cmi parsing/lexer.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    parsing/pcoq.cmi lib/pp.cmi interp/topconstr.cmi lib/util.cmi 
+parsing/g_primnew.cmx: lib/bignat.cmx parsing/coqast.cmx parsing/lexer.cmx \
+    library/libnames.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    parsing/pcoq.cmx lib/pp.cmx interp/topconstr.cmx lib/util.cmx 
+parsing/g_proofs.cmo: interp/genarg.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/g_proofs.cmx: interp/genarg.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx proofs/tacexpr.cmx interp/topconstr.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx 
+parsing/g_proofsnew.cmo: parsing/g_vernacnew.cmo interp/genarg.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi proofs/tacexpr.cmo \
+    interp/topconstr.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+parsing/g_proofsnew.cmx: parsing/g_vernacnew.cmx interp/genarg.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx proofs/tacexpr.cmx \
+    interp/topconstr.cmx lib/util.cmx toplevel/vernacexpr.cmx 
+parsing/g_rsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \
+    parsing/esyntax.cmi parsing/extend.cmi library/libnames.cmi \
+    kernel/names.cmi library/nametab.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi parsing/termast.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+parsing/g_rsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \
+    parsing/esyntax.cmx parsing/extend.cmx library/libnames.cmx \
+    kernel/names.cmx library/nametab.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx parsing/termast.cmx \
+    interp/topconstr.cmx lib/util.cmx 
+parsing/g_tactic.cmo: parsing/ast.cmi interp/genarg.cmi parsing/lexer.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi \
+    pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi 
+parsing/g_tactic.cmx: parsing/ast.cmx interp/genarg.cmx parsing/lexer.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx \
+    pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx \
+    proofs/tacexpr.cmx interp/topconstr.cmx lib/util.cmx 
+parsing/g_tacticnew.cmo: parsing/ast.cmi interp/genarg.cmi parsing/lexer.cmi \
+    kernel/names.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \
+    lib/util.cmi 
+parsing/g_tacticnew.cmx: parsing/ast.cmx interp/genarg.cmx parsing/lexer.cmx \
+    kernel/names.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \
+    lib/util.cmx 
+parsing/g_vernac.cmo: parsing/ast.cmi toplevel/class.cmi \
+    library/decl_kinds.cmo parsing/g_basevernac.cmo parsing/g_proofs.cmo \
+    interp/genarg.cmi library/goptions.cmi kernel/names.cmi lib/options.cmi \
+    parsing/pcoq.cmi lib/pp.cmi toplevel/recordobj.cmi interp/topconstr.cmi \
+    lib/util.cmi toplevel/vernacexpr.cmo 
+parsing/g_vernac.cmx: parsing/ast.cmx toplevel/class.cmx \
+    library/decl_kinds.cmx parsing/g_basevernac.cmx parsing/g_proofs.cmx \
+    interp/genarg.cmx library/goptions.cmx kernel/names.cmx lib/options.cmx \
+    parsing/pcoq.cmx lib/pp.cmx toplevel/recordobj.cmx interp/topconstr.cmx \
+    lib/util.cmx toplevel/vernacexpr.cmx 
+parsing/g_vernacnew.cmo: parsing/ast.cmi toplevel/class.cmi \
+    parsing/coqast.cmi library/decl_kinds.cmo parsing/egrammar.cmi \
+    parsing/extend.cmi parsing/g_constrnew.cmo interp/genarg.cmi \
+    library/goptions.cmi parsing/lexer.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    interp/ppextend.cmi toplevel/recordobj.cmi interp/topconstr.cmi \
+    lib/util.cmi toplevel/vernacexpr.cmo 
+parsing/g_vernacnew.cmx: parsing/ast.cmx toplevel/class.cmx \
+    parsing/coqast.cmx library/decl_kinds.cmx parsing/egrammar.cmx \
+    parsing/extend.cmx parsing/g_constrnew.cmx interp/genarg.cmx \
+    library/goptions.cmx parsing/lexer.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    interp/ppextend.cmx toplevel/recordobj.cmx interp/topconstr.cmx \
+    lib/util.cmx toplevel/vernacexpr.cmx 
+parsing/g_zsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \
+    interp/coqlib.cmi parsing/esyntax.cmi parsing/extend.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi parsing/termast.cmi \
+    interp/topconstr.cmi lib/util.cmi parsing/g_zsyntax.cmi 
+parsing/g_zsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \
+    interp/coqlib.cmx parsing/esyntax.cmx parsing/extend.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx parsing/termast.cmx \
+    interp/topconstr.cmx lib/util.cmx parsing/g_zsyntax.cmi 
+parsing/lexer.cmo: lib/options.cmi lib/pp.cmi lib/util.cmi parsing/lexer.cmi 
+parsing/lexer.cmx: lib/options.cmx lib/pp.cmx lib/util.cmx parsing/lexer.cmi 
+parsing/pcoq.cmo: parsing/ast.cmi parsing/coqast.cmi library/decl_kinds.cmo \
+    parsing/extend.cmi interp/genarg.cmi parsing/lexer.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \
+    interp/ppextend.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    interp/topconstr.cmi lib/util.cmi parsing/pcoq.cmi 
+parsing/pcoq.cmx: parsing/ast.cmx parsing/coqast.cmx library/decl_kinds.cmx \
+    parsing/extend.cmx interp/genarg.cmx parsing/lexer.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \
+    interp/ppextend.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx \
+    interp/topconstr.cmx lib/util.cmx parsing/pcoq.cmi 
+parsing/ppconstr.cmo: parsing/ast.cmi lib/bignat.cmi interp/constrextern.cmi \
+    parsing/coqast.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi interp/ppextend.cmi \
+    pretyping/rawterm.cmi interp/symbols.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi parsing/ppconstr.cmi 
+parsing/ppconstr.cmx: parsing/ast.cmx lib/bignat.cmx interp/constrextern.cmx \
+    parsing/coqast.cmx pretyping/evd.cmx interp/genarg.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx interp/ppextend.cmx \
+    pretyping/rawterm.cmx interp/symbols.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx parsing/ppconstr.cmi 
+parsing/pptactic.cmo: kernel/closure.cmi interp/constrextern.cmi lib/dyn.cmi \
+    parsing/extend.cmi interp/genarg.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    pretyping/pattern.cmi lib/pp.cmi parsing/ppconstr.cmi \
+    translate/ppconstrnew.cmi parsing/printer.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo kernel/term.cmi interp/topconstr.cmi lib/util.cmi \
+    parsing/pptactic.cmi 
+parsing/pptactic.cmx: kernel/closure.cmx interp/constrextern.cmx lib/dyn.cmx \
+    parsing/extend.cmx interp/genarg.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    pretyping/pattern.cmx lib/pp.cmx parsing/ppconstr.cmx \
+    translate/ppconstrnew.cmx parsing/printer.cmx pretyping/rawterm.cmx \
+    proofs/tacexpr.cmx kernel/term.cmx interp/topconstr.cmx lib/util.cmx \
+    parsing/pptactic.cmi 
+parsing/prettyp.cmo: pretyping/classops.cmi interp/constrextern.cmi \
+    kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi library/impargs.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi parsing/printer.cmi parsing/printmod.cmi kernel/reduction.cmi \
+    pretyping/reductionops.cmi kernel/safe_typing.cmi kernel/sign.cmi \
+    interp/symbols.cmi interp/syntax_def.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi parsing/prettyp.cmi 
+parsing/prettyp.cmx: pretyping/classops.cmx interp/constrextern.cmx \
+    kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx library/impargs.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx parsing/printer.cmx parsing/printmod.cmx kernel/reduction.cmx \
+    pretyping/reductionops.cmx kernel/safe_typing.cmx kernel/sign.cmx \
+    interp/symbols.cmx interp/syntax_def.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx parsing/prettyp.cmi 
+parsing/printer.cmo: parsing/ast.cmi interp/constrextern.cmi \
+    parsing/coqast.cmi library/declare.cmi lib/dyn.cmi kernel/environ.cmi \
+    parsing/esyntax.cmi parsing/extend.cmi library/global.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    parsing/ppconstr.cmi translate/ppconstrnew.cmi interp/ppextend.cmi \
+    kernel/sign.cmi kernel/term.cmi parsing/termast.cmi pretyping/termops.cmi \
+    lib/util.cmi parsing/printer.cmi 
+parsing/printer.cmx: parsing/ast.cmx interp/constrextern.cmx \
+    parsing/coqast.cmx library/declare.cmx lib/dyn.cmx kernel/environ.cmx \
+    parsing/esyntax.cmx parsing/extend.cmx library/global.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    parsing/ppconstr.cmx translate/ppconstrnew.cmx interp/ppextend.cmx \
+    kernel/sign.cmx kernel/term.cmx parsing/termast.cmx pretyping/termops.cmx \
+    lib/util.cmx parsing/printer.cmi 
+parsing/printmod.cmo: kernel/declarations.cmi library/global.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi lib/util.cmi parsing/printmod.cmi 
+parsing/printmod.cmx: kernel/declarations.cmx library/global.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx lib/util.cmx parsing/printmod.cmi 
+parsing/q_coqast.cmo: parsing/coqast.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi parsing/q_util.cmi \
+    pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \
+    lib/util.cmi 
+parsing/q_coqast.cmx: parsing/coqast.cmx interp/genarg.cmx \
+    library/libnames.cmx kernel/names.cmx parsing/pcoq.cmx parsing/q_util.cmx \
+    pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \
+    lib/util.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: parsing/coqast.cmi interp/coqlib.cmi \
+    kernel/declarations.cmi library/declare.cmi library/declaremods.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi \
+    kernel/inductive.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi pretyping/matching.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \
+    parsing/printer.cmi pretyping/rawterm.cmi kernel/term.cmi \
+    pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    parsing/search.cmi 
+parsing/search.cmx: parsing/coqast.cmx interp/coqlib.cmx \
+    kernel/declarations.cmx library/declare.cmx library/declaremods.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx \
+    kernel/inductive.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx pretyping/matching.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \
+    parsing/printer.cmx pretyping/rawterm.cmx kernel/term.cmx \
+    pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    parsing/search.cmi 
+parsing/tacextend.cmo: parsing/argextend.cmo interp/genarg.cmi \
+    parsing/pcoq.cmi lib/pp.cmi lib/pp_control.cmi parsing/q_coqast.cmo \
+    parsing/q_util.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+parsing/tacextend.cmx: parsing/argextend.cmx interp/genarg.cmx \
+    parsing/pcoq.cmx lib/pp.cmx lib/pp_control.cmx parsing/q_coqast.cmx \
+    parsing/q_util.cmx lib/util.cmx toplevel/vernacexpr.cmx 
+parsing/termast.cmo: parsing/ast.cmi pretyping/classops.cmi \
+    interp/constrextern.cmi parsing/coqast.cmi library/declare.cmi \
+    pretyping/detyping.cmi kernel/environ.cmi library/impargs.cmi \
+    kernel/inductive.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/univ.cmi lib/util.cmi \
+    parsing/termast.cmi 
+parsing/termast.cmx: parsing/ast.cmx pretyping/classops.cmx \
+    interp/constrextern.cmx parsing/coqast.cmx library/declare.cmx \
+    pretyping/detyping.cmx kernel/environ.cmx library/impargs.cmx \
+    kernel/inductive.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/univ.cmx lib/util.cmx \
+    parsing/termast.cmi 
+parsing/vernacextend.cmo: parsing/argextend.cmo parsing/ast.cmi \
+    interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi lib/pp_control.cmi \
+    parsing/q_coqast.cmo parsing/q_util.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo 
+parsing/vernacextend.cmx: parsing/argextend.cmx parsing/ast.cmx \
+    interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx lib/pp_control.cmx \
+    parsing/q_coqast.cmx parsing/q_util.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx 
+pretyping/cases.cmo: pretyping/coercion.cmi kernel/declarations.cmi \
+    kernel/environ.cmi pretyping/evarconv.cmi pretyping/evarutil.cmi \
+    library/global.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    library/nameops.cmi kernel/names.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi pretyping/rawterm.cmi \
+    pretyping/reductionops.cmi pretyping/retyping.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi \
+    kernel/typeops.cmi lib/util.cmi pretyping/cases.cmi 
+pretyping/cases.cmx: pretyping/coercion.cmx kernel/declarations.cmx \
+    kernel/environ.cmx pretyping/evarconv.cmx pretyping/evarutil.cmx \
+    library/global.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    library/nameops.cmx kernel/names.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx pretyping/rawterm.cmx \
+    pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx \
+    kernel/typeops.cmx lib/util.cmx pretyping/cases.cmi 
+pretyping/cbv.cmo: kernel/closure.cmi kernel/environ.cmi kernel/esubst.cmi \
+    pretyping/evd.cmi pretyping/instantiate.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/term.cmi kernel/univ.cmi lib/util.cmi pretyping/cbv.cmi 
+pretyping/cbv.cmx: kernel/closure.cmx kernel/environ.cmx kernel/esubst.cmx \
+    pretyping/evd.cmx pretyping/instantiate.cmx kernel/names.cmx lib/pp.cmx \
+    kernel/term.cmx kernel/univ.cmx lib/util.cmx pretyping/cbv.cmi 
+pretyping/classops.cmo: library/decl_kinds.cmo kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi lib/gmap.cmi library/goptions.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \
+    library/summary.cmi pretyping/tacred.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi pretyping/classops.cmi 
+pretyping/classops.cmx: library/decl_kinds.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx lib/gmap.cmx library/goptions.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \
+    library/summary.cmx pretyping/tacred.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx pretyping/classops.cmi 
+pretyping/coercion.cmo: pretyping/classops.cmi kernel/environ.cmi \
+    pretyping/evarconv.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    kernel/names.cmi pretyping/pretype_errors.cmi pretyping/rawterm.cmi \
+    pretyping/recordops.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \
+    kernel/term.cmi kernel/typeops.cmi lib/util.cmi pretyping/coercion.cmi 
+pretyping/coercion.cmx: pretyping/classops.cmx kernel/environ.cmx \
+    pretyping/evarconv.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    kernel/names.cmx pretyping/pretype_errors.cmx pretyping/rawterm.cmx \
+    pretyping/recordops.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \
+    kernel/term.cmx kernel/typeops.cmx lib/util.cmx pretyping/coercion.cmi 
+pretyping/detyping.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    library/global.cmi library/goptions.cmi kernel/inductive.cmi \
+    pretyping/inductiveops.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \
+    pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/univ.cmi lib/util.cmi pretyping/detyping.cmi 
+pretyping/detyping.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    library/global.cmx library/goptions.cmx kernel/inductive.cmx \
+    pretyping/inductiveops.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \
+    pretyping/rawterm.cmx kernel/sign.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/univ.cmx lib/util.cmx pretyping/detyping.cmi 
+pretyping/evarconv.cmo: pretyping/classops.cmi kernel/closure.cmi \
+    kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    pretyping/instantiate.cmi library/libnames.cmi kernel/names.cmi \
+    pretyping/rawterm.cmi pretyping/recordops.cmi pretyping/reductionops.cmi \
+    kernel/term.cmi pretyping/typing.cmi lib/util.cmi pretyping/evarconv.cmi 
+pretyping/evarconv.cmx: pretyping/classops.cmx kernel/closure.cmx \
+    kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    pretyping/instantiate.cmx library/libnames.cmx kernel/names.cmx \
+    pretyping/rawterm.cmx pretyping/recordops.cmx pretyping/reductionops.cmx \
+    kernel/term.cmx pretyping/typing.cmx lib/util.cmx pretyping/evarconv.cmi 
+pretyping/evarutil.cmo: kernel/environ.cmi pretyping/evd.cmi \
+    library/global.cmi pretyping/indrec.cmi pretyping/instantiate.cmi \
+    library/nameops.cmi kernel/names.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi pretyping/rawterm.cmi \
+    pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \
+    pretyping/evarutil.cmi 
+pretyping/evarutil.cmx: kernel/environ.cmx pretyping/evd.cmx \
+    library/global.cmx pretyping/indrec.cmx pretyping/instantiate.cmx \
+    library/nameops.cmx kernel/names.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx pretyping/rawterm.cmx \
+    pretyping/reductionops.cmx kernel/sign.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \
+    pretyping/evarutil.cmi 
+pretyping/evd.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \
+    lib/util.cmi pretyping/evd.cmi 
+pretyping/evd.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \
+    lib/util.cmx pretyping/evd.cmi 
+pretyping/indrec.cmo: kernel/declarations.cmi kernel/entries.cmi \
+    kernel/environ.cmi library/global.cmi kernel/indtypes.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi kernel/reduction.cmi \
+    pretyping/reductionops.cmi kernel/safe_typing.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/type_errors.cmi kernel/typeops.cmi \
+    lib/util.cmi pretyping/indrec.cmi 
+pretyping/indrec.cmx: kernel/declarations.cmx kernel/entries.cmx \
+    kernel/environ.cmx library/global.cmx kernel/indtypes.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx kernel/reduction.cmx \
+    pretyping/reductionops.cmx kernel/safe_typing.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/type_errors.cmx kernel/typeops.cmx \
+    lib/util.cmx pretyping/indrec.cmi 
+pretyping/inductiveops.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi kernel/inductive.cmi \
+    kernel/names.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/univ.cmi lib/util.cmi \
+    pretyping/inductiveops.cmi 
+pretyping/inductiveops.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx kernel/inductive.cmx \
+    kernel/names.cmx pretyping/reductionops.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/univ.cmx lib/util.cmx \
+    pretyping/inductiveops.cmi 
+pretyping/instantiate.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \
+    kernel/term.cmi lib/util.cmi pretyping/instantiate.cmi 
+pretyping/instantiate.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    pretyping/evd.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \
+    kernel/term.cmx lib/util.cmx pretyping/instantiate.cmi 
+pretyping/matching.cmo: kernel/environ.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi pretyping/matching.cmi 
+pretyping/matching.cmx: kernel/environ.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx pretyping/matching.cmi 
+pretyping/pattern.cmo: kernel/environ.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi \
+    pretyping/pattern.cmi 
+pretyping/pattern.cmx: kernel/environ.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx \
+    pretyping/pattern.cmi 
+pretyping/pretype_errors.cmo: kernel/environ.cmi pretyping/evd.cmi \
+    pretyping/inductiveops.cmi kernel/names.cmi pretyping/rawterm.cmi \
+    kernel/reduction.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi lib/util.cmi \
+    pretyping/pretype_errors.cmi 
+pretyping/pretype_errors.cmx: kernel/environ.cmx pretyping/evd.cmx \
+    pretyping/inductiveops.cmx kernel/names.cmx pretyping/rawterm.cmx \
+    kernel/reduction.cmx pretyping/reductionops.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx lib/util.cmx \
+    pretyping/pretype_errors.cmi 
+pretyping/pretyping.cmo: pretyping/cases.cmi pretyping/classops.cmi \
+    pretyping/coercion.cmi kernel/declarations.cmi pretyping/detyping.cmi \
+    lib/dyn.cmi kernel/environ.cmi pretyping/evarconv.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \
+    pretyping/indrec.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    pretyping/instantiate.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi pretyping/rawterm.cmi \
+    pretyping/recordops.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \
+    kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi \
+    kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \
+    pretyping/pretyping.cmi 
+pretyping/pretyping.cmx: pretyping/cases.cmx pretyping/classops.cmx \
+    pretyping/coercion.cmx kernel/declarations.cmx pretyping/detyping.cmx \
+    lib/dyn.cmx kernel/environ.cmx pretyping/evarconv.cmx \
+    pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \
+    pretyping/indrec.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    pretyping/instantiate.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx pretyping/rawterm.cmx \
+    pretyping/recordops.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \
+    kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \
+    kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \
+    pretyping/pretyping.cmi 
+pretyping/rawterm.cmo: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \
+    lib/util.cmi pretyping/rawterm.cmi 
+pretyping/rawterm.cmx: lib/dyn.cmx library/libnames.cmx kernel/names.cmx \
+    library/nametab.cmx kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \
+    lib/util.cmx pretyping/rawterm.cmi 
+pretyping/recordops.cmo: pretyping/classops.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi library/library.cmi \
+    kernel/names.cmi library/nametab.cmi lib/pp.cmi library/summary.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/typeops.cmi lib/util.cmi \
+    pretyping/recordops.cmi 
+pretyping/recordops.cmx: pretyping/classops.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx library/library.cmx \
+    kernel/names.cmx library/nametab.cmx lib/pp.cmx library/summary.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/typeops.cmx lib/util.cmx \
+    pretyping/recordops.cmi 
+pretyping/reductionops.cmo: kernel/closure.cmi kernel/declarations.cmi \
+    kernel/environ.cmi kernel/esubst.cmi pretyping/evd.cmi \
+    pretyping/instantiate.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/univ.cmi lib/util.cmi \
+    pretyping/reductionops.cmi 
+pretyping/reductionops.cmx: kernel/closure.cmx kernel/declarations.cmx \
+    kernel/environ.cmx kernel/esubst.cmx pretyping/evd.cmx \
+    pretyping/instantiate.cmx kernel/names.cmx lib/pp.cmx \
+    kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/univ.cmx lib/util.cmx \
+    pretyping/reductionops.cmi 
+pretyping/retyping.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \
+    kernel/names.cmi pretyping/reductionops.cmi kernel/term.cmi \
+    kernel/typeops.cmi kernel/univ.cmi lib/util.cmi pretyping/retyping.cmi 
+pretyping/retyping.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \
+    kernel/names.cmx pretyping/reductionops.cmx kernel/term.cmx \
+    kernel/typeops.cmx kernel/univ.cmx lib/util.cmx pretyping/retyping.cmi 
+pretyping/tacred.cmo: pretyping/cbv.cmi kernel/closure.cmi \
+    kernel/conv_oracle.cmi kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi kernel/inductive.cmi \
+    pretyping/instantiate.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \
+    pretyping/reductionops.cmi pretyping/retyping.cmi library/summary.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi pretyping/tacred.cmi 
+pretyping/tacred.cmx: pretyping/cbv.cmx kernel/closure.cmx \
+    kernel/conv_oracle.cmx kernel/declarations.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx kernel/inductive.cmx \
+    pretyping/instantiate.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx \
+    pretyping/reductionops.cmx pretyping/retyping.cmx library/summary.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx pretyping/tacred.cmi 
+pretyping/termops.cmo: kernel/environ.cmi library/global.cmi library/lib.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/univ.cmi lib/util.cmi pretyping/termops.cmi 
+pretyping/termops.cmx: kernel/environ.cmx library/global.cmx library/lib.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/univ.cmx lib/util.cmx pretyping/termops.cmi 
+pretyping/typing.cmo: kernel/environ.cmi kernel/inductive.cmi \
+    pretyping/instantiate.cmi kernel/names.cmi pretyping/pretype_errors.cmi \
+    pretyping/reductionops.cmi kernel/term.cmi kernel/type_errors.cmi \
+    kernel/typeops.cmi lib/util.cmi pretyping/typing.cmi 
+pretyping/typing.cmx: kernel/environ.cmx kernel/inductive.cmx \
+    pretyping/instantiate.cmx kernel/names.cmx pretyping/pretype_errors.cmx \
+    pretyping/reductionops.cmx kernel/term.cmx kernel/type_errors.cmx \
+    kernel/typeops.cmx lib/util.cmx pretyping/typing.cmi 
+proofs/clenv.cmo: pretyping/coercion.cmi kernel/environ.cmi \
+    proofs/evar_refiner.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    library/global.cmi pretyping/instantiate.cmi proofs/logic.cmi \
+    library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    pretyping/retyping.cmi kernel/sign.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi kernel/term.cmi pretyping/termops.cmi \
+    pretyping/typing.cmi lib/util.cmi proofs/clenv.cmi 
+proofs/clenv.cmx: pretyping/coercion.cmx kernel/environ.cmx \
+    proofs/evar_refiner.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    library/global.cmx pretyping/instantiate.cmx proofs/logic.cmx \
+    library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    pretyping/retyping.cmx kernel/sign.cmx proofs/tacexpr.cmx \
+    proofs/tacmach.cmx kernel/term.cmx pretyping/termops.cmx \
+    pretyping/typing.cmx lib/util.cmx proofs/clenv.cmi 
+proofs/evar_refiner.cmo: interp/constrintern.cmi kernel/environ.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \
+    pretyping/instantiate.cmi proofs/logic.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \
+    kernel/type_errors.cmi pretyping/typing.cmi lib/util.cmi \
+    proofs/evar_refiner.cmi 
+proofs/evar_refiner.cmx: interp/constrintern.cmx kernel/environ.cmx \
+    pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \
+    pretyping/instantiate.cmx proofs/logic.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    kernel/sign.cmx proofs/tacexpr.cmx pretyping/tacred.cmx kernel/term.cmx \
+    kernel/type_errors.cmx pretyping/typing.cmx lib/util.cmx \
+    proofs/evar_refiner.cmi 
+proofs/logic.cmo: interp/constrextern.cmi parsing/coqast.cmi \
+    kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    library/global.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi pretyping/pretype_errors.cmi parsing/printer.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \
+    pretyping/retyping.cmi kernel/sign.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/type_errors.cmi kernel/typeops.cmi \
+    pretyping/typing.cmi lib/util.cmi proofs/logic.cmi 
+proofs/logic.cmx: interp/constrextern.cmx parsing/coqast.cmx \
+    kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    library/global.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx pretyping/pretype_errors.cmx parsing/printer.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \
+    pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/type_errors.cmx kernel/typeops.cmx \
+    pretyping/typing.cmx lib/util.cmx proofs/logic.cmi 
+proofs/pfedit.cmo: library/decl_kinds.cmo kernel/declarations.cmi \
+    lib/edit.cmi kernel/entries.cmi kernel/environ.cmi \
+    proofs/evar_refiner.cmi pretyping/evd.cmi library/lib.cmi \
+    library/nameops.cmi kernel/names.cmi lib/pp.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi proofs/refiner.cmi kernel/safe_typing.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \
+    pretyping/typing.cmi lib/util.cmi proofs/pfedit.cmi 
+proofs/pfedit.cmx: library/decl_kinds.cmx kernel/declarations.cmx \
+    lib/edit.cmx kernel/entries.cmx kernel/environ.cmx \
+    proofs/evar_refiner.cmx pretyping/evd.cmx library/lib.cmx \
+    library/nameops.cmx kernel/names.cmx lib/pp.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx proofs/refiner.cmx kernel/safe_typing.cmx \
+    kernel/sign.cmx proofs/tacexpr.cmx proofs/tacmach.cmx kernel/term.cmx \
+    pretyping/typing.cmx lib/util.cmx proofs/pfedit.cmi 
+proofs/proof_trees.cmo: kernel/closure.cmi pretyping/detyping.cmi \
+    kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    library/global.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_type.cmi kernel/sign.cmi pretyping/tacred.cmi \
+    kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    proofs/proof_trees.cmi 
+proofs/proof_trees.cmx: kernel/closure.cmx pretyping/detyping.cmx \
+    kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    library/global.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/printer.cmx \
+    proofs/proof_type.cmx kernel/sign.cmx pretyping/tacred.cmx \
+    kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    proofs/proof_trees.cmi 
+proofs/proof_type.cmo: kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    kernel/term.cmi lib/util.cmi proofs/proof_type.cmi 
+proofs/proof_type.cmx: kernel/environ.cmx pretyping/evd.cmx interp/genarg.cmx \
+    library/libnames.cmx kernel/names.cmx library/nametab.cmx \
+    pretyping/pattern.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx \
+    kernel/term.cmx lib/util.cmx proofs/proof_type.cmi 
+proofs/refiner.cmo: kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/evd.cmi library/global.cmi pretyping/instantiate.cmi \
+    proofs/logic.cmi lib/options.cmi lib/pp.cmi parsing/pptactic.cmi \
+    translate/pptacticnew.cmi parsing/printer.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo kernel/term.cmi pretyping/termops.cmi \
+    kernel/type_errors.cmi lib/util.cmi proofs/refiner.cmi 
+proofs/refiner.cmx: kernel/environ.cmx pretyping/evarutil.cmx \
+    pretyping/evd.cmx library/global.cmx pretyping/instantiate.cmx \
+    proofs/logic.cmx lib/options.cmx lib/pp.cmx parsing/pptactic.cmx \
+    translate/pptacticnew.cmx parsing/printer.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx pretyping/reductionops.cmx kernel/sign.cmx \
+    proofs/tacexpr.cmx kernel/term.cmx pretyping/termops.cmx \
+    kernel/type_errors.cmx lib/util.cmx proofs/refiner.cmi 
+proofs/tacexpr.cmo: library/decl_kinds.cmo lib/dyn.cmi interp/genarg.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi pretyping/rawterm.cmi kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+proofs/tacexpr.cmx: library/decl_kinds.cmx lib/dyn.cmx interp/genarg.cmx \
+    library/libnames.cmx kernel/names.cmx library/nametab.cmx \
+    pretyping/pattern.cmx pretyping/rawterm.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx 
+proofs/tacmach.cmo: interp/constrintern.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi pretyping/instantiate.cmi \
+    proofs/logic.cmi library/nameops.cmi kernel/names.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \
+    pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    proofs/tacmach.cmi 
+proofs/tacmach.cmx: interp/constrintern.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx pretyping/instantiate.cmx \
+    proofs/logic.cmx library/nameops.cmx kernel/names.cmx lib/pp.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    kernel/sign.cmx proofs/tacexpr.cmx pretyping/tacred.cmx kernel/term.cmx \
+    pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    proofs/tacmach.cmi 
+proofs/tactic_debug.cmo: parsing/ast.cmi interp/constrextern.cmi \
+    library/global.cmi proofs/logic.cmi kernel/names.cmi lib/options.cmi \
+    lib/pp.cmi parsing/pptactic.cmi translate/pptacticnew.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi pretyping/termops.cmi proofs/tactic_debug.cmi 
+proofs/tactic_debug.cmx: parsing/ast.cmx interp/constrextern.cmx \
+    library/global.cmx proofs/logic.cmx kernel/names.cmx lib/options.cmx \
+    lib/pp.cmx parsing/pptactic.cmx translate/pptacticnew.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx proofs/tacexpr.cmx \
+    proofs/tacmach.cmx pretyping/termops.cmx proofs/tactic_debug.cmi 
+scripts/coqc.cmo: config/coq_config.cmi toplevel/usage.cmi 
+scripts/coqc.cmx: config/coq_config.cmx toplevel/usage.cmx 
+scripts/coqmktop.cmo: config/coq_config.cmi scripts/tolink.cmo 
+scripts/coqmktop.cmx: config/coq_config.cmx scripts/tolink.cmx 
+tactics/auto.cmo: tactics/btermdn.cmi proofs/clenv.cmi \
+    interp/constrintern.cmi kernel/declarations.cmi tactics/dhyp.cmi \
+    proofs/evar_refiner.cmi pretyping/evd.cmi library/global.cmi \
+    tactics/hiddentac.cmi tactics/hipattern.cmi kernel/inductive.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi proofs/logic.cmi pretyping/matching.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    pretyping/pattern.cmi proofs/pfedit.cmi lib/pp.cmi parsing/pptactic.cmi \
+    parsing/printer.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \
+    kernel/reduction.cmi proofs/refiner.cmi kernel/sign.cmi \
+    library/summary.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    pretyping/tacred.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo tactics/auto.cmi 
+tactics/auto.cmx: tactics/btermdn.cmx proofs/clenv.cmx \
+    interp/constrintern.cmx kernel/declarations.cmx tactics/dhyp.cmx \
+    proofs/evar_refiner.cmx pretyping/evd.cmx library/global.cmx \
+    tactics/hiddentac.cmx tactics/hipattern.cmx kernel/inductive.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx proofs/logic.cmx pretyping/matching.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    pretyping/pattern.cmx proofs/pfedit.cmx lib/pp.cmx parsing/pptactic.cmx \
+    parsing/printer.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \
+    kernel/reduction.cmx proofs/refiner.cmx kernel/sign.cmx \
+    library/summary.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \
+    pretyping/tacred.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx tactics/auto.cmi 
+tactics/autorewrite.cmo: parsing/ast.cmi parsing/coqast.cmi \
+    tactics/equality.cmi tactics/hipattern.cmi library/lib.cmi \
+    library/libobject.cmi kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi \
+    library/summary.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \
+    toplevel/vernacinterp.cmi tactics/autorewrite.cmi 
+tactics/autorewrite.cmx: parsing/ast.cmx parsing/coqast.cmx \
+    tactics/equality.cmx tactics/hipattern.cmx library/lib.cmx \
+    library/libobject.cmx kernel/names.cmx lib/pp.cmx proofs/proof_type.cmx \
+    library/summary.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx \
+    toplevel/vernacinterp.cmx tactics/autorewrite.cmi 
+tactics/btermdn.cmo: tactics/dn.cmi pretyping/pattern.cmi kernel/term.cmi \
+    tactics/termdn.cmi tactics/btermdn.cmi 
+tactics/btermdn.cmx: tactics/dn.cmx pretyping/pattern.cmx kernel/term.cmx \
+    tactics/termdn.cmx tactics/btermdn.cmi 
+tactics/contradiction.cmo: interp/coqlib.cmi tactics/hipattern.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi lib/util.cmi tactics/contradiction.cmi 
+tactics/contradiction.cmx: interp/coqlib.cmx tactics/hipattern.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx lib/util.cmx tactics/contradiction.cmi 
+tactics/dhyp.cmo: parsing/ast.cmi proofs/clenv.cmi interp/constrintern.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi library/library.cmi \
+    pretyping/matching.cmi kernel/names.cmi tactics/nbtermdn.cmi \
+    pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi proofs/refiner.cmi \
+    library/summary.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \
+    tactics/dhyp.cmi 
+tactics/dhyp.cmx: parsing/ast.cmx proofs/clenv.cmx interp/constrintern.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx library/library.cmx \
+    pretyping/matching.cmx kernel/names.cmx tactics/nbtermdn.cmx \
+    pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx kernel/reduction.cmx proofs/refiner.cmx \
+    library/summary.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.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: tactics/auto.cmi toplevel/cerrors.cmi proofs/clenv.cmi \
+    kernel/declarations.cmi parsing/egrammar.cmi proofs/evar_refiner.cmi \
+    lib/explore.cmi parsing/extend.cmi interp/genarg.cmi library/global.cmi \
+    proofs/logic.cmi library/nameops.cmi kernel/names.cmi lib/options.cmi \
+    pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \
+    kernel/reduction.cmi proofs/refiner.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi tactics/eauto.cmi 
+tactics/eauto.cmx: tactics/auto.cmx toplevel/cerrors.cmx proofs/clenv.cmx \
+    kernel/declarations.cmx parsing/egrammar.cmx proofs/evar_refiner.cmx \
+    lib/explore.cmx parsing/extend.cmx interp/genarg.cmx library/global.cmx \
+    proofs/logic.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \
+    pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \
+    kernel/reduction.cmx proofs/refiner.cmx kernel/sign.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx tactics/eauto.cmi 
+tactics/elim.cmo: proofs/clenv.cmi kernel/environ.cmi interp/genarg.cmi \
+    tactics/hiddentac.cmi tactics/hipattern.cmi pretyping/inductiveops.cmi \
+    library/libnames.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_type.cmi kernel/reduction.cmi proofs/refiner.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    tactics/elim.cmi 
+tactics/elim.cmx: proofs/clenv.cmx kernel/environ.cmx interp/genarg.cmx \
+    tactics/hiddentac.cmx tactics/hipattern.cmx pretyping/inductiveops.cmx \
+    library/libnames.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \
+    proofs/proof_type.cmx kernel/reduction.cmx proofs/refiner.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    tactics/elim.cmi 
+tactics/eqdecide.cmo: tactics/auto.cmi toplevel/cerrors.cmi interp/coqlib.cmi \
+    kernel/declarations.cmi parsing/egrammar.cmi tactics/equality.cmi \
+    tactics/extratactics.cmi interp/genarg.cmi library/global.cmi \
+    tactics/hiddentac.cmi tactics/hipattern.cmi pretyping/matching.cmi \
+    library/nameops.cmi kernel/names.cmi lib/options.cmi \
+    pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \
+    proofs/refiner.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi lib/util.cmi 
+tactics/eqdecide.cmx: tactics/auto.cmx toplevel/cerrors.cmx interp/coqlib.cmx \
+    kernel/declarations.cmx parsing/egrammar.cmx tactics/equality.cmx \
+    tactics/extratactics.cmx interp/genarg.cmx library/global.cmx \
+    tactics/hiddentac.cmx tactics/hipattern.cmx pretyping/matching.cmx \
+    library/nameops.cmx kernel/names.cmx lib/options.cmx \
+    pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \
+    proofs/refiner.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx lib/util.cmx 
+tactics/equality.cmo: proofs/clenv.cmi interp/coqlib.cmi \
+    kernel/declarations.cmi kernel/environ.cmi proofs/evar_refiner.cmi \
+    pretyping/evarconv.cmi pretyping/evarutil.cmi tactics/hipattern.cmi \
+    pretyping/indrec.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    pretyping/instantiate.cmi proofs/logic.cmi pretyping/matching.cmi \
+    library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \
+    pretyping/retyping.cmi tactics/setoid_replace.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi pretyping/tacred.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/typeops.cmi pretyping/typing.cmi \
+    kernel/univ.cmi lib/util.cmi toplevel/vernacexpr.cmo tactics/equality.cmi 
+tactics/equality.cmx: proofs/clenv.cmx interp/coqlib.cmx \
+    kernel/declarations.cmx kernel/environ.cmx proofs/evar_refiner.cmx \
+    pretyping/evarconv.cmx pretyping/evarutil.cmx tactics/hipattern.cmx \
+    pretyping/indrec.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    pretyping/instantiate.cmx proofs/logic.cmx pretyping/matching.cmx \
+    library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \
+    pretyping/retyping.cmx tactics/setoid_replace.cmx kernel/sign.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx pretyping/tacred.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/typeops.cmx pretyping/typing.cmx \
+    kernel/univ.cmx lib/util.cmx toplevel/vernacexpr.cmx tactics/equality.cmi 
+tactics/extraargs.cmo: parsing/extend.cmi interp/genarg.cmi \
+    toplevel/metasyntax.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    tactics/tacinterp.cmi tactics/extraargs.cmi 
+tactics/extraargs.cmx: parsing/extend.cmx interp/genarg.cmx \
+    toplevel/metasyntax.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    tactics/tacinterp.cmx tactics/extraargs.cmi 
+tactics/extratactics.cmo: tactics/autorewrite.cmi toplevel/cerrors.cmi \
+    interp/constrintern.cmi tactics/contradiction.cmi parsing/egrammar.cmi \
+    tactics/equality.cmi pretyping/evd.cmi tactics/extraargs.cmi \
+    interp/genarg.cmi library/global.cmi tactics/inv.cmi tactics/leminv.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/nametab.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi pretyping/rawterm.cmi tactics/refine.cmi \
+    proofs/refiner.cmi tactics/setoid_replace.cmi library/summary.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi lib/util.cmi \
+    toplevel/vernacinterp.cmi tactics/extratactics.cmi 
+tactics/extratactics.cmx: tactics/autorewrite.cmx toplevel/cerrors.cmx \
+    interp/constrintern.cmx tactics/contradiction.cmx parsing/egrammar.cmx \
+    tactics/equality.cmx pretyping/evd.cmx tactics/extraargs.cmx \
+    interp/genarg.cmx library/global.cmx tactics/inv.cmx tactics/leminv.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/nametab.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx pretyping/rawterm.cmx tactics/refine.cmx \
+    proofs/refiner.cmx tactics/setoid_replace.cmx library/summary.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx lib/util.cmx \
+    toplevel/vernacinterp.cmx tactics/extratactics.cmi 
+tactics/hiddentac.cmo: proofs/evar_refiner.cmi interp/genarg.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi proofs/refiner.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tactics.cmi kernel/term.cmi \
+    lib/util.cmi tactics/hiddentac.cmi 
+tactics/hiddentac.cmx: proofs/evar_refiner.cmx interp/genarg.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx proofs/refiner.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tactics.cmx kernel/term.cmx \
+    lib/util.cmx tactics/hiddentac.cmi 
+tactics/hipattern.cmo: proofs/clenv.cmi interp/coqlib.cmi \
+    kernel/declarations.cmi kernel/environ.cmi pretyping/evd.cmi \
+    library/global.cmi pretyping/inductiveops.cmi pretyping/matching.cmi \
+    library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \
+    proofs/proof_trees.cmi pretyping/reductionops.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    tactics/hipattern.cmi 
+tactics/hipattern.cmx: proofs/clenv.cmx interp/coqlib.cmx \
+    kernel/declarations.cmx kernel/environ.cmx pretyping/evd.cmx \
+    library/global.cmx pretyping/inductiveops.cmx pretyping/matching.cmx \
+    library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \
+    proofs/proof_trees.cmx pretyping/reductionops.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    tactics/hipattern.cmi 
+tactics/inv.cmo: proofs/clenv.cmi interp/coqlib.cmi tactics/elim.cmi \
+    kernel/environ.cmi tactics/equality.cmi proofs/evar_refiner.cmi \
+    interp/genarg.cmi library/global.cmi tactics/hipattern.cmi \
+    pretyping/inductiveops.cmi pretyping/matching.cmi library/nameops.cmi \
+    kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \
+    pretyping/reductionops.cmi pretyping/retyping.cmi kernel/sign.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi \
+    pretyping/typing.cmi lib/util.cmi tactics/inv.cmi 
+tactics/inv.cmx: proofs/clenv.cmx interp/coqlib.cmx tactics/elim.cmx \
+    kernel/environ.cmx tactics/equality.cmx proofs/evar_refiner.cmx \
+    interp/genarg.cmx library/global.cmx tactics/hipattern.cmx \
+    pretyping/inductiveops.cmx pretyping/matching.cmx library/nameops.cmx \
+    kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx parsing/printer.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \
+    pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx \
+    pretyping/typing.cmx lib/util.cmx tactics/inv.cmi 
+tactics/leminv.cmo: proofs/clenv.cmi interp/constrintern.cmi \
+    library/decl_kinds.cmo kernel/declarations.cmi library/declare.cmi \
+    kernel/entries.cmi kernel/environ.cmi proofs/evar_refiner.cmi \
+    pretyping/evd.cmi library/global.cmi pretyping/inductiveops.cmi \
+    tactics/inv.cmi library/nameops.cmi kernel/names.cmi proofs/pfedit.cmi \
+    lib/pp.cmi pretyping/pretyping.cmi parsing/printer.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \
+    kernel/safe_typing.cmi kernel/sign.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    tactics/leminv.cmi 
+tactics/leminv.cmx: proofs/clenv.cmx interp/constrintern.cmx \
+    library/decl_kinds.cmx kernel/declarations.cmx library/declare.cmx \
+    kernel/entries.cmx kernel/environ.cmx proofs/evar_refiner.cmx \
+    pretyping/evd.cmx library/global.cmx pretyping/inductiveops.cmx \
+    tactics/inv.cmx library/nameops.cmx kernel/names.cmx proofs/pfedit.cmx \
+    lib/pp.cmx pretyping/pretyping.cmx parsing/printer.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \
+    kernel/safe_typing.cmx kernel/sign.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    tactics/leminv.cmi 
+tactics/nbtermdn.cmo: tactics/btermdn.cmi lib/gmap.cmi library/libobject.cmi \
+    library/library.cmi kernel/names.cmi pretyping/pattern.cmi \
+    kernel/term.cmi tactics/termdn.cmi lib/util.cmi tactics/nbtermdn.cmi 
+tactics/nbtermdn.cmx: tactics/btermdn.cmx lib/gmap.cmx library/libobject.cmx \
+    library/library.cmx kernel/names.cmx pretyping/pattern.cmx \
+    kernel/term.cmx tactics/termdn.cmx lib/util.cmx tactics/nbtermdn.cmi 
+tactics/refine.cmo: proofs/clenv.cmi kernel/environ.cmi pretyping/evd.cmi \
+    kernel/names.cmi lib/pp.cmi parsing/printer.cmi kernel/reduction.cmi \
+    pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    tactics/refine.cmi 
+tactics/refine.cmx: proofs/clenv.cmx kernel/environ.cmx pretyping/evd.cmx \
+    kernel/names.cmx lib/pp.cmx parsing/printer.cmx kernel/reduction.cmx \
+    pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    tactics/refine.cmi 
+tactics/setoid_replace.cmo: tactics/auto.cmi interp/constrintern.cmi \
+    interp/coqlib.cmi library/decl_kinds.cmo library/declare.cmi \
+    kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi \
+    library/global.cmi lib/gmap.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi proofs/pfedit.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \
+    kernel/safe_typing.cmi library/summary.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo tactics/setoid_replace.cmi 
+tactics/setoid_replace.cmx: tactics/auto.cmx interp/constrintern.cmx \
+    interp/coqlib.cmx library/decl_kinds.cmx library/declare.cmx \
+    kernel/entries.cmx kernel/environ.cmx pretyping/evd.cmx \
+    library/global.cmx lib/gmap.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx proofs/pfedit.cmx lib/pp.cmx \
+    parsing/printer.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \
+    kernel/safe_typing.cmx library/summary.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx tactics/setoid_replace.cmi 
+tactics/tacinterp.cmo: parsing/ast.cmi tactics/auto.cmi kernel/closure.cmi \
+    interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi tactics/dhyp.cmi lib/dyn.cmi tactics/elim.cmi \
+    kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/global.cmi lib/gmap.cmi tactics/hiddentac.cmi tactics/inv.cmi \
+    tactics/leminv.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi proofs/logic.cmi pretyping/matching.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    pretyping/pattern.cmi proofs/pfedit.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi pretyping/pretyping.cmi parsing/printer.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi proofs/refiner.cmi \
+    pretyping/retyping.cmi kernel/safe_typing.cmi kernel/sign.cmi \
+    library/summary.cmi interp/syntax_def.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi pretyping/tacred.cmi proofs/tactic_debug.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi pretyping/typing.cmi lib/util.cmi \
+    tactics/tacinterp.cmi 
+tactics/tacinterp.cmx: parsing/ast.cmx tactics/auto.cmx kernel/closure.cmx \
+    interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \
+    kernel/declarations.cmx tactics/dhyp.cmx lib/dyn.cmx tactics/elim.cmx \
+    kernel/entries.cmx kernel/environ.cmx pretyping/evd.cmx interp/genarg.cmx \
+    library/global.cmx lib/gmap.cmx tactics/hiddentac.cmx tactics/inv.cmx \
+    tactics/leminv.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx proofs/logic.cmx pretyping/matching.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    pretyping/pattern.cmx proofs/pfedit.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx pretyping/pretyping.cmx parsing/printer.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx proofs/refiner.cmx \
+    pretyping/retyping.cmx kernel/safe_typing.cmx kernel/sign.cmx \
+    library/summary.cmx interp/syntax_def.cmx proofs/tacexpr.cmx \
+    proofs/tacmach.cmx pretyping/tacred.cmx proofs/tactic_debug.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx \
+    interp/topconstr.cmx pretyping/typing.cmx lib/util.cmx \
+    tactics/tacinterp.cmi 
+tactics/tacticals.cmo: proofs/clenv.cmi kernel/declarations.cmi \
+    kernel/environ.cmi proofs/evar_refiner.cmi interp/genarg.cmi \
+    library/global.cmi pretyping/indrec.cmi kernel/inductive.cmi \
+    library/libnames.cmi pretyping/matching.cmi kernel/names.cmi \
+    pretyping/pattern.cmi lib/pp.cmi kernel/reduction.cmi proofs/refiner.cmi \
+    kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi tactics/tacticals.cmi 
+tactics/tacticals.cmx: proofs/clenv.cmx kernel/declarations.cmx \
+    kernel/environ.cmx proofs/evar_refiner.cmx interp/genarg.cmx \
+    library/global.cmx pretyping/indrec.cmx kernel/inductive.cmx \
+    library/libnames.cmx pretyping/matching.cmx kernel/names.cmx \
+    pretyping/pattern.cmx lib/pp.cmx kernel/reduction.cmx proofs/refiner.cmx \
+    kernel/sign.cmx proofs/tacexpr.cmx proofs/tacmach.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx tactics/tacticals.cmi 
+tactics/tactics.cmo: proofs/clenv.cmi interp/constrintern.cmi \
+    interp/coqlib.cmi library/decl_kinds.cmo kernel/declarations.cmi \
+    library/declare.cmi kernel/entries.cmi kernel/environ.cmi \
+    proofs/evar_refiner.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/global.cmi tactics/hipattern.cmi pretyping/indrec.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.cmi \
+    proofs/logic.cmi library/nameops.cmi kernel/names.cmi library/nametab.cmi \
+    lib/options.cmi proofs/pfedit.cmi lib/pp.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \
+    proofs/refiner.cmi kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi tactics/tactics.cmi 
+tactics/tactics.cmx: proofs/clenv.cmx interp/constrintern.cmx \
+    interp/coqlib.cmx library/decl_kinds.cmx kernel/declarations.cmx \
+    library/declare.cmx kernel/entries.cmx kernel/environ.cmx \
+    proofs/evar_refiner.cmx pretyping/evd.cmx interp/genarg.cmx \
+    library/global.cmx tactics/hipattern.cmx pretyping/indrec.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx library/libnames.cmx \
+    proofs/logic.cmx library/nameops.cmx kernel/names.cmx library/nametab.cmx \
+    lib/options.cmx proofs/pfedit.cmx lib/pp.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \
+    proofs/refiner.cmx kernel/sign.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \
+    pretyping/tacred.cmx tactics/tacticals.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx tactics/tactics.cmi 
+tactics/tauto.cmo: parsing/ast.cmi toplevel/cerrors.cmi parsing/coqast.cmi \
+    parsing/egrammar.cmi interp/genarg.cmi tactics/hipattern.cmi \
+    library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    lib/pp.cmi parsing/pptactic.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi proofs/refiner.cmi proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    interp/topconstr.cmi lib/util.cmi 
+tactics/tauto.cmx: parsing/ast.cmx toplevel/cerrors.cmx parsing/coqast.cmx \
+    parsing/egrammar.cmx interp/genarg.cmx tactics/hipattern.cmx \
+    library/libnames.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    lib/pp.cmx parsing/pptactic.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx proofs/refiner.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    interp/topconstr.cmx lib/util.cmx 
+tactics/termdn.cmo: tactics/dn.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi \
+    pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi tactics/termdn.cmi 
+tactics/termdn.cmx: tactics/dn.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx pretyping/pattern.cmx \
+    pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx tactics/termdn.cmi 
+tools/coqdep.cmo: config/coq_config.cmi tools/coqdep_lexer.cmo 
+tools/coqdep.cmx: config/coq_config.cmx tools/coqdep_lexer.cmx 
+tools/gallina.cmo: tools/gallina_lexer.cmo 
+tools/gallina.cmx: tools/gallina_lexer.cmx 
+toplevel/cerrors.cmo: parsing/ast.cmi pretyping/cases.cmi toplevel/himsg.cmi \
+    kernel/indtypes.cmi parsing/lexer.cmi library/libnames.cmi \
+    proofs/logic.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \
+    pretyping/pretype_errors.cmi proofs/refiner.cmi proofs/tactic_debug.cmi \
+    kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi toplevel/cerrors.cmi 
+toplevel/cerrors.cmx: parsing/ast.cmx pretyping/cases.cmx toplevel/himsg.cmx \
+    kernel/indtypes.cmx parsing/lexer.cmx library/libnames.cmx \
+    proofs/logic.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \
+    pretyping/pretype_errors.cmx proofs/refiner.cmx proofs/tactic_debug.cmx \
+    kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx toplevel/cerrors.cmi 
+toplevel/class.cmo: pretyping/classops.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi library/declare.cmi kernel/entries.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi \
+    kernel/inductive.cmi library/lib.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi parsing/printer.cmi pretyping/reductionops.cmi \
+    pretyping/retyping.cmi kernel/safe_typing.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/class.cmi 
+toplevel/class.cmx: pretyping/classops.cmx library/decl_kinds.cmx \
+    kernel/declarations.cmx library/declare.cmx kernel/entries.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx \
+    kernel/inductive.cmx library/lib.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx parsing/printer.cmx pretyping/reductionops.cmx \
+    pretyping/retyping.cmx kernel/safe_typing.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/class.cmi 
+toplevel/command.cmo: toplevel/class.cmi interp/constrextern.cmi \
+    interp/constrintern.cmi library/decl_kinds.cmo kernel/declarations.cmi \
+    library/declare.cmi kernel/entries.cmi kernel/environ.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \
+    library/impargs.cmi pretyping/indrec.cmi kernel/indtypes.cmi \
+    kernel/inductive.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi proofs/logic.cmi \
+    toplevel/metasyntax.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi proofs/pfedit.cmi lib/pp.cmi \
+    pretyping/pretyping.cmi parsing/printer.cmi proofs/proof_type.cmi \
+    kernel/reduction.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \
+    kernel/safe_typing.cmi library/states.cmi interp/symbols.cmi \
+    interp/syntax_def.cmi proofs/tacmach.cmi pretyping/tacred.cmi \
+    kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi \
+    kernel/typeops.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    toplevel/command.cmi 
+toplevel/command.cmx: toplevel/class.cmx interp/constrextern.cmx \
+    interp/constrintern.cmx library/decl_kinds.cmx kernel/declarations.cmx \
+    library/declare.cmx kernel/entries.cmx kernel/environ.cmx \
+    pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \
+    library/impargs.cmx pretyping/indrec.cmx kernel/indtypes.cmx \
+    kernel/inductive.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/library.cmx proofs/logic.cmx \
+    toplevel/metasyntax.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx proofs/pfedit.cmx lib/pp.cmx \
+    pretyping/pretyping.cmx parsing/printer.cmx proofs/proof_type.cmx \
+    kernel/reduction.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \
+    kernel/safe_typing.cmx library/states.cmx interp/symbols.cmx \
+    interp/syntax_def.cmx proofs/tacmach.cmx pretyping/tacred.cmx \
+    kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \
+    kernel/typeops.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    toplevel/command.cmi 
+toplevel/coqinit.cmo: config/coq_config.cmi toplevel/mltop.cmi \
+    library/nameops.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \
+    lib/system.cmi toplevel/toplevel.cmi toplevel/vernac.cmi \
+    toplevel/coqinit.cmi 
+toplevel/coqinit.cmx: config/coq_config.cmx toplevel/mltop.cmx \
+    library/nameops.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \
+    lib/system.cmx toplevel/toplevel.cmx toplevel/vernac.cmx \
+    toplevel/coqinit.cmi 
+toplevel/coqtop.cmo: toplevel/cerrors.cmi config/coq_config.cmi \
+    toplevel/coqinit.cmi library/declaremods.cmi kernel/environ.cmi \
+    library/global.cmi library/lib.cmi library/libnames.cmi \
+    library/library.cmi toplevel/mltop.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi lib/profile.cmi \
+    library/states.cmi lib/system.cmi toplevel/toplevel.cmi \
+    toplevel/usage.cmi lib/util.cmi toplevel/vernac.cmi toplevel/coqtop.cmi 
+toplevel/coqtop.cmx: toplevel/cerrors.cmx config/coq_config.cmx \
+    toplevel/coqinit.cmx library/declaremods.cmx kernel/environ.cmx \
+    library/global.cmx library/lib.cmx library/libnames.cmx \
+    library/library.cmx toplevel/mltop.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx lib/profile.cmx \
+    library/states.cmx lib/system.cmx toplevel/toplevel.cmx \
+    toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx toplevel/coqtop.cmi 
+toplevel/discharge.cmo: toplevel/class.cmi pretyping/classops.cmi \
+    kernel/cooking.cmi library/decl_kinds.cmo kernel/declarations.cmi \
+    library/declare.cmi library/dischargedhypsmap.cmi kernel/entries.cmi \
+    kernel/environ.cmi library/global.cmi library/impargs.cmi \
+    kernel/indtypes.cmi kernel/inductive.cmi pretyping/instantiate.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi toplevel/recordobj.cmi \
+    pretyping/recordops.cmi kernel/reduction.cmi kernel/sign.cmi \
+    library/summary.cmi kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi \
+    lib/util.cmi toplevel/discharge.cmi 
+toplevel/discharge.cmx: toplevel/class.cmx pretyping/classops.cmx \
+    kernel/cooking.cmx library/decl_kinds.cmx kernel/declarations.cmx \
+    library/declare.cmx library/dischargedhypsmap.cmx kernel/entries.cmx \
+    kernel/environ.cmx library/global.cmx library/impargs.cmx \
+    kernel/indtypes.cmx kernel/inductive.cmx pretyping/instantiate.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx toplevel/recordobj.cmx \
+    pretyping/recordops.cmx kernel/reduction.cmx kernel/sign.cmx \
+    library/summary.cmx kernel/term.cmx kernel/typeops.cmx kernel/univ.cmx \
+    lib/util.cmx toplevel/discharge.cmi 
+toplevel/fhimsg.cmo: kernel/environ.cmi parsing/g_minicoq.cmi \
+    kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \
+    kernel/term.cmi kernel/type_errors.cmi lib/util.cmi toplevel/fhimsg.cmi 
+toplevel/fhimsg.cmx: kernel/environ.cmx parsing/g_minicoq.cmx \
+    kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \
+    kernel/term.cmx kernel/type_errors.cmx lib/util.cmx toplevel/fhimsg.cmi 
+toplevel/himsg.cmo: parsing/ast.cmi pretyping/cases.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi library/impargs.cmi \
+    kernel/indtypes.cmi kernel/inductive.cmi proofs/logic.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi pretyping/pretype_errors.cmi parsing/printer.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi lib/util.cmi \
+    toplevel/himsg.cmi 
+toplevel/himsg.cmx: parsing/ast.cmx pretyping/cases.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx library/impargs.cmx \
+    kernel/indtypes.cmx kernel/inductive.cmx proofs/logic.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx pretyping/pretype_errors.cmx parsing/printer.cmx \
+    pretyping/rawterm.cmx kernel/reduction.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx lib/util.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: parsing/ast.cmi pretyping/classops.cmi \
+    interp/constrextern.cmi interp/constrintern.cmi parsing/coqast.cmi \
+    parsing/egrammar.cmi parsing/esyntax.cmi pretyping/evd.cmi \
+    parsing/extend.cmi interp/genarg.cmi library/global.cmi parsing/lexer.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    parsing/pcoq.cmi lib/pp.cmi interp/ppextend.cmi parsing/pptactic.cmi \
+    pretyping/rawterm.cmi library/summary.cmi interp/symbols.cmi \
+    parsing/termast.cmi interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo toplevel/metasyntax.cmi 
+toplevel/metasyntax.cmx: parsing/ast.cmx pretyping/classops.cmx \
+    interp/constrextern.cmx interp/constrintern.cmx parsing/coqast.cmx \
+    parsing/egrammar.cmx parsing/esyntax.cmx pretyping/evd.cmx \
+    parsing/extend.cmx interp/genarg.cmx library/global.cmx parsing/lexer.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    parsing/pcoq.cmx lib/pp.cmx interp/ppextend.cmx parsing/pptactic.cmx \
+    pretyping/rawterm.cmx library/summary.cmx interp/symbols.cmx \
+    parsing/termast.cmx interp/topconstr.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx toplevel/metasyntax.cmi 
+toplevel/minicoq.cmo: kernel/declarations.cmi toplevel/fhimsg.cmi \
+    parsing/g_minicoq.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \
+    kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \
+    kernel/type_errors.cmi lib/util.cmi 
+toplevel/minicoq.cmx: kernel/declarations.cmx toplevel/fhimsg.cmx \
+    parsing/g_minicoq.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \
+    kernel/safe_typing.cmx kernel/sign.cmx kernel/term.cmx \
+    kernel/type_errors.cmx lib/util.cmx 
+toplevel/mltop.cmo: library/lib.cmi library/libobject.cmi library/library.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi library/summary.cmi \
+    lib/system.cmi lib/util.cmi toplevel/vernacinterp.cmi toplevel/mltop.cmi 
+toplevel/mltop.cmx: library/lib.cmx library/libobject.cmx library/library.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx library/summary.cmx \
+    lib/system.cmx lib/util.cmx toplevel/vernacinterp.cmx toplevel/mltop.cmi 
+toplevel/protectedtoplevel.cmo: toplevel/cerrors.cmi \
+    toplevel/line_oriented_parser.cmi parsing/pcoq.cmi lib/pp.cmi \
+    toplevel/vernac.cmi toplevel/vernacexpr.cmo \
+    toplevel/protectedtoplevel.cmi 
+toplevel/protectedtoplevel.cmx: toplevel/cerrors.cmx \
+    toplevel/line_oriented_parser.cmx parsing/pcoq.cmx lib/pp.cmx \
+    toplevel/vernac.cmx toplevel/vernacexpr.cmx \
+    toplevel/protectedtoplevel.cmi 
+toplevel/record.cmo: toplevel/class.cmi toplevel/command.cmi \
+    interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi library/declare.cmi kernel/entries.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi \
+    kernel/indtypes.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi lib/pp.cmi parsing/printer.cmi \
+    pretyping/recordops.cmi kernel/safe_typing.cmi kernel/term.cmi \
+    pretyping/termops.cmi interp/topconstr.cmi kernel/type_errors.cmi \
+    lib/util.cmi toplevel/vernacexpr.cmo toplevel/record.cmi 
+toplevel/record.cmx: toplevel/class.cmx toplevel/command.cmx \
+    interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \
+    kernel/declarations.cmx library/declare.cmx kernel/entries.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx \
+    kernel/indtypes.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx lib/pp.cmx parsing/printer.cmx \
+    pretyping/recordops.cmx kernel/safe_typing.cmx kernel/term.cmx \
+    pretyping/termops.cmx interp/topconstr.cmx kernel/type_errors.cmx \
+    lib/util.cmx toplevel/vernacexpr.cmx toplevel/record.cmi 
+toplevel/recordobj.cmo: pretyping/classops.cmi library/declare.cmi \
+    kernel/environ.cmi library/global.cmi pretyping/instantiate.cmi \
+    library/lib.cmi library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi pretyping/recordops.cmi kernel/term.cmi \
+    lib/util.cmi toplevel/recordobj.cmi 
+toplevel/recordobj.cmx: pretyping/classops.cmx library/declare.cmx \
+    kernel/environ.cmx library/global.cmx pretyping/instantiate.cmx \
+    library/lib.cmx library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx pretyping/recordops.cmx kernel/term.cmx \
+    lib/util.cmx toplevel/recordobj.cmi 
+toplevel/toplevel.cmo: toplevel/cerrors.cmi library/lib.cmi \
+    toplevel/mltop.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \
+    proofs/pfedit.cmi lib/pp.cmi toplevel/protectedtoplevel.cmi lib/util.cmi \
+    toplevel/vernac.cmi toplevel/vernacexpr.cmo toplevel/toplevel.cmi 
+toplevel/toplevel.cmx: toplevel/cerrors.cmx library/lib.cmx \
+    toplevel/mltop.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \
+    proofs/pfedit.cmx lib/pp.cmx toplevel/protectedtoplevel.cmx lib/util.cmx \
+    toplevel/vernac.cmx toplevel/vernacexpr.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/vernacentries.cmo: tactics/auto.cmi toplevel/class.cmi \
+    pretyping/classops.cmi toplevel/command.cmi interp/constrextern.cmi \
+    interp/constrintern.cmi library/decl_kinds.cmo library/declaremods.cmi \
+    pretyping/detyping.cmi toplevel/discharge.cmi kernel/entries.cmi \
+    kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \
+    library/global.cmi library/goptions.cmi library/impargs.cmi \
+    pretyping/inductiveops.cmi library/lib.cmi library/libnames.cmi \
+    library/library.cmi toplevel/metasyntax.cmi toplevel/mltop.cmi \
+    interp/modintern.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi proofs/pfedit.cmi lib/pp.cmi \
+    lib/pp_control.cmi parsing/prettyp.cmi pretyping/pretyping.cmi \
+    parsing/printer.cmi parsing/printmod.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi toplevel/record.cmi \
+    toplevel/recordobj.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    interp/reserve.cmi kernel/safe_typing.cmi parsing/search.cmi \
+    library/states.cmi interp/symbols.cmi interp/syntax_def.cmi \
+    lib/system.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    proofs/tacmach.cmi pretyping/tacred.cmi proofs/tactic_debug.cmi \
+    tactics/tactics.cmi kernel/term.cmi interp/topconstr.cmi \
+    kernel/typeops.cmi kernel/univ.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    toplevel/vernacinterp.cmi toplevel/vernacentries.cmi 
+toplevel/vernacentries.cmx: tactics/auto.cmx toplevel/class.cmx \
+    pretyping/classops.cmx toplevel/command.cmx interp/constrextern.cmx \
+    interp/constrintern.cmx library/decl_kinds.cmx library/declaremods.cmx \
+    pretyping/detyping.cmx toplevel/discharge.cmx kernel/entries.cmx \
+    kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \
+    library/global.cmx library/goptions.cmx library/impargs.cmx \
+    pretyping/inductiveops.cmx library/lib.cmx library/libnames.cmx \
+    library/library.cmx toplevel/metasyntax.cmx toplevel/mltop.cmx \
+    interp/modintern.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx proofs/pfedit.cmx lib/pp.cmx \
+    lib/pp_control.cmx parsing/prettyp.cmx pretyping/pretyping.cmx \
+    parsing/printer.cmx parsing/printmod.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx toplevel/record.cmx \
+    toplevel/recordobj.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    interp/reserve.cmx kernel/safe_typing.cmx parsing/search.cmx \
+    library/states.cmx interp/symbols.cmx interp/syntax_def.cmx \
+    lib/system.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    proofs/tacmach.cmx pretyping/tacred.cmx proofs/tactic_debug.cmx \
+    tactics/tactics.cmx kernel/term.cmx interp/topconstr.cmx \
+    kernel/typeops.cmx kernel/univ.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    toplevel/vernacinterp.cmx toplevel/vernacentries.cmi 
+toplevel/vernacexpr.cmo: library/decl_kinds.cmo parsing/extend.cmi \
+    interp/genarg.cmi library/goptions.cmi library/libnames.cmi \
+    kernel/names.cmi library/nametab.cmi interp/ppextend.cmi \
+    pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \
+    lib/util.cmi 
+toplevel/vernacexpr.cmx: library/decl_kinds.cmx parsing/extend.cmx \
+    interp/genarg.cmx library/goptions.cmx library/libnames.cmx \
+    kernel/names.cmx library/nametab.cmx interp/ppextend.cmx \
+    pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \
+    lib/util.cmx 
+toplevel/vernacinterp.cmo: parsing/ast.cmi parsing/coqast.cmi \
+    parsing/extend.cmi toplevel/himsg.cmi library/libnames.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi proofs/proof_type.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi 
+toplevel/vernacinterp.cmx: parsing/ast.cmx parsing/coqast.cmx \
+    parsing/extend.cmx toplevel/himsg.cmx library/libnames.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx proofs/proof_type.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx toplevel/vernacinterp.cmi 
+toplevel/vernac.cmo: interp/constrextern.cmi interp/constrintern.cmi \
+    parsing/coqast.cmi parsing/lexer.cmi library/lib.cmi library/library.cmi \
+    kernel/names.cmi lib/options.cmi parsing/pcoq.cmi proofs/pfedit.cmi \
+    lib/pp.cmi translate/ppvernacnew.cmi proofs/refiner.cmi \
+    library/states.cmi lib/system.cmi tactics/tacinterp.cmi \
+    proofs/tacmach.cmi lib/util.cmi toplevel/vernacentries.cmi \
+    toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernac.cmi 
+toplevel/vernac.cmx: interp/constrextern.cmx interp/constrintern.cmx \
+    parsing/coqast.cmx parsing/lexer.cmx library/lib.cmx library/library.cmx \
+    kernel/names.cmx lib/options.cmx parsing/pcoq.cmx proofs/pfedit.cmx \
+    lib/pp.cmx translate/ppvernacnew.cmx proofs/refiner.cmx \
+    library/states.cmx lib/system.cmx tactics/tacinterp.cmx \
+    proofs/tacmach.cmx lib/util.cmx toplevel/vernacentries.cmx \
+    toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi 
+translate/ppconstrnew.cmo: parsing/ast.cmi lib/bignat.cmi \
+    interp/constrextern.cmi interp/constrintern.cmi parsing/coqast.cmi \
+    pretyping/evd.cmi interp/genarg.cmi library/global.cmi library/lib.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    interp/ppextend.cmi pretyping/pretyping.cmi pretyping/rawterm.cmi \
+    pretyping/retyping.cmi interp/symbols.cmi interp/syntax_def.cmi \
+    kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi lib/util.cmi \
+    translate/ppconstrnew.cmi 
+translate/ppconstrnew.cmx: parsing/ast.cmx lib/bignat.cmx \
+    interp/constrextern.cmx interp/constrintern.cmx parsing/coqast.cmx \
+    pretyping/evd.cmx interp/genarg.cmx library/global.cmx library/lib.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    interp/ppextend.cmx pretyping/pretyping.cmx pretyping/rawterm.cmx \
+    pretyping/retyping.cmx interp/symbols.cmx interp/syntax_def.cmx \
+    kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx lib/util.cmx \
+    translate/ppconstrnew.cmi 
+translate/pptacticnew.cmo: kernel/closure.cmi interp/constrextern.cmi \
+    lib/dyn.cmi parsing/egrammar.cmi kernel/environ.cmi parsing/extend.cmi \
+    interp/genarg.cmi library/global.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi translate/ppconstrnew.cmi interp/ppextend.cmi \
+    parsing/pptactic.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \
+    kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi lib/util.cmi \
+    translate/pptacticnew.cmi 
+translate/pptacticnew.cmx: kernel/closure.cmx interp/constrextern.cmx \
+    lib/dyn.cmx parsing/egrammar.cmx kernel/environ.cmx parsing/extend.cmx \
+    interp/genarg.cmx library/global.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx translate/ppconstrnew.cmx interp/ppextend.cmx \
+    parsing/pptactic.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx \
+    kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx lib/util.cmx \
+    translate/pptacticnew.cmi 
+translate/ppvernacnew.cmo: parsing/ast.cmi interp/constrextern.cmi \
+    interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \
+    library/declaremods.cmi parsing/egrammar.cmi kernel/environ.cmi \
+    pretyping/evd.cmi parsing/extend.cmi interp/genarg.cmi library/global.cmi \
+    library/goptions.cmi library/impargs.cmi library/lib.cmi \
+    library/libnames.cmi library/library.cmi toplevel/metasyntax.cmi \
+    interp/modintern.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi parsing/pcoq.cmi proofs/pfedit.cmi \
+    lib/pp.cmi translate/ppconstrnew.cmi interp/ppextend.cmi \
+    parsing/pptactic.cmi translate/pptacticnew.cmi pretyping/rawterm.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi kernel/term.cmi \
+    pretyping/termops.cmi interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo translate/ppvernacnew.cmi 
+translate/ppvernacnew.cmx: parsing/ast.cmx interp/constrextern.cmx \
+    interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \
+    library/declaremods.cmx parsing/egrammar.cmx kernel/environ.cmx \
+    pretyping/evd.cmx parsing/extend.cmx interp/genarg.cmx library/global.cmx \
+    library/goptions.cmx library/impargs.cmx library/lib.cmx \
+    library/libnames.cmx library/library.cmx toplevel/metasyntax.cmx \
+    interp/modintern.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx parsing/pcoq.cmx proofs/pfedit.cmx \
+    lib/pp.cmx translate/ppconstrnew.cmx interp/ppextend.cmx \
+    parsing/pptactic.cmx translate/pptacticnew.cmx pretyping/rawterm.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx kernel/term.cmx \
+    pretyping/termops.cmx interp/topconstr.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx translate/ppvernacnew.cmi 
+contrib/cc/ccalgo.cmo: kernel/names.cmi kernel/term.cmi lib/util.cmi \
+    contrib/cc/ccalgo.cmi 
+contrib/cc/ccalgo.cmx: kernel/names.cmx kernel/term.cmx lib/util.cmx \
+    contrib/cc/ccalgo.cmi 
+contrib/cc/ccproof.cmo: contrib/cc/ccalgo.cmi kernel/names.cmi lib/pp.cmi \
+    lib/util.cmi contrib/cc/ccproof.cmi 
+contrib/cc/ccproof.cmx: contrib/cc/ccalgo.cmx kernel/names.cmx lib/pp.cmx \
+    lib/util.cmx contrib/cc/ccproof.cmi 
+contrib/cc/cctac.cmo: contrib/cc/ccalgo.cmi contrib/cc/ccproof.cmi \
+    toplevel/cerrors.cmi interp/coqlib.cmi kernel/declarations.cmi \
+    parsing/egrammar.cmi pretyping/evd.cmi library/global.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.cmi \
+    library/library.cmi library/nameops.cmi kernel/names.cmi lib/options.cmi \
+    parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi proofs/proof_type.cmi \
+    proofs/refiner.cmi kernel/sign.cmi proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi 
+contrib/cc/cctac.cmx: contrib/cc/ccalgo.cmx contrib/cc/ccproof.cmx \
+    toplevel/cerrors.cmx interp/coqlib.cmx kernel/declarations.cmx \
+    parsing/egrammar.cmx pretyping/evd.cmx library/global.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx library/libnames.cmx \
+    library/library.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \
+    parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx proofs/proof_type.cmx \
+    proofs/refiner.cmx kernel/sign.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx 
+contrib/correctness/pcicenv.cmo: library/global.cmi kernel/names.cmi \
+    kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \
+    contrib/correctness/pcicenv.cmi 
+contrib/correctness/pcicenv.cmx: library/global.cmx kernel/names.cmx \
+    kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \
+    contrib/correctness/pcicenv.cmi 
+contrib/correctness/pcic.cmo: kernel/declarations.cmi library/declare.cmi \
+    pretyping/detyping.cmi kernel/entries.cmi library/global.cmi \
+    kernel/indtypes.cmi library/libnames.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi pretyping/rawterm.cmi \
+    toplevel/record.cmi kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi \
+    interp/topconstr.cmi kernel/typeops.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo contrib/correctness/pcic.cmi 
+contrib/correctness/pcic.cmx: kernel/declarations.cmx library/declare.cmx \
+    pretyping/detyping.cmx kernel/entries.cmx library/global.cmx \
+    kernel/indtypes.cmx library/libnames.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx pretyping/rawterm.cmx \
+    toplevel/record.cmx kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \
+    interp/topconstr.cmx kernel/typeops.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx contrib/correctness/pcic.cmi 
+contrib/correctness/pdb.cmo: interp/constrintern.cmi library/global.cmi \
+    kernel/names.cmi library/nametab.cmi kernel/term.cmi \
+    pretyping/termops.cmi contrib/correctness/pdb.cmi 
+contrib/correctness/pdb.cmx: interp/constrintern.cmx library/global.cmx \
+    kernel/names.cmx library/nametab.cmx kernel/term.cmx \
+    pretyping/termops.cmx contrib/correctness/pdb.cmi 
+contrib/correctness/peffect.cmo: toplevel/himsg.cmi library/nameops.cmi \
+    kernel/names.cmi lib/pp.cmi lib/util.cmi contrib/correctness/peffect.cmi 
+contrib/correctness/peffect.cmx: toplevel/himsg.cmx library/nameops.cmx \
+    kernel/names.cmx lib/pp.cmx lib/util.cmx contrib/correctness/peffect.cmi 
+contrib/correctness/penv.cmo: toplevel/himsg.cmi library/lib.cmi \
+    library/libobject.cmi library/library.cmi library/nameops.cmi \
+    kernel/names.cmi lib/options.cmi lib/pp.cmi library/summary.cmi \
+    kernel/term.cmi contrib/correctness/penv.cmi 
+contrib/correctness/penv.cmx: toplevel/himsg.cmx library/lib.cmx \
+    library/libobject.cmx library/library.cmx library/nameops.cmx \
+    kernel/names.cmx lib/options.cmx lib/pp.cmx library/summary.cmx \
+    kernel/term.cmx contrib/correctness/penv.cmi 
+contrib/correctness/perror.cmo: interp/constrintern.cmi pretyping/evd.cmi \
+    library/global.cmi toplevel/himsg.cmi library/nameops.cmi \
+    kernel/names.cmi lib/pp.cmi pretyping/reductionops.cmi kernel/term.cmi \
+    lib/util.cmi contrib/correctness/perror.cmi 
+contrib/correctness/perror.cmx: interp/constrintern.cmx pretyping/evd.cmx \
+    library/global.cmx toplevel/himsg.cmx library/nameops.cmx \
+    kernel/names.cmx lib/pp.cmx pretyping/reductionops.cmx kernel/term.cmx \
+    lib/util.cmx contrib/correctness/perror.cmi 
+contrib/correctness/pextract.cmo: parsing/ast.cmi pretyping/evd.cmi \
+    toplevel/himsg.cmi library/library.cmi kernel/names.cmi \
+    library/nametab.cmi contrib/extraction/ocaml.cmi lib/pp.cmi \
+    lib/pp_control.cmi kernel/reduction.cmi pretyping/reductionops.cmi \
+    lib/system.cmi kernel/term.cmi lib/util.cmi toplevel/vernacinterp.cmi \
+    contrib/correctness/pextract.cmi 
+contrib/correctness/pextract.cmx: parsing/ast.cmx pretyping/evd.cmx \
+    toplevel/himsg.cmx library/library.cmx kernel/names.cmx \
+    library/nametab.cmx contrib/extraction/ocaml.cmx lib/pp.cmx \
+    lib/pp_control.cmx kernel/reduction.cmx pretyping/reductionops.cmx \
+    lib/system.cmx kernel/term.cmx lib/util.cmx toplevel/vernacinterp.cmx \
+    contrib/correctness/pextract.cmi 
+contrib/correctness/pmisc.cmo: interp/constrextern.cmi \
+    interp/constrintern.cmi pretyping/evarutil.cmi library/global.cmi \
+    library/libnames.cmi library/nameops.cmi kernel/names.cmi lib/options.cmi \
+    lib/pp.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi \
+    contrib/correctness/pmisc.cmi 
+contrib/correctness/pmisc.cmx: interp/constrextern.cmx \
+    interp/constrintern.cmx pretyping/evarutil.cmx library/global.cmx \
+    library/libnames.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \
+    lib/pp.cmx kernel/term.cmx interp/topconstr.cmx lib/util.cmx \
+    contrib/correctness/pmisc.cmi 
+contrib/correctness/pmlize.cmo: pretyping/evd.cmi library/global.cmi \
+    tactics/hipattern.cmi pretyping/matching.cmi kernel/names.cmi \
+    pretyping/pattern.cmi pretyping/reductionops.cmi kernel/term.cmi \
+    parsing/termast.cmi pretyping/typing.cmi lib/util.cmi \
+    contrib/correctness/pmlize.cmi 
+contrib/correctness/pmlize.cmx: pretyping/evd.cmx library/global.cmx \
+    tactics/hipattern.cmx pretyping/matching.cmx kernel/names.cmx \
+    pretyping/pattern.cmx pretyping/reductionops.cmx kernel/term.cmx \
+    parsing/termast.cmx pretyping/typing.cmx lib/util.cmx \
+    contrib/correctness/pmlize.cmi 
+contrib/correctness/pmonad.cmo: kernel/names.cmi kernel/term.cmi \
+    parsing/termast.cmi lib/util.cmi contrib/correctness/pmonad.cmi 
+contrib/correctness/pmonad.cmx: kernel/names.cmx kernel/term.cmx \
+    parsing/termast.cmx lib/util.cmx contrib/correctness/pmonad.cmi 
+contrib/correctness/pred.cmo: pretyping/evd.cmi library/global.cmi lib/pp.cmi \
+    pretyping/reductionops.cmi kernel/term.cmi contrib/correctness/pred.cmi 
+contrib/correctness/pred.cmx: pretyping/evd.cmx library/global.cmx lib/pp.cmx \
+    pretyping/reductionops.cmx kernel/term.cmx contrib/correctness/pred.cmi 
+contrib/correctness/prename.cmo: toplevel/himsg.cmi library/nameops.cmi \
+    kernel/names.cmi lib/pp.cmi lib/util.cmi contrib/correctness/prename.cmi 
+contrib/correctness/prename.cmx: toplevel/himsg.cmx library/nameops.cmx \
+    kernel/names.cmx lib/pp.cmx lib/util.cmx contrib/correctness/prename.cmi 
+contrib/correctness/ptactic.cmo: library/decl_kinds.cmo tactics/equality.cmi \
+    pretyping/evd.cmi tactics/extratactics.cmi library/global.cmi \
+    library/libnames.cmi library/library.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    pretyping/pattern.cmi proofs/pfedit.cmi lib/pp.cmi \
+    pretyping/pretyping.cmi parsing/printer.cmi kernel/reduction.cmi \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    toplevel/vernacentries.cmi contrib/correctness/ptactic.cmi 
+contrib/correctness/ptactic.cmx: library/decl_kinds.cmx tactics/equality.cmx \
+    pretyping/evd.cmx tactics/extratactics.cmx library/global.cmx \
+    library/libnames.cmx library/library.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    pretyping/pattern.cmx proofs/pfedit.cmx lib/pp.cmx \
+    pretyping/pretyping.cmx parsing/printer.cmx kernel/reduction.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    toplevel/vernacentries.cmx contrib/correctness/ptactic.cmi 
+contrib/correctness/ptyping.cmo: interp/constrintern.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi toplevel/himsg.cmi kernel/names.cmi \
+    lib/pp.cmi proofs/proof_trees.cmi pretyping/reductionops.cmi \
+    kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi \
+    pretyping/typing.cmi lib/util.cmi contrib/correctness/ptyping.cmi 
+contrib/correctness/ptyping.cmx: interp/constrintern.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx toplevel/himsg.cmx kernel/names.cmx \
+    lib/pp.cmx proofs/proof_trees.cmx pretyping/reductionops.cmx \
+    kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \
+    pretyping/typing.cmx lib/util.cmx contrib/correctness/ptyping.cmi 
+contrib/correctness/putil.cmo: kernel/environ.cmi library/global.cmi \
+    tactics/hipattern.cmi pretyping/matching.cmi library/nameops.cmi \
+    kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi parsing/printer.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/correctness/putil.cmi 
+contrib/correctness/putil.cmx: kernel/environ.cmx library/global.cmx \
+    tactics/hipattern.cmx pretyping/matching.cmx library/nameops.cmx \
+    kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx parsing/printer.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/correctness/putil.cmi 
+contrib/correctness/pwp.cmo: kernel/environ.cmi library/global.cmi \
+    tactics/hipattern.cmi library/libnames.cmi kernel/names.cmi \
+    library/nametab.cmi kernel/reduction.cmi pretyping/reductionops.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/correctness/pwp.cmi 
+contrib/correctness/pwp.cmx: kernel/environ.cmx library/global.cmx \
+    tactics/hipattern.cmx library/libnames.cmx kernel/names.cmx \
+    library/nametab.cmx kernel/reduction.cmx pretyping/reductionops.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/correctness/pwp.cmi 
+contrib/extraction/common.cmo: kernel/declarations.cmi \
+    contrib/extraction/extraction.cmi library/global.cmi lib/gset.cmi \
+    contrib/extraction/haskell.cmi library/libnames.cmi \
+    contrib/extraction/miniml.cmi kernel/modops.cmi \
+    contrib/extraction/modutil.cmi library/nameops.cmi kernel/names.cmi \
+    contrib/extraction/ocaml.cmi lib/options.cmi lib/pp.cmi \
+    lib/pp_control.cmi contrib/extraction/scheme.cmi \
+    contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \
+    contrib/extraction/common.cmi 
+contrib/extraction/common.cmx: kernel/declarations.cmx \
+    contrib/extraction/extraction.cmx library/global.cmx lib/gset.cmx \
+    contrib/extraction/haskell.cmx library/libnames.cmx \
+    contrib/extraction/miniml.cmi kernel/modops.cmx \
+    contrib/extraction/modutil.cmx library/nameops.cmx kernel/names.cmx \
+    contrib/extraction/ocaml.cmx lib/options.cmx lib/pp.cmx \
+    lib/pp_control.cmx contrib/extraction/scheme.cmx \
+    contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \
+    contrib/extraction/common.cmi 
+contrib/extraction/extract_env.cmo: contrib/extraction/common.cmi \
+    kernel/declarations.cmi contrib/extraction/extraction.cmi \
+    library/global.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi contrib/extraction/miniml.cmi \
+    kernel/modops.cmi contrib/extraction/modutil.cmi kernel/names.cmi \
+    library/nametab.cmi lib/pp.cmi kernel/reduction.cmi \
+    contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \
+    contrib/extraction/extract_env.cmi 
+contrib/extraction/extract_env.cmx: contrib/extraction/common.cmx \
+    kernel/declarations.cmx contrib/extraction/extraction.cmx \
+    library/global.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/library.cmx contrib/extraction/miniml.cmi \
+    kernel/modops.cmx contrib/extraction/modutil.cmx kernel/names.cmx \
+    library/nametab.cmx lib/pp.cmx kernel/reduction.cmx \
+    contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \
+    contrib/extraction/extract_env.cmi 
+contrib/extraction/extraction.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \
+    library/libnames.cmi contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi pretyping/recordops.cmi kernel/reduction.cmi \
+    pretyping/reductionops.cmi pretyping/retyping.cmi kernel/sign.cmi \
+    library/summary.cmi contrib/extraction/table.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi contrib/extraction/extraction.cmi 
+contrib/extraction/extraction.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    pretyping/evd.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \
+    library/libnames.cmx contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx pretyping/recordops.cmx kernel/reduction.cmx \
+    pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \
+    library/summary.cmx contrib/extraction/table.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx contrib/extraction/extraction.cmi 
+contrib/extraction/g_extraction.cmo: toplevel/cerrors.cmi \
+    parsing/egrammar.cmi parsing/extend.cmi \
+    contrib/extraction/extract_env.cmi interp/genarg.cmi lib/options.cmi \
+    parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    translate/pptacticnew.cmi contrib/extraction/table.cmi \
+    tactics/tacinterp.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    toplevel/vernacinterp.cmi 
+contrib/extraction/g_extraction.cmx: toplevel/cerrors.cmx \
+    parsing/egrammar.cmx parsing/extend.cmx \
+    contrib/extraction/extract_env.cmx interp/genarg.cmx lib/options.cmx \
+    parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    translate/pptacticnew.cmx contrib/extraction/table.cmx \
+    tactics/tacinterp.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    toplevel/vernacinterp.cmx 
+contrib/extraction/haskell.cmo: library/libnames.cmi \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmi \
+    library/nameops.cmi kernel/names.cmi contrib/extraction/ocaml.cmi \
+    lib/pp.cmi contrib/extraction/table.cmi lib/util.cmi \
+    contrib/extraction/haskell.cmi 
+contrib/extraction/haskell.cmx: library/libnames.cmx \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmx \
+    library/nameops.cmx kernel/names.cmx contrib/extraction/ocaml.cmx \
+    lib/pp.cmx contrib/extraction/table.cmx lib/util.cmx \
+    contrib/extraction/haskell.cmi 
+contrib/extraction/mlutil.cmo: library/libnames.cmi \
+    contrib/extraction/miniml.cmi kernel/names.cmi library/nametab.cmi \
+    lib/pp.cmi contrib/extraction/table.cmi lib/util.cmi \
+    contrib/extraction/mlutil.cmi 
+contrib/extraction/mlutil.cmx: library/libnames.cmx \
+    contrib/extraction/miniml.cmi kernel/names.cmx library/nametab.cmx \
+    lib/pp.cmx contrib/extraction/table.cmx lib/util.cmx \
+    contrib/extraction/mlutil.cmi 
+contrib/extraction/modutil.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    library/libnames.cmi contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmi kernel/modops.cmi kernel/names.cmi \
+    contrib/extraction/table.cmi lib/util.cmi contrib/extraction/modutil.cmi 
+contrib/extraction/modutil.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    library/libnames.cmx contrib/extraction/miniml.cmi \
+    contrib/extraction/mlutil.cmx kernel/modops.cmx kernel/names.cmx \
+    contrib/extraction/table.cmx lib/util.cmx contrib/extraction/modutil.cmi 
+contrib/extraction/ocaml.cmo: library/libnames.cmi \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmi \
+    contrib/extraction/modutil.cmi library/nameops.cmi kernel/names.cmi \
+    lib/pp.cmi contrib/extraction/table.cmi lib/util.cmi \
+    contrib/extraction/ocaml.cmi 
+contrib/extraction/ocaml.cmx: library/libnames.cmx \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmx \
+    contrib/extraction/modutil.cmx library/nameops.cmx kernel/names.cmx \
+    lib/pp.cmx contrib/extraction/table.cmx lib/util.cmx \
+    contrib/extraction/ocaml.cmi 
+contrib/extraction/scheme.cmo: library/libnames.cmi \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmi \
+    library/nameops.cmi kernel/names.cmi contrib/extraction/ocaml.cmi \
+    lib/pp.cmi contrib/extraction/table.cmi lib/util.cmi \
+    contrib/extraction/scheme.cmi 
+contrib/extraction/scheme.cmx: library/libnames.cmx \
+    contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmx \
+    library/nameops.cmx kernel/names.cmx contrib/extraction/ocaml.cmx \
+    lib/pp.cmx contrib/extraction/table.cmx lib/util.cmx \
+    contrib/extraction/scheme.cmi 
+contrib/extraction/table.cmo: kernel/declarations.cmi kernel/environ.cmi \
+    library/global.cmi library/goptions.cmi library/lib.cmi \
+    library/libnames.cmi library/libobject.cmi contrib/extraction/miniml.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    lib/pp.cmi parsing/printer.cmi kernel/reduction.cmi library/summary.cmi \
+    kernel/term.cmi lib/util.cmi contrib/extraction/table.cmi 
+contrib/extraction/table.cmx: kernel/declarations.cmx kernel/environ.cmx \
+    library/global.cmx library/goptions.cmx library/lib.cmx \
+    library/libnames.cmx library/libobject.cmx contrib/extraction/miniml.cmi \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    lib/pp.cmx parsing/printer.cmx kernel/reduction.cmx library/summary.cmx \
+    kernel/term.cmx lib/util.cmx contrib/extraction/table.cmi 
+contrib/field/field.cmo: toplevel/cerrors.cmi interp/constrintern.cmi \
+    interp/coqlib.cmi parsing/egrammar.cmi pretyping/evd.cmi \
+    parsing/extend.cmi interp/genarg.cmi library/global.cmi lib/gmap.cmi \
+    tactics/hipattern.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi kernel/names.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi translate/ppconstrnew.cmi \
+    parsing/pptactic.cmi parsing/printer.cmi proofs/proof_type.cmi \
+    contrib/ring/quote.cmo pretyping/reductionops.cmi proofs/refiner.cmi \
+    contrib/ring/ring.cmo library/summary.cmi proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \
+    kernel/term.cmi interp/topconstr.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi 
+contrib/field/field.cmx: toplevel/cerrors.cmx interp/constrintern.cmx \
+    interp/coqlib.cmx parsing/egrammar.cmx pretyping/evd.cmx \
+    parsing/extend.cmx interp/genarg.cmx library/global.cmx lib/gmap.cmx \
+    tactics/hipattern.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/library.cmx kernel/names.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx translate/ppconstrnew.cmx \
+    parsing/pptactic.cmx parsing/printer.cmx proofs/proof_type.cmx \
+    contrib/ring/quote.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    contrib/ring/ring.cmx library/summary.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    kernel/term.cmx interp/topconstr.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx 
+contrib/first-order/formula.cmo: kernel/closure.cmi kernel/declarations.cmi \
+    library/global.cmi tactics/hipattern.cmi kernel/inductive.cmi \
+    pretyping/inductiveops.cmi library/libnames.cmi kernel/names.cmi \
+    pretyping/reductionops.cmi kernel/sign.cmi proofs/tacmach.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/first-order/formula.cmi 
+contrib/first-order/formula.cmx: kernel/closure.cmx kernel/declarations.cmx \
+    library/global.cmx tactics/hipattern.cmx kernel/inductive.cmx \
+    pretyping/inductiveops.cmx library/libnames.cmx kernel/names.cmx \
+    pretyping/reductionops.cmx kernel/sign.cmx proofs/tacmach.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/first-order/formula.cmi 
+contrib/first-order/g_ground.cmo: tactics/auto.cmi toplevel/cerrors.cmi \
+    parsing/egrammar.cmi contrib/first-order/formula.cmi interp/genarg.cmi \
+    library/goptions.cmi contrib/first-order/ground.cmi library/libnames.cmi \
+    kernel/names.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi proofs/refiner.cmi contrib/first-order/sequent.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi lib/util.cmi 
+contrib/first-order/g_ground.cmx: tactics/auto.cmx toplevel/cerrors.cmx \
+    parsing/egrammar.cmx contrib/first-order/formula.cmx interp/genarg.cmx \
+    library/goptions.cmx contrib/first-order/ground.cmx library/libnames.cmx \
+    kernel/names.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx proofs/refiner.cmx contrib/first-order/sequent.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx lib/util.cmx 
+contrib/first-order/ground.cmo: pretyping/classops.cmi kernel/closure.cmi \
+    contrib/first-order/formula.cmi lib/heap.cmi \
+    contrib/first-order/instances.cmi library/libnames.cmi kernel/names.cmi \
+    lib/pp.cmi proofs/proof_trees.cmi contrib/first-order/rules.cmi \
+    contrib/first-order/sequent.cmi tactics/tacinterp.cmi proofs/tacmach.cmi \
+    proofs/tactic_debug.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi contrib/first-order/ground.cmi 
+contrib/first-order/ground.cmx: pretyping/classops.cmx kernel/closure.cmx \
+    contrib/first-order/formula.cmx lib/heap.cmx \
+    contrib/first-order/instances.cmx library/libnames.cmx kernel/names.cmx \
+    lib/pp.cmx proofs/proof_trees.cmx contrib/first-order/rules.cmx \
+    contrib/first-order/sequent.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \
+    proofs/tactic_debug.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx contrib/first-order/ground.cmi 
+contrib/first-order/instances.cmo: kernel/declarations.cmi \
+    pretyping/detyping.cmi contrib/first-order/formula.cmi lib/heap.cmi \
+    library/libnames.cmi kernel/names.cmi pretyping/pretyping.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi proofs/refiner.cmi \
+    contrib/first-order/rules.cmi contrib/first-order/sequent.cmi \
+    kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi \
+    contrib/first-order/unify.cmi lib/util.cmi \
+    contrib/first-order/instances.cmi 
+contrib/first-order/instances.cmx: kernel/declarations.cmx \
+    pretyping/detyping.cmx contrib/first-order/formula.cmx lib/heap.cmx \
+    library/libnames.cmx kernel/names.cmx pretyping/pretyping.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx proofs/refiner.cmx \
+    contrib/first-order/rules.cmx contrib/first-order/sequent.cmx \
+    kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx \
+    contrib/first-order/unify.cmx lib/util.cmx \
+    contrib/first-order/instances.cmi 
+contrib/first-order/rules.cmo: interp/coqlib.cmi kernel/declarations.cmi \
+    contrib/first-order/formula.cmi library/libnames.cmi kernel/names.cmi \
+    contrib/first-order/sequent.cmi kernel/sign.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/first-order/rules.cmi 
+contrib/first-order/rules.cmx: interp/coqlib.cmx kernel/declarations.cmx \
+    contrib/first-order/formula.cmx library/libnames.cmx kernel/names.cmx \
+    contrib/first-order/sequent.cmx kernel/sign.cmx proofs/tacexpr.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/first-order/rules.cmi 
+contrib/first-order/sequent.cmo: tactics/auto.cmi interp/constrextern.cmi \
+    contrib/first-order/formula.cmi library/global.cmi lib/heap.cmi \
+    library/libnames.cmi kernel/names.cmi lib/pp.cmi parsing/ppconstr.cmi \
+    proofs/tacmach.cmi kernel/term.cmi contrib/first-order/unify.cmi \
+    lib/util.cmi contrib/first-order/sequent.cmi 
+contrib/first-order/sequent.cmx: tactics/auto.cmx interp/constrextern.cmx \
+    contrib/first-order/formula.cmx library/global.cmx lib/heap.cmx \
+    library/libnames.cmx kernel/names.cmx lib/pp.cmx parsing/ppconstr.cmx \
+    proofs/tacmach.cmx kernel/term.cmx contrib/first-order/unify.cmx \
+    lib/util.cmx contrib/first-order/sequent.cmi 
+contrib/first-order/unify.cmo: contrib/first-order/formula.cmi \
+    kernel/names.cmi pretyping/reductionops.cmi proofs/tacmach.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/first-order/unify.cmi 
+contrib/first-order/unify.cmx: contrib/first-order/formula.cmx \
+    kernel/names.cmx pretyping/reductionops.cmx proofs/tacmach.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/first-order/unify.cmi 
+contrib/fourier/fourierR.cmo: proofs/clenv.cmi tactics/contradiction.cmi \
+    interp/coqlib.cmi tactics/equality.cmi contrib/fourier/fourier.cmo \
+    library/libnames.cmi library/library.cmi kernel/names.cmi \
+    contrib/ring/ring.cmo proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi lib/util.cmi toplevel/vernacexpr.cmo 
+contrib/fourier/fourierR.cmx: proofs/clenv.cmx tactics/contradiction.cmx \
+    interp/coqlib.cmx tactics/equality.cmx contrib/fourier/fourier.cmx \
+    library/libnames.cmx library/library.cmx kernel/names.cmx \
+    contrib/ring/ring.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx lib/util.cmx toplevel/vernacexpr.cmx 
+contrib/fourier/g_fourier.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \
+    contrib/fourier/fourierR.cmo lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi proofs/refiner.cmi proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi lib/util.cmi 
+contrib/fourier/g_fourier.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \
+    contrib/fourier/fourierR.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx proofs/refiner.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx lib/util.cmx 
+contrib/funind/tacinv.cmo: toplevel/cerrors.cmi interp/constrintern.cmi \
+    interp/coqlib.cmi library/decl_kinds.cmo library/declare.cmi \
+    parsing/egrammar.cmi kernel/entries.cmi kernel/environ.cmi \
+    tactics/equality.cmi pretyping/evd.cmi interp/genarg.cmi \
+    library/global.cmi pretyping/inductiveops.cmi kernel/names.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    parsing/printer.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \
+    tactics/refine.cmi proofs/refiner.cmi kernel/safe_typing.cmi \
+    tactics/setoid_replace.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    contrib/funind/tacinvutils.cmi proofs/tacmach.cmi pretyping/tacred.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacinterp.cmi 
+contrib/funind/tacinv.cmx: toplevel/cerrors.cmx interp/constrintern.cmx \
+    interp/coqlib.cmx library/decl_kinds.cmx library/declare.cmx \
+    parsing/egrammar.cmx kernel/entries.cmx kernel/environ.cmx \
+    tactics/equality.cmx pretyping/evd.cmx interp/genarg.cmx \
+    library/global.cmx pretyping/inductiveops.cmx kernel/names.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    parsing/printer.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \
+    tactics/refine.cmx proofs/refiner.cmx kernel/safe_typing.cmx \
+    tactics/setoid_replace.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    contrib/funind/tacinvutils.cmx proofs/tacmach.cmx pretyping/tacred.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/vernacinterp.cmx 
+contrib/funind/tacinvutils.cmo: interp/coqlib.cmi kernel/declarations.cmi \
+    kernel/environ.cmi pretyping/evd.cmi library/global.cmi \
+    pretyping/inductiveops.cmi library/nameops.cmi kernel/names.cmi \
+    lib/pp.cmi parsing/printer.cmi pretyping/reductionops.cmi kernel/sign.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi \
+    contrib/funind/tacinvutils.cmi 
+contrib/funind/tacinvutils.cmx: interp/coqlib.cmx kernel/declarations.cmx \
+    kernel/environ.cmx pretyping/evd.cmx library/global.cmx \
+    pretyping/inductiveops.cmx library/nameops.cmx kernel/names.cmx \
+    lib/pp.cmx parsing/printer.cmx pretyping/reductionops.cmx kernel/sign.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx \
+    contrib/funind/tacinvutils.cmi 
+contrib/interface/blast.cmo: tactics/auto.cmi proofs/clenv.cmi \
+    toplevel/command.cmi contrib/interface/ctast.cmo kernel/declarations.cmi \
+    library/declare.cmi tactics/eauto.cmi kernel/environ.cmi \
+    tactics/equality.cmi proofs/evar_refiner.cmi pretyping/evd.cmi \
+    lib/explore.cmi library/global.cmi tactics/hipattern.cmi \
+    kernel/inductive.cmi proofs/logic.cmi library/nameops.cmi \
+    kernel/names.cmi pretyping/pattern.cmi contrib/interface/pbp.cmi \
+    parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi parsing/pptactic.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi proofs/refiner.cmi \
+    kernel/sign.cmi tactics/tacinterp.cmi proofs/tacmach.cmi \
+    pretyping/tacred.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \
+    toplevel/vernacentries.cmi toplevel/vernacinterp.cmi \
+    contrib/interface/blast.cmi 
+contrib/interface/blast.cmx: tactics/auto.cmx proofs/clenv.cmx \
+    toplevel/command.cmx contrib/interface/ctast.cmx kernel/declarations.cmx \
+    library/declare.cmx tactics/eauto.cmx kernel/environ.cmx \
+    tactics/equality.cmx proofs/evar_refiner.cmx pretyping/evd.cmx \
+    lib/explore.cmx library/global.cmx tactics/hipattern.cmx \
+    kernel/inductive.cmx proofs/logic.cmx library/nameops.cmx \
+    kernel/names.cmx pretyping/pattern.cmx contrib/interface/pbp.cmx \
+    parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx parsing/pptactic.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx kernel/reduction.cmx proofs/refiner.cmx \
+    kernel/sign.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \
+    pretyping/tacred.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \
+    toplevel/vernacentries.cmx toplevel/vernacinterp.cmx \
+    contrib/interface/blast.cmi 
+contrib/interface/centaur.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \
+    contrib/interface/blast.cmi toplevel/cerrors.cmi pretyping/classops.cmi \
+    toplevel/command.cmi interp/constrintern.cmi parsing/coqast.cmi \
+    contrib/interface/debug_tac.cmi kernel/declarations.cmi \
+    library/declare.cmi parsing/egrammar.cmi kernel/environ.cmi \
+    pretyping/evd.cmi parsing/extend.cmi interp/genarg.cmi library/global.cmi \
+    contrib/interface/history.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi \
+    toplevel/line_oriented_parser.cmi pretyping/matching.cmi \
+    contrib/interface/name_to_ast.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi contrib/interface/pbp.cmi \
+    parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi parsing/pptactic.cmi \
+    pretyping/pretyping.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    toplevel/protectedtoplevel.cmi pretyping/rawterm.cmi kernel/reduction.cmi \
+    proofs/refiner.cmi parsing/search.cmi contrib/interface/showproof.cmi \
+    contrib/interface/showproof_ct.cmo proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi proofs/tacmach.cmi kernel/term.cmi \
+    parsing/termast.cmi contrib/interface/translate.cmi lib/util.cmi \
+    toplevel/vernac.cmi toplevel/vernacentries.cmi toplevel/vernacexpr.cmo \
+    toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \
+    contrib/interface/xlate.cmi 
+contrib/interface/centaur.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \
+    contrib/interface/blast.cmx toplevel/cerrors.cmx pretyping/classops.cmx \
+    toplevel/command.cmx interp/constrintern.cmx parsing/coqast.cmx \
+    contrib/interface/debug_tac.cmx kernel/declarations.cmx \
+    library/declare.cmx parsing/egrammar.cmx kernel/environ.cmx \
+    pretyping/evd.cmx parsing/extend.cmx interp/genarg.cmx library/global.cmx \
+    contrib/interface/history.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/library.cmx \
+    toplevel/line_oriented_parser.cmx pretyping/matching.cmx \
+    contrib/interface/name_to_ast.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx contrib/interface/pbp.cmx \
+    parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx parsing/pptactic.cmx \
+    pretyping/pretyping.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \
+    toplevel/protectedtoplevel.cmx pretyping/rawterm.cmx kernel/reduction.cmx \
+    proofs/refiner.cmx parsing/search.cmx contrib/interface/showproof.cmx \
+    contrib/interface/showproof_ct.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx proofs/tacmach.cmx kernel/term.cmx \
+    parsing/termast.cmx contrib/interface/translate.cmx lib/util.cmx \
+    toplevel/vernac.cmx toplevel/vernacentries.cmx toplevel/vernacexpr.cmx \
+    toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \
+    contrib/interface/xlate.cmx 
+contrib/interface/ctast.cmo: parsing/coqast.cmi lib/dyn.cmi \
+    library/libnames.cmi kernel/names.cmi lib/util.cmi 
+contrib/interface/ctast.cmx: parsing/coqast.cmx lib/dyn.cmx \
+    library/libnames.cmx kernel/names.cmx lib/util.cmx 
+contrib/interface/dad.cmo: interp/constrextern.cmi interp/constrintern.cmi \
+    kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi library/global.cmi \
+    library/libnames.cmi pretyping/matching.cmi library/nameops.cmi \
+    kernel/names.cmi library/nametab.cmi contrib/interface/paths.cmi \
+    pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \
+    tactics/tactics.cmi kernel/term.cmi interp/topconstr.cmi \
+    pretyping/typing.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    toplevel/vernacinterp.cmi contrib/interface/dad.cmi 
+contrib/interface/dad.cmx: interp/constrextern.cmx interp/constrintern.cmx \
+    kernel/environ.cmx pretyping/evd.cmx interp/genarg.cmx library/global.cmx \
+    library/libnames.cmx pretyping/matching.cmx library/nameops.cmx \
+    kernel/names.cmx library/nametab.cmx contrib/interface/paths.cmx \
+    pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \
+    tactics/tactics.cmx kernel/term.cmx interp/topconstr.cmx \
+    pretyping/typing.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    toplevel/vernacinterp.cmx contrib/interface/dad.cmi 
+contrib/interface/debug_tac.cmo: parsing/ast.cmi toplevel/cerrors.cmi \
+    parsing/coqast.cmi interp/genarg.cmi lib/pp.cmi parsing/pptactic.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi proofs/refiner.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi lib/util.cmi contrib/interface/debug_tac.cmi 
+contrib/interface/debug_tac.cmx: parsing/ast.cmx toplevel/cerrors.cmx \
+    parsing/coqast.cmx interp/genarg.cmx lib/pp.cmx parsing/pptactic.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx proofs/refiner.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx lib/util.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 \
+    contrib/interface/history.cmi 
+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: parsing/ast.cmi pretyping/classops.cmi \
+    interp/constrextern.cmi parsing/coqast.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \
+    library/global.cmi library/impargs.cmi kernel/inductive.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \
+    parsing/prettyp.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \
+    parsing/termast.cmi interp/topconstr.cmi lib/util.cmi \
+    toplevel/vernacexpr.cmo contrib/interface/name_to_ast.cmi 
+contrib/interface/name_to_ast.cmx: parsing/ast.cmx pretyping/classops.cmx \
+    interp/constrextern.cmx parsing/coqast.cmx library/decl_kinds.cmx \
+    kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \
+    library/global.cmx library/impargs.cmx kernel/inductive.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \
+    parsing/prettyp.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \
+    parsing/termast.cmx interp/topconstr.cmx lib/util.cmx \
+    toplevel/vernacexpr.cmx contrib/interface/name_to_ast.cmi 
+contrib/interface/parse.cmo: contrib/interface/ascent.cmi \
+    toplevel/cerrors.cmi config/coq_config.cmi library/declaremods.cmi \
+    parsing/esyntax.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi contrib/interface/line_parser.cmi toplevel/mltop.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi \
+    lib/pp.cmi lib/system.cmi lib/util.cmi toplevel/vernacentries.cmi \
+    toplevel/vernacexpr.cmo contrib/interface/vtp.cmi \
+    contrib/interface/xlate.cmi 
+contrib/interface/parse.cmx: contrib/interface/ascent.cmi \
+    toplevel/cerrors.cmx config/coq_config.cmx library/declaremods.cmx \
+    parsing/esyntax.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx contrib/interface/line_parser.cmx toplevel/mltop.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx \
+    lib/pp.cmx lib/system.cmx lib/util.cmx toplevel/vernacentries.cmx \
+    toplevel/vernacexpr.cmx contrib/interface/vtp.cmx \
+    contrib/interface/xlate.cmx 
+contrib/interface/paths.cmo: contrib/interface/paths.cmi 
+contrib/interface/paths.cmx: contrib/interface/paths.cmi 
+contrib/interface/pbp.cmo: interp/coqlib.cmi kernel/environ.cmi \
+    pretyping/evd.cmi interp/genarg.cmi library/global.cmi \
+    tactics/hipattern.cmi library/libnames.cmi proofs/logic.cmi \
+    pretyping/matching.cmi kernel/names.cmi library/nametab.cmi \
+    pretyping/pattern.cmi lib/pp.cmi pretyping/pretyping.cmi \
+    proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \
+    kernel/reduction.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi \
+    pretyping/typing.cmi lib/util.cmi contrib/interface/pbp.cmi 
+contrib/interface/pbp.cmx: interp/coqlib.cmx kernel/environ.cmx \
+    pretyping/evd.cmx interp/genarg.cmx library/global.cmx \
+    tactics/hipattern.cmx library/libnames.cmx proofs/logic.cmx \
+    pretyping/matching.cmx kernel/names.cmx library/nametab.cmx \
+    pretyping/pattern.cmx lib/pp.cmx pretyping/pretyping.cmx \
+    proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \
+    kernel/reduction.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \
+    pretyping/typing.cmx lib/util.cmx contrib/interface/pbp.cmi 
+contrib/interface/showproof_ct.cmo: contrib/interface/ascent.cmi \
+    parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi lib/pp.cmi \
+    parsing/printer.cmi contrib/interface/translate.cmi \
+    contrib/interface/vtp.cmi contrib/interface/xlate.cmi 
+contrib/interface/showproof_ct.cmx: contrib/interface/ascent.cmi \
+    parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx lib/pp.cmx \
+    parsing/printer.cmx contrib/interface/translate.cmx \
+    contrib/interface/vtp.cmx contrib/interface/xlate.cmx 
+contrib/interface/showproof.cmo: proofs/clenv.cmi interp/constrintern.cmi \
+    parsing/coqast.cmi kernel/declarations.cmi kernel/environ.cmi \
+    pretyping/evd.cmi interp/genarg.cmi library/global.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.cmi \
+    library/nameops.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi pretyping/reductionops.cmi \
+    contrib/interface/showproof_ct.cmo kernel/sign.cmi proofs/tacexpr.cmo \
+    proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \
+    pretyping/termops.cmi contrib/interface/translate.cmi \
+    pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi \
+    contrib/interface/showproof.cmi 
+contrib/interface/showproof.cmx: proofs/clenv.cmx interp/constrintern.cmx \
+    parsing/coqast.cmx kernel/declarations.cmx kernel/environ.cmx \
+    pretyping/evd.cmx interp/genarg.cmx library/global.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx library/libnames.cmx \
+    library/nameops.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx pretyping/reductionops.cmx \
+    contrib/interface/showproof_ct.cmx kernel/sign.cmx proofs/tacexpr.cmx \
+    proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \
+    pretyping/termops.cmx contrib/interface/translate.cmx \
+    pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \
+    contrib/interface/showproof.cmi 
+contrib/interface/translate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \
+    interp/constrextern.cmi contrib/interface/ctast.cmo kernel/environ.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi library/libobject.cmi \
+    library/library.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \
+    proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \
+    parsing/termast.cmi lib/util.cmi toplevel/vernacinterp.cmi \
+    contrib/interface/vtp.cmi contrib/interface/xlate.cmi \
+    contrib/interface/translate.cmi 
+contrib/interface/translate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \
+    interp/constrextern.cmx contrib/interface/ctast.cmx kernel/environ.cmx \
+    pretyping/evarutil.cmx pretyping/evd.cmx library/libobject.cmx \
+    library/library.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \
+    proofs/proof_type.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \
+    parsing/termast.cmx lib/util.cmx toplevel/vernacinterp.cmx \
+    contrib/interface/vtp.cmx contrib/interface/xlate.cmx \
+    contrib/interface/translate.cmi 
+contrib/interface/vtp.cmo: contrib/interface/ascent.cmi \
+    contrib/interface/vtp.cmi 
+contrib/interface/vtp.cmx: contrib/interface/ascent.cmi \
+    contrib/interface/vtp.cmi 
+contrib/interface/xlate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \
+    lib/bignat.cmi library/decl_kinds.cmo tactics/eauto.cmi \
+    parsing/extend.cmi tactics/extraargs.cmi contrib/field/field.cmo \
+    interp/genarg.cmi library/goptions.cmi library/libnames.cmi \
+    kernel/names.cmi lib/options.cmi parsing/ppconstr.cmi \
+    pretyping/rawterm.cmi proofs/tacexpr.cmo kernel/term.cmi \
+    interp/topconstr.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    contrib/interface/xlate.cmi 
+contrib/interface/xlate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \
+    lib/bignat.cmx library/decl_kinds.cmx tactics/eauto.cmx \
+    parsing/extend.cmx tactics/extraargs.cmx contrib/field/field.cmx \
+    interp/genarg.cmx library/goptions.cmx library/libnames.cmx \
+    kernel/names.cmx lib/options.cmx parsing/ppconstr.cmx \
+    pretyping/rawterm.cmx proofs/tacexpr.cmx kernel/term.cmx \
+    interp/topconstr.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    contrib/interface/xlate.cmi 
+contrib/jprover/jall.cmo: contrib/jprover/jlogic.cmi \
+    contrib/jprover/jterm.cmi contrib/jprover/jtunify.cmi \
+    contrib/jprover/opname.cmi lib/pp.cmi contrib/jprover/jall.cmi 
+contrib/jprover/jall.cmx: contrib/jprover/jlogic.cmx \
+    contrib/jprover/jterm.cmx contrib/jprover/jtunify.cmx \
+    contrib/jprover/opname.cmx lib/pp.cmx contrib/jprover/jall.cmi 
+contrib/jprover/jlogic.cmo: contrib/jprover/jterm.cmi \
+    contrib/jprover/opname.cmi contrib/jprover/jlogic.cmi 
+contrib/jprover/jlogic.cmx: contrib/jprover/jterm.cmx \
+    contrib/jprover/opname.cmx contrib/jprover/jlogic.cmi 
+contrib/jprover/jprover.cmo: toplevel/cerrors.cmi proofs/clenv.cmi \
+    parsing/egrammar.cmi interp/genarg.cmi library/global.cmi \
+    tactics/hiddentac.cmi tactics/hipattern.cmi contrib/jprover/jall.cmi \
+    contrib/jprover/jlogic.cmi contrib/jprover/jterm.cmi kernel/names.cmi \
+    lib/options.cmi pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi parsing/printer.cmi proofs/proof_type.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi pretyping/reductionops.cmi \
+    proofs/refiner.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \
+    kernel/term.cmi pretyping/termops.cmi lib/util.cmi 
+contrib/jprover/jprover.cmx: toplevel/cerrors.cmx proofs/clenv.cmx \
+    parsing/egrammar.cmx interp/genarg.cmx library/global.cmx \
+    tactics/hiddentac.cmx tactics/hipattern.cmx contrib/jprover/jall.cmx \
+    contrib/jprover/jlogic.cmx contrib/jprover/jterm.cmx kernel/names.cmx \
+    lib/options.cmx pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx parsing/printer.cmx proofs/proof_type.cmx \
+    pretyping/rawterm.cmx kernel/reduction.cmx pretyping/reductionops.cmx \
+    proofs/refiner.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \
+    kernel/term.cmx pretyping/termops.cmx lib/util.cmx 
+contrib/jprover/jterm.cmo: contrib/jprover/opname.cmi \
+    contrib/jprover/jterm.cmi 
+contrib/jprover/jterm.cmx: contrib/jprover/opname.cmx \
+    contrib/jprover/jterm.cmi 
+contrib/jprover/jtunify.cmo: contrib/jprover/jtunify.cmi 
+contrib/jprover/jtunify.cmx: contrib/jprover/jtunify.cmi 
+contrib/jprover/opname.cmo: contrib/jprover/opname.cmi 
+contrib/jprover/opname.cmx: contrib/jprover/opname.cmi 
+contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \
+    kernel/closure.cmi tactics/contradiction.cmi interp/coqlib.cmi \
+    kernel/declarations.cmi kernel/environ.cmi tactics/equality.cmi \
+    proofs/evar_refiner.cmi library/global.cmi library/goptions.cmi \
+    kernel/inductive.cmi library/libnames.cmi library/library.cmi \
+    proofs/logic.cmi library/nameops.cmi kernel/names.cmi library/nametab.cmi \
+    contrib/omega/omega.cmo lib/options.cmi lib/pp.cmi parsing/printer.cmi \
+    proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \
+    kernel/sign.cmi proofs/tacmach.cmi pretyping/tacred.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/termops.cmi lib/util.cmi 
+contrib/omega/coq_omega.cmx: parsing/ast.cmx proofs/clenv.cmx \
+    kernel/closure.cmx tactics/contradiction.cmx interp/coqlib.cmx \
+    kernel/declarations.cmx kernel/environ.cmx tactics/equality.cmx \
+    proofs/evar_refiner.cmx library/global.cmx library/goptions.cmx \
+    kernel/inductive.cmx library/libnames.cmx library/library.cmx \
+    proofs/logic.cmx library/nameops.cmx kernel/names.cmx library/nametab.cmx \
+    contrib/omega/omega.cmx lib/options.cmx lib/pp.cmx parsing/printer.cmx \
+    proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \
+    kernel/sign.cmx proofs/tacmach.cmx pretyping/tacred.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/termops.cmx lib/util.cmx 
+contrib/omega/g_omega.cmo: toplevel/cerrors.cmi contrib/omega/coq_omega.cmo \
+    parsing/egrammar.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi proofs/refiner.cmi proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi lib/util.cmi 
+contrib/omega/g_omega.cmx: toplevel/cerrors.cmx contrib/omega/coq_omega.cmx \
+    parsing/egrammar.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx proofs/refiner.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx lib/util.cmx 
+contrib/omega/omega.cmo: library/nameops.cmi kernel/names.cmi lib/util.cmi 
+contrib/omega/omega.cmx: library/nameops.cmx kernel/names.cmx lib/util.cmx 
+contrib/ring/g_quote.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \
+    interp/genarg.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi contrib/ring/quote.cmo proofs/refiner.cmi \
+    proofs/tacexpr.cmo tactics/tacinterp.cmi lib/util.cmi 
+contrib/ring/g_quote.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \
+    interp/genarg.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx contrib/ring/quote.cmx proofs/refiner.cmx \
+    proofs/tacexpr.cmx tactics/tacinterp.cmx lib/util.cmx 
+contrib/ring/g_ring.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \
+    interp/genarg.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \
+    parsing/pptactic.cmi contrib/ring/quote.cmo proofs/refiner.cmi \
+    contrib/ring/ring.cmo proofs/tacexpr.cmo tactics/tacinterp.cmi \
+    lib/util.cmi toplevel/vernacinterp.cmi 
+contrib/ring/g_ring.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \
+    interp/genarg.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \
+    parsing/pptactic.cmx contrib/ring/quote.cmx proofs/refiner.cmx \
+    contrib/ring/ring.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \
+    lib/util.cmx toplevel/vernacinterp.cmx 
+contrib/ring/quote.cmo: interp/coqlib.cmi kernel/environ.cmi \
+    library/global.cmi pretyping/instantiate.cmi library/library.cmi \
+    pretyping/matching.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \
+    proofs/proof_trees.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \
+    tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi 
+contrib/ring/quote.cmx: interp/coqlib.cmx kernel/environ.cmx \
+    library/global.cmx pretyping/instantiate.cmx library/library.cmx \
+    pretyping/matching.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \
+    proofs/proof_trees.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \
+    tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx 
+contrib/ring/ring.cmo: kernel/closure.cmi interp/constrintern.cmi \
+    interp/coqlib.cmi tactics/equality.cmi pretyping/evd.cmi \
+    library/global.cmi tactics/hiddentac.cmi tactics/hipattern.cmi \
+    library/lib.cmi library/libnames.cmi library/libobject.cmi \
+    library/library.cmi library/nameops.cmi kernel/names.cmi \
+    library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \
+    parsing/printer.cmi proofs/proof_trees.cmi contrib/ring/quote.cmo \
+    pretyping/reductionops.cmi tactics/setoid_replace.cmi library/summary.cmi \
+    proofs/tacexpr.cmo proofs/tacmach.cmi pretyping/tacred.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \
+    pretyping/typing.cmi lib/util.cmi toplevel/vernacexpr.cmo \
+    toplevel/vernacinterp.cmi 
+contrib/ring/ring.cmx: kernel/closure.cmx interp/constrintern.cmx \
+    interp/coqlib.cmx tactics/equality.cmx pretyping/evd.cmx \
+    library/global.cmx tactics/hiddentac.cmx tactics/hipattern.cmx \
+    library/lib.cmx library/libnames.cmx library/libobject.cmx \
+    library/library.cmx library/nameops.cmx kernel/names.cmx \
+    library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \
+    parsing/printer.cmx proofs/proof_trees.cmx contrib/ring/quote.cmx \
+    pretyping/reductionops.cmx tactics/setoid_replace.cmx library/summary.cmx \
+    proofs/tacexpr.cmx proofs/tacmach.cmx pretyping/tacred.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \
+    pretyping/typing.cmx lib/util.cmx toplevel/vernacexpr.cmx \
+    toplevel/vernacinterp.cmx 
+contrib/romega/const_omega.cmo: interp/coqlib.cmi library/global.cmi \
+    library/libnames.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \
+    kernel/term.cmi lib/util.cmi 
+contrib/romega/const_omega.cmx: interp/coqlib.cmx library/global.cmx \
+    library/libnames.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \
+    kernel/term.cmx lib/util.cmx 
+contrib/romega/g_romega.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \
+    lib/options.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \
+    proofs/refiner.cmi contrib/romega/refl_omega.cmo proofs/tacexpr.cmo \
+    tactics/tacinterp.cmi lib/util.cmi 
+contrib/romega/g_romega.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \
+    lib/options.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \
+    proofs/refiner.cmx contrib/romega/refl_omega.cmx proofs/tacexpr.cmx \
+    tactics/tacinterp.cmx lib/util.cmx 
+contrib/romega/omega2.cmo: kernel/names.cmi lib/util.cmi 
+contrib/romega/omega2.cmx: kernel/names.cmx lib/util.cmx 
+contrib/romega/refl_omega.cmo: contrib/romega/const_omega.cmo \
+    proofs/logic.cmi kernel/names.cmi contrib/romega/omega2.cmo \
+    lib/options.cmi lib/pp.cmi parsing/printer.cmi proofs/tacmach.cmi \
+    tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi 
+contrib/romega/refl_omega.cmx: contrib/romega/const_omega.cmx \
+    proofs/logic.cmx kernel/names.cmx contrib/romega/omega2.cmx \
+    lib/options.cmx lib/pp.cmx parsing/printer.cmx proofs/tacmach.cmx \
+    tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx 
+contrib/xml/acic2Xml.cmo: contrib/xml/acic.cmo contrib/xml/cic2acic.cmo \
+    kernel/names.cmi kernel/term.cmi lib/util.cmi contrib/xml/xml.cmi 
+contrib/xml/acic2Xml.cmx: contrib/xml/acic.cmx contrib/xml/cic2acic.cmx \
+    kernel/names.cmx kernel/term.cmx lib/util.cmx contrib/xml/xml.cmx 
+contrib/xml/acic.cmo: kernel/names.cmi kernel/term.cmi 
+contrib/xml/acic.cmx: kernel/names.cmx kernel/term.cmx 
+contrib/xml/cic2acic.cmo: contrib/xml/acic.cmo kernel/declarations.cmi \
+    library/declare.cmi library/dischargedhypsmap.cmi \
+    contrib/xml/doubleTypeInference.cmi kernel/environ.cmi \
+    pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \
+    kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \
+    library/lib.cmi library/libnames.cmi library/library.cmi \
+    library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \
+    parsing/printer.cmi pretyping/reductionops.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/univ.cmi contrib/xml/unshare.cmi \
+    lib/util.cmi 
+contrib/xml/cic2acic.cmx: contrib/xml/acic.cmx kernel/declarations.cmx \
+    library/declare.cmx library/dischargedhypsmap.cmx \
+    contrib/xml/doubleTypeInference.cmx kernel/environ.cmx \
+    pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \
+    kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \
+    library/lib.cmx library/libnames.cmx library/library.cmx \
+    library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \
+    parsing/printer.cmx pretyping/reductionops.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/univ.cmx contrib/xml/unshare.cmx \
+    lib/util.cmx 
+contrib/xml/doubleTypeInference.cmo: contrib/xml/acic.cmo \
+    kernel/conv_oracle.cmi kernel/environ.cmi pretyping/evarutil.cmi \
+    pretyping/evd.cmi kernel/inductive.cmi pretyping/instantiate.cmi \
+    library/libnames.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \
+    pretyping/rawterm.cmi kernel/reduction.cmi pretyping/reductionops.cmi \
+    pretyping/retyping.cmi pretyping/tacred.cmi kernel/term.cmi \
+    pretyping/termops.cmi kernel/typeops.cmi contrib/xml/unshare.cmi \
+    lib/util.cmi contrib/xml/doubleTypeInference.cmi 
+contrib/xml/doubleTypeInference.cmx: contrib/xml/acic.cmx \
+    kernel/conv_oracle.cmx kernel/environ.cmx pretyping/evarutil.cmx \
+    pretyping/evd.cmx kernel/inductive.cmx pretyping/instantiate.cmx \
+    library/libnames.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \
+    pretyping/rawterm.cmx kernel/reduction.cmx pretyping/reductionops.cmx \
+    pretyping/retyping.cmx pretyping/tacred.cmx kernel/term.cmx \
+    pretyping/termops.cmx kernel/typeops.cmx contrib/xml/unshare.cmx \
+    lib/util.cmx contrib/xml/doubleTypeInference.cmi 
+contrib/xml/proof2aproof.cmo: pretyping/evarutil.cmi pretyping/evd.cmi \
+    library/global.cmi pretyping/instantiate.cmi proofs/logic.cmi lib/pp.cmi \
+    proofs/proof_type.cmi proofs/refiner.cmi kernel/sign.cmi \
+    proofs/tacmach.cmi kernel/term.cmi pretyping/termops.cmi \
+    contrib/xml/unshare.cmi lib/util.cmi 
+contrib/xml/proof2aproof.cmx: pretyping/evarutil.cmx pretyping/evd.cmx \
+    library/global.cmx pretyping/instantiate.cmx proofs/logic.cmx lib/pp.cmx \
+    proofs/proof_type.cmx proofs/refiner.cmx kernel/sign.cmx \
+    proofs/tacmach.cmx kernel/term.cmx pretyping/termops.cmx \
+    contrib/xml/unshare.cmx lib/util.cmx 
+contrib/xml/proofTree2Xml.cmo: contrib/xml/acic.cmo contrib/xml/acic2Xml.cmo \
+    contrib/xml/cic2acic.cmo kernel/environ.cmi pretyping/evd.cmi \
+    library/global.cmi proofs/logic.cmi kernel/names.cmi lib/options.cmi \
+    lib/pp.cmi parsing/pptactic.cmi translate/pptacticnew.cmi \
+    parsing/printer.cmi contrib/xml/proof2aproof.cmo proofs/proof_trees.cmi \
+    proofs/proof_type.cmi kernel/sign.cmi proofs/tacexpr.cmo kernel/term.cmi \
+    contrib/xml/unshare.cmi lib/util.cmi contrib/xml/xml.cmi 
+contrib/xml/proofTree2Xml.cmx: contrib/xml/acic.cmx contrib/xml/acic2Xml.cmx \
+    contrib/xml/cic2acic.cmx kernel/environ.cmx pretyping/evd.cmx \
+    library/global.cmx proofs/logic.cmx kernel/names.cmx lib/options.cmx \
+    lib/pp.cmx parsing/pptactic.cmx translate/pptacticnew.cmx \
+    parsing/printer.cmx contrib/xml/proof2aproof.cmx proofs/proof_trees.cmx \
+    proofs/proof_type.cmx kernel/sign.cmx proofs/tacexpr.cmx kernel/term.cmx \
+    contrib/xml/unshare.cmx lib/util.cmx contrib/xml/xml.cmx 
+contrib/xml/unshare.cmo: contrib/xml/unshare.cmi 
+contrib/xml/unshare.cmx: contrib/xml/unshare.cmi 
+contrib/xml/xmlcommand.cmo: contrib/xml/acic.cmo contrib/xml/acic2Xml.cmo \
+    contrib/xml/cic2acic.cmo config/coq_config.cmi library/decl_kinds.cmo \
+    kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \
+    pretyping/evd.cmi library/global.cmi kernel/inductive.cmi \
+    parsing/lexer.cmi library/lib.cmi library/libnames.cmi \
+    library/libobject.cmi library/library.cmi kernel/names.cmi \
+    library/nametab.cmi proofs/pfedit.cmi contrib/xml/proof2aproof.cmo \
+    proofs/proof_trees.cmi pretyping/recordops.cmi kernel/sign.cmi \
+    proofs/tacmach.cmi kernel/term.cmi contrib/xml/unshare.cmi lib/util.cmi \
+    toplevel/vernac.cmi contrib/xml/xml.cmi contrib/xml/xmlcommand.cmi 
+contrib/xml/xmlcommand.cmx: contrib/xml/acic.cmx contrib/xml/acic2Xml.cmx \
+    contrib/xml/cic2acic.cmx config/coq_config.cmx library/decl_kinds.cmx \
+    kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \
+    pretyping/evd.cmx library/global.cmx kernel/inductive.cmx \
+    parsing/lexer.cmx library/lib.cmx library/libnames.cmx \
+    library/libobject.cmx library/library.cmx kernel/names.cmx \
+    library/nametab.cmx proofs/pfedit.cmx contrib/xml/proof2aproof.cmx \
+    proofs/proof_trees.cmx pretyping/recordops.cmx kernel/sign.cmx \
+    proofs/tacmach.cmx kernel/term.cmx contrib/xml/unshare.cmx lib/util.cmx \
+    toplevel/vernac.cmx contrib/xml/xml.cmx contrib/xml/xmlcommand.cmi 
+contrib/xml/xmlentries.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \
+    parsing/extend.cmi interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi \
+    lib/util.cmi toplevel/vernacinterp.cmi contrib/xml/xmlcommand.cmi 
+contrib/xml/xmlentries.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \
+    parsing/extend.cmx interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \
+    lib/util.cmx toplevel/vernacinterp.cmx contrib/xml/xmlcommand.cmx 
+contrib/xml/xml.cmo: contrib/xml/xml.cmi 
+contrib/xml/xml.cmx: contrib/xml/xml.cmi 
+ide/utils/configwin_html_config.cmo: ide/utils/configwin_ihm.cmo \
+    ide/utils/configwin_messages.cmo ide/utils/configwin_types.cmo \
+    ide/utils/uoptions.cmi 
+ide/utils/configwin_html_config.cmx: ide/utils/configwin_ihm.cmx \
+    ide/utils/configwin_messages.cmx ide/utils/configwin_types.cmx \
+    ide/utils/uoptions.cmx 
+ide/utils/configwin_ihm.cmo: ide/utils/configwin_messages.cmo \
+    ide/utils/configwin_types.cmo ide/utils/okey.cmi ide/utils/uoptions.cmi 
+ide/utils/configwin_ihm.cmx: ide/utils/configwin_messages.cmx \
+    ide/utils/configwin_types.cmx ide/utils/okey.cmx ide/utils/uoptions.cmx 
+ide/utils/configwin.cmo: ide/utils/configwin_ihm.cmo \
+    ide/utils/configwin_types.cmo ide/utils/configwin.cmi 
+ide/utils/configwin.cmx: ide/utils/configwin_ihm.cmx \
+    ide/utils/configwin_types.cmx ide/utils/configwin.cmi 
+ide/utils/configwin_types.cmo: ide/utils/configwin_keys.cmo \
+    ide/utils/uoptions.cmi 
+ide/utils/configwin_types.cmx: ide/utils/configwin_keys.cmx \
+    ide/utils/uoptions.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/main.cmo: config/coq_config.cmi tools/coqdoc/index.cmi \
+    tools/coqdoc/output.cmi tools/coqdoc/pretty.cmi 
+tools/coqdoc/main.cmx: config/coq_config.cmx tools/coqdoc/index.cmx \
+    tools/coqdoc/output.cmx tools/coqdoc/pretty.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/pretty.cmo: tools/coqdoc/index.cmi tools/coqdoc/output.cmi \
+    tools/coqdoc/pretty.cmi 
+tools/coqdoc/pretty.cmx: tools/coqdoc/index.cmx tools/coqdoc/output.cmx \
+    tools/coqdoc/pretty.cmi 
+tactics/tauto.cmo: parsing/grammar.cma
+tactics/tauto.cmx: parsing/grammar.cma
+tactics/eqdecide.cmo: parsing/grammar.cma
+tactics/eqdecide.cmx: parsing/grammar.cma
+tactics/extraargs.cmo: parsing/grammar.cma
+tactics/extraargs.cmx: parsing/grammar.cma
+tactics/extratactics.cmo: parsing/grammar.cma
+tactics/extratactics.cmx: parsing/grammar.cma
+tactics/eauto.cmo: parsing/grammar.cma
+tactics/eauto.cmx: parsing/grammar.cma
+contrib/omega/g_omega.cmo: parsing/grammar.cma
+contrib/omega/g_omega.cmx: parsing/grammar.cma
+contrib/romega/g_romega.cmo: parsing/grammar.cma
+contrib/romega/g_romega.cmx: parsing/grammar.cma
+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/field/field.cmo: parsing/grammar.cma
+contrib/field/field.cmx: parsing/grammar.cma
+contrib/fourier/g_fourier.cmo: parsing/grammar.cma
+contrib/fourier/g_fourier.cmx: parsing/grammar.cma
+contrib/extraction/g_extraction.cmo: parsing/grammar.cma
+contrib/extraction/g_extraction.cmx: parsing/grammar.cma
+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/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/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/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_proofs.cmo: 
+parsing/g_proofs.cmx: 
+parsing/g_cases.cmo: 
+parsing/g_cases.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: 
+parsing/g_ltac.cmx: 
+parsing/argextend.cmo: 
+parsing/argextend.cmx: 
+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: 
+toplevel/mltop.cmo: 
+toplevel/mltop.cmx: 
+lib/pp.cmo: 
+lib/pp.cmx: 
+lib/compat.cmo: 
+lib/compat.cmx: 
+contrib/xml/xml.cmo: 
+contrib/xml/xml.cmx: 
+contrib/xml/acic2Xml.cmo: 
+contrib/xml/acic2Xml.cmx: 
+contrib/xml/proofTree2Xml.cmo: 
+contrib/xml/proofTree2Xml.cmx: 
+contrib/interface/line_parser.cmo: 
+contrib/interface/line_parser.cmx: 
+tools/coq_makefile.cmo: 
+tools/coq_makefile.cmx: 
+tools/coq-tex.cmo: 
+tools/coq-tex.cmx: 
diff --git a/.depend.camlp4 b/.depend.camlp4
new file mode 100644
index 00000000..a34765fc
--- /dev/null
+++ b/.depend.camlp4
@@ -0,0 +1,51 @@
+tactics/tauto.ml: parsing/grammar.cma
+tactics/eqdecide.ml: parsing/grammar.cma
+tactics/extraargs.ml: parsing/grammar.cma
+tactics/extratactics.ml: parsing/grammar.cma
+tactics/eauto.ml: parsing/grammar.cma
+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/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/funind/tacinv.ml: parsing/grammar.cma
+contrib/first-order/g_ground.ml: parsing/grammar.cma
+contrib/interface/debug_tac.ml: parsing/grammar.cma
+contrib/interface/centaur.ml: parsing/grammar.cma
+parsing/lexer.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_proofs.ml: 
+parsing/g_cases.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: 
+toplevel/mltop.ml: 
+lib/pp.ml: 
+lib/compat.ml: 
+contrib/xml/xml.ml: 
+contrib/xml/acic2Xml.ml: 
+contrib/xml/proofTree2Xml.ml: 
+contrib/interface/line_parser.ml: 
+tools/coq_makefile.ml: 
+tools/coq-tex.ml: 
diff --git a/.depend.coq b/.depend.coq
new file mode 100644
index 00000000..95233f2e
--- /dev/null
+++ b/.depend.coq
@@ -0,0 +1,278 @@
+theories/Reals/Rdefinitions.vo: theories/Reals/Rdefinitions.v theories/ZArith/ZArith_base.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/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/R_Ifp.vo: theories/Reals/R_Ifp.v theories/Reals/Rbase.vo contrib/omega/Omega.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/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
+theories/Reals/PartSum.vo: theories/Reals/PartSum.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/Rcomplete.vo theories/Arith/Max.vo
+theories/Reals/AltSeries.vo: theories/Reals/AltSeries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/PartSum.vo theories/Arith/Max.vo
+theories/Reals/Binomial.vo: theories/Reals/Binomial.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/PartSum.vo
+theories/Reals/Rsigma.vo: theories/Reals/Rsigma.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo
+theories/Reals/Rprod.vo: theories/Reals/Rprod.v theories/Arith/Compare.vo theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo theories/Reals/Binomial.vo
+theories/Reals/Cauchy_prod.vo: theories/Reals/Cauchy_prod.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo
+theories/Reals/Alembert.vo: theories/Reals/Alembert.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/PartSum.vo theories/Arith/Max.vo
+theories/Reals/SeqSeries.vo: theories/Reals/SeqSeries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Arith/Max.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/Rcomplete.vo theories/Reals/PartSum.vo theories/Reals/AltSeries.vo theories/Reals/Binomial.vo theories/Reals/Rsigma.vo theories/Reals/Rprod.vo theories/Reals/Cauchy_prod.vo theories/Reals/Alembert.vo
+theories/Reals/Rtrigo_fun.vo: theories/Reals/Rtrigo_fun.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo
+theories/Reals/Rtrigo_def.vo: theories/Reals/Rtrigo_def.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_fun.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo_alt.vo: theories/Reals/Rtrigo_alt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo
+theories/Reals/Cos_rel.vo: theories/Reals/Cos_rel.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo
+theories/Reals/Cos_plus.vo: theories/Reals/Cos_plus.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo theories/Reals/Cos_rel.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo.vo: theories/Reals/Rtrigo.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_fun.vo theories/Reals/Rtrigo_def.vo theories/Reals/Rtrigo_alt.vo theories/Reals/Cos_rel.vo theories/Reals/Cos_plus.vo theories/ZArith/ZArith_base.vo theories/ZArith/Zcomplements.vo theories/Logic/Classical_Prop.vo
+theories/Reals/Rlimit.vo: theories/Reals/Rlimit.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Logic/Classical_Prop.vo contrib/fourier/Fourier.vo
+theories/Reals/Rderiv.vo: theories/Reals/Rderiv.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rlimit.vo contrib/fourier/Fourier.vo theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo contrib/omega/Omega.vo
+theories/Reals/RList.vo: theories/Reals/RList.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo
+theories/Reals/Ranalysis1.vo: theories/Reals/Ranalysis1.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rlimit.vo theories/Reals/Rderiv.vo
+theories/Reals/Ranalysis2.vo: theories/Reals/Ranalysis2.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo
+theories/Reals/Ranalysis3.vo: theories/Reals/Ranalysis3.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis2.vo
+theories/Reals/Rtopology.vo: theories/Reals/Rtopology.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/RList.vo theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo
+theories/Reals/MVT.vo: theories/Reals/MVT.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Rtopology.vo
+theories/Reals/PSeries_reg.vo: theories/Reals/PSeries_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo theories/Arith/Max.vo theories/Arith/Even.vo
+theories/Reals/Exp_prop.vo: theories/Reals/Exp_prop.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/PSeries_reg.vo theories/Arith/Div2.vo theories/Arith/Even.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo_reg.vo: theories/Reals/Rtrigo_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/PSeries_reg.vo
+theories/Reals/Rsqrt_def.vo: theories/Reals/Rsqrt_def.v theories/Bool/Sumbool.vo theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo
+theories/Reals/R_sqrt.vo: theories/Reals/R_sqrt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rsqrt_def.vo
+theories/Reals/Rtrigo_calc.vo: theories/Reals/Rtrigo_calc.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/R_sqrt.vo
+theories/Reals/Rgeom.vo: theories/Reals/Rgeom.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/R_sqrt.vo
+theories/Reals/Sqrt_reg.vo: theories/Reals/Sqrt_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/R_sqrt.vo
+theories/Reals/Ranalysis4.vo: theories/Reals/Ranalysis4.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis3.vo theories/Reals/Exp_prop.vo
+theories/Reals/Rpower.vo: theories/Reals/Rpower.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/Exp_prop.vo theories/Reals/Rsqrt_def.vo theories/Reals/R_sqrt.vo theories/Reals/MVT.vo theories/Reals/Ranalysis4.vo
+theories/Reals/Ranalysis.vo: theories/Reals/Ranalysis.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rtrigo.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis2.vo theories/Reals/Ranalysis3.vo theories/Reals/Rtopology.vo theories/Reals/MVT.vo theories/Reals/PSeries_reg.vo theories/Reals/Exp_prop.vo theories/Reals/Rtrigo_reg.vo theories/Reals/Rsqrt_def.vo theories/Reals/R_sqrt.vo theories/Reals/Rtrigo_calc.vo theories/Reals/Rgeom.vo theories/Reals/RList.vo theories/Reals/Sqrt_reg.vo theories/Reals/Ranalysis4.vo theories/Reals/Rpower.vo
+theories/Reals/NewtonInt.vo: theories/Reals/NewtonInt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis.vo
+theories/Reals/RiemannInt_SF.vo: theories/Reals/RiemannInt_SF.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis.vo theories/Logic/Classical_Prop.vo
+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/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
+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/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
+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/Logic/Hurkens.vo: theories/Logic/Hurkens.v
+theories/Logic/ProofIrrelevance.vo: theories/Logic/ProofIrrelevance.v theories/Logic/Hurkens.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_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/Berardi.vo: theories/Logic/Berardi.v
+theories/Logic/Eqdep_dec.vo: theories/Logic/Eqdep_dec.v
+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/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/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/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/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
+theories/Arith/Even.vo: theories/Arith/Even.v
+theories/Arith/EqNat.vo: theories/Arith/EqNat.v
+theories/Arith/Peano_dec.vo: theories/Arith/Peano_dec.v theories/Logic/Decidable.vo
+theories/Arith/Euclid.vo: theories/Arith/Euclid.v theories/Arith/Mult.vo theories/Arith/Compare_dec.vo theories/Arith/Wf_nat.vo
+theories/Arith/Plus.vo: theories/Arith/Plus.v theories/Arith/Le.vo theories/Arith/Lt.vo
+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/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
+theories/Bool/DecBool.vo: theories/Bool/DecBool.v
+theories/Bool/Sumbool.vo: theories/Bool/Sumbool.v
+theories/Bool/BoolEq.vo: theories/Bool/BoolEq.v theories/Bool/Bool.vo
+theories/Bool/Bvector.vo: theories/Bool/Bvector.v theories/Bool/Bool.vo theories/Bool/Sumbool.vo theories/Arith/Arith.vo
+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/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/Zbool.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/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/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/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/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/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/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
+theories/Sets/Powerset.vo: theories/Sets/Powerset.v theories/Sets/Ensembles.vo theories/Sets/Relations_1.vo theories/Sets/Relations_1_facts.vo theories/Sets/Partial_Order.vo theories/Sets/Cpo.vo
+theories/Sets/Cpo.vo: theories/Sets/Cpo.v theories/Sets/Ensembles.vo theories/Sets/Relations_1.vo theories/Sets/Partial_Order.vo
+theories/Sets/Powerset_Classical_facts.vo: theories/Sets/Powerset_Classical_facts.v theories/Sets/Ensembles.vo theories/Sets/Constructive_sets.vo theories/Sets/Relations_1.vo theories/Sets/Relations_1_facts.vo theories/Sets/Partial_Order.vo theories/Sets/Cpo.vo theories/Sets/Powerset.vo theories/Sets/Powerset_facts.vo theories/Logic/Classical_Type.vo theories/Sets/Classical_sets.vo
+theories/Sets/Ensembles.vo: theories/Sets/Ensembles.v
+theories/Sets/Powerset_facts.vo: theories/Sets/Powerset_facts.v theories/Sets/Ensembles.vo theories/Sets/Constructive_sets.vo theories/Sets/Relations_1.vo theories/Sets/Relations_1_facts.vo theories/Sets/Partial_Order.vo theories/Sets/Cpo.vo theories/Sets/Powerset.vo
+theories/Sets/Finite_sets.vo: theories/Sets/Finite_sets.v theories/Sets/Ensembles.vo theories/Sets/Constructive_sets.vo
+theories/Sets/Relations_1.vo: theories/Sets/Relations_1.v
+theories/Sets/Finite_sets_facts.vo: theories/Sets/Finite_sets_facts.v theories/Sets/Finite_sets.vo theories/Sets/Constructive_sets.vo theories/Logic/Classical_Type.vo theories/Sets/Classical_sets.vo theories/Sets/Powerset.vo theories/Sets/Powerset_facts.vo theories/Sets/Powerset_Classical_facts.vo theories/Arith/Gt.vo theories/Arith/Lt.vo
+theories/Sets/Relations_1_facts.vo: theories/Sets/Relations_1_facts.v theories/Sets/Relations_1.vo
+theories/Sets/Image.vo: theories/Sets/Image.v theories/Sets/Finite_sets.vo theories/Sets/Constructive_sets.vo theories/Logic/Classical_Type.vo theories/Sets/Classical_sets.vo theories/Sets/Powerset.vo theories/Sets/Powerset_facts.vo theories/Sets/Powerset_Classical_facts.vo theories/Arith/Gt.vo theories/Arith/Lt.vo theories/Arith/Le.vo theories/Sets/Finite_sets_facts.vo
+theories/Sets/Relations_2.vo: theories/Sets/Relations_2.v theories/Sets/Relations_1.vo
+theories/Sets/Infinite_sets.vo: theories/Sets/Infinite_sets.v theories/Sets/Finite_sets.vo theories/Sets/Constructive_sets.vo theories/Logic/Classical_Type.vo theories/Sets/Classical_sets.vo theories/Sets/Powerset.vo theories/Sets/Powerset_facts.vo theories/Sets/Powerset_Classical_facts.vo theories/Arith/Gt.vo theories/Arith/Lt.vo theories/Arith/Le.vo theories/Sets/Finite_sets_facts.vo theories/Sets/Image.vo
+theories/Sets/Relations_2_facts.vo: theories/Sets/Relations_2_facts.v theories/Sets/Relations_1.vo theories/Sets/Relations_1_facts.vo theories/Sets/Relations_2.vo
+theories/Sets/Integers.vo: theories/Sets/Integers.v theories/Sets/Finite_sets.vo theories/Sets/Constructive_sets.vo theories/Logic/Classical_Type.vo theories/Sets/Classical_sets.vo theories/Sets/Powerset.vo theories/Sets/Powerset_facts.vo theories/Sets/Powerset_Classical_facts.vo theories/Arith/Gt.vo theories/Arith/Lt.vo theories/Arith/Le.vo theories/Sets/Finite_sets_facts.vo theories/Sets/Image.vo theories/Sets/Infinite_sets.vo theories/Arith/Compare_dec.vo theories/Sets/Relations_1.vo theories/Sets/Partial_Order.vo theories/Sets/Cpo.vo
+theories/Sets/Relations_3.vo: theories/Sets/Relations_3.v theories/Sets/Relations_1.vo theories/Sets/Relations_2.vo
+theories/Sets/Multiset.vo: theories/Sets/Multiset.v theories/Sets/Permut.vo theories/Arith/Plus.vo
+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/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
+theories/Relations/Relation_Operators.vo: theories/Relations/Relation_Operators.v theories/Relations/Relation_Definitions.vo theories/Lists/List.vo
+theories/Relations/Relations.vo: theories/Relations/Relations.v theories/Relations/Relation_Definitions.vo theories/Relations/Relation_Operators.vo theories/Relations/Operators_Properties.vo
+theories/Relations/Rstar.vo: theories/Relations/Rstar.v
+theories/Wellfounded/Disjoint_Union.vo: theories/Wellfounded/Disjoint_Union.v theories/Relations/Relation_Operators.vo
+theories/Wellfounded/Inclusion.vo: theories/Wellfounded/Inclusion.v theories/Relations/Relation_Definitions.vo
+theories/Wellfounded/Inverse_Image.vo: theories/Wellfounded/Inverse_Image.v
+theories/Wellfounded/Lexicographic_Exponentiation.vo: theories/Wellfounded/Lexicographic_Exponentiation.v theories/Logic/Eqdep.vo theories/Lists/List.vo theories/Relations/Relation_Operators.vo theories/Wellfounded/Transitive_Closure.vo
+theories/Wellfounded/Transitive_Closure.vo: theories/Wellfounded/Transitive_Closure.v theories/Relations/Relation_Definitions.vo theories/Relations/Relation_Operators.vo
+theories/Wellfounded/Union.vo: theories/Wellfounded/Union.v theories/Relations/Relation_Operators.vo theories/Relations/Relation_Definitions.vo theories/Wellfounded/Transitive_Closure.vo
+theories/Wellfounded/Wellfounded.vo: theories/Wellfounded/Wellfounded.v theories/Wellfounded/Disjoint_Union.vo theories/Wellfounded/Inclusion.vo theories/Wellfounded/Inverse_Image.vo theories/Wellfounded/Lexicographic_Exponentiation.vo theories/Wellfounded/Lexicographic_Product.vo theories/Wellfounded/Transitive_Closure.vo theories/Wellfounded/Union.vo theories/Wellfounded/Well_Ordering.vo
+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/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/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/R_Ifp.vo: theories/Reals/R_Ifp.v theories/Reals/Rbase.vo contrib/omega/Omega.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/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
+theories/Reals/PartSum.vo: theories/Reals/PartSum.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/Rcomplete.vo theories/Arith/Max.vo
+theories/Reals/AltSeries.vo: theories/Reals/AltSeries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/PartSum.vo theories/Arith/Max.vo
+theories/Reals/Binomial.vo: theories/Reals/Binomial.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/PartSum.vo
+theories/Reals/Rsigma.vo: theories/Reals/Rsigma.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo
+theories/Reals/Rprod.vo: theories/Reals/Rprod.v theories/Arith/Compare.vo theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo theories/Reals/Binomial.vo
+theories/Reals/Cauchy_prod.vo: theories/Reals/Cauchy_prod.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo
+theories/Reals/Alembert.vo: theories/Reals/Alembert.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/PartSum.vo theories/Arith/Max.vo
+theories/Reals/SeqSeries.vo: theories/Reals/SeqSeries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Arith/Max.vo theories/Reals/Rseries.vo theories/Reals/SeqProp.vo theories/Reals/Rcomplete.vo theories/Reals/PartSum.vo theories/Reals/AltSeries.vo theories/Reals/Binomial.vo theories/Reals/Rsigma.vo theories/Reals/Rprod.vo theories/Reals/Cauchy_prod.vo theories/Reals/Alembert.vo
+theories/Reals/Rtrigo_fun.vo: theories/Reals/Rtrigo_fun.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo
+theories/Reals/Rtrigo_def.vo: theories/Reals/Rtrigo_def.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_fun.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo_alt.vo: theories/Reals/Rtrigo_alt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo
+theories/Reals/Cos_rel.vo: theories/Reals/Cos_rel.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo
+theories/Reals/Cos_plus.vo: theories/Reals/Cos_plus.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_def.vo theories/Reals/Cos_rel.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo.vo: theories/Reals/Rtrigo.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo_fun.vo theories/Reals/Rtrigo_def.vo theories/Reals/Rtrigo_alt.vo theories/Reals/Cos_rel.vo theories/Reals/Cos_plus.vo theories/ZArith/ZArith_base.vo theories/ZArith/Zcomplements.vo theories/Logic/Classical_Prop.vo
+theories/Reals/Rlimit.vo: theories/Reals/Rlimit.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Logic/Classical_Prop.vo contrib/fourier/Fourier.vo
+theories/Reals/Rderiv.vo: theories/Reals/Rderiv.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rlimit.vo contrib/fourier/Fourier.vo theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo contrib/omega/Omega.vo
+theories/Reals/RList.vo: theories/Reals/RList.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo
+theories/Reals/Ranalysis1.vo: theories/Reals/Ranalysis1.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rlimit.vo theories/Reals/Rderiv.vo
+theories/Reals/Ranalysis2.vo: theories/Reals/Ranalysis2.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo
+theories/Reals/Ranalysis3.vo: theories/Reals/Ranalysis3.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis2.vo
+theories/Reals/Rtopology.vo: theories/Reals/Rtopology.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/RList.vo theories/Logic/Classical_Prop.vo theories/Logic/Classical_Pred_Type.vo
+theories/Reals/MVT.vo: theories/Reals/MVT.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Rtopology.vo
+theories/Reals/PSeries_reg.vo: theories/Reals/PSeries_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo theories/Arith/Max.vo theories/Arith/Even.vo
+theories/Reals/Exp_prop.vo: theories/Reals/Exp_prop.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/PSeries_reg.vo theories/Arith/Div2.vo theories/Arith/Even.vo theories/Arith/Max.vo
+theories/Reals/Rtrigo_reg.vo: theories/Reals/Rtrigo_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/PSeries_reg.vo
+theories/Reals/Rsqrt_def.vo: theories/Reals/Rsqrt_def.v theories/Bool/Sumbool.vo theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo
+theories/Reals/R_sqrt.vo: theories/Reals/R_sqrt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rsqrt_def.vo
+theories/Reals/Rtrigo_calc.vo: theories/Reals/Rtrigo_calc.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/R_sqrt.vo
+theories/Reals/Rgeom.vo: theories/Reals/Rgeom.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/R_sqrt.vo
+theories/Reals/Sqrt_reg.vo: theories/Reals/Sqrt_reg.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/R_sqrt.vo
+theories/Reals/Ranalysis4.vo: theories/Reals/Ranalysis4.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis3.vo theories/Reals/Exp_prop.vo
+theories/Reals/Rpower.vo: theories/Reals/Rpower.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis1.vo theories/Reals/Exp_prop.vo theories/Reals/Rsqrt_def.vo theories/Reals/R_sqrt.vo theories/Reals/MVT.vo theories/Reals/Ranalysis4.vo
+theories/Reals/Ranalysis.vo: theories/Reals/Ranalysis.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rtrigo.vo theories/Reals/SeqSeries.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis2.vo theories/Reals/Ranalysis3.vo theories/Reals/Rtopology.vo theories/Reals/MVT.vo theories/Reals/PSeries_reg.vo theories/Reals/Exp_prop.vo theories/Reals/Rtrigo_reg.vo theories/Reals/Rsqrt_def.vo theories/Reals/R_sqrt.vo theories/Reals/Rtrigo_calc.vo theories/Reals/Rgeom.vo theories/Reals/RList.vo theories/Reals/Sqrt_reg.vo theories/Reals/Ranalysis4.vo theories/Reals/Rpower.vo
+theories/Reals/NewtonInt.vo: theories/Reals/NewtonInt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo theories/Reals/Rtrigo.vo theories/Reals/Ranalysis.vo
+theories/Reals/RiemannInt_SF.vo: theories/Reals/RiemannInt_SF.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis.vo theories/Logic/Classical_Prop.vo
+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/Sorting.vo: theories/Sorting/Sorting.v theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Relations/Relations.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/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/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
diff --git a/.depend.coq7 b/.depend.coq7
new file mode 100644
index 00000000..452c951f
--- /dev/null
+++ b/.depend.coq7
@@ -0,0 +1,231 @@
+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
new file mode 100644
index 00000000..2daeded1
--- /dev/null
+++ b/CHANGES
@@ -0,0 +1,1027 @@
+Changes from V8.0 to V8.0pl1
+============================
+
+Unicode support
+
+- Miscellaneous Mathematical Symbols-A and B, and Supplemental
+  Arrows-A now supported
+
+Bug fixes
+
+- 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
+=============================
+
+Vernacular commands
+
+- New option "Set Printing All" to deactivate all high-level forms of
+  printing (implicit arguments, coercions, destructing let,
+  if-then-else, notations, projections)
+- "Functional Scheme" and "Functional Induction" extended to polymorphic
+  types and dependent types
+- Notation now allows recursive patterns, hence recovering parts of the
+  fonctionalities of pre-V8 Grammar/Syntax commands
+- Command "Print." discontinued.
+- Redundant syntax "Implicit Arguments On/Off" discontinued
+
+New syntax
+
+- Semantics change of the if-then-else construction in new syntax: 
+  "if c then t1 else t2" now stands for
+  "match c with c1 _ ... _ => t1 | c2 _ ... _ => t2 end"
+  with no dependency of t1 and t2 in the arguments of the constructors;
+  this may cause incompatibilities for files translated using coq 8.0beta
+
+Interpretation scopes
+
+- Delimiting key %bool for bool_scope added
+- Import no more needed to activate argument scopes from a module
+
+Tactics and the tactic Language
+
+- Semantics of "assert" is now consistent with the reference manual
+- New tactics stepl and stepr for chaining transitivity steps
+- Tactic "replace ... with ... in" added
+- Intro patterns now supported in Ltac (parsed with prefix "ipattern:")
+
+Executables and tools
+
+- Added option -top to change the name of the toplevel module "Top"
+- Coqdoc updated to new syntax and now part of Coq sources
+- XML exportation tool now exports the structure of vernacular files 
+  (cf chapter 13 in the reference manual)
+
+User contributions
+
+- User contributions have been updated to the new syntax
+
+Bug fixes
+
+- Many bugs have been fixed (cf coq-bugs web page)
+
+Changes from V8.0beta old syntax to V8.0beta
+============================================
+
+New concrete syntax
+
+- A completely new syntax for terms
+- A more uniform syntax for tactics and the tactic language 
+- A few syntactic changes for vernacular commands
+- A smart automatic translator translating V8.0 files in old syntax to
+  files valid for V8.0
+
+Syntax extensions
+
+- "Grammar" for terms disappears
+- "Grammar" for tactics becomes "Tactic Notation"
+- "Syntax" disappears
+- Introduction of a notion of interpretation scope allowing to use the
+  same notations in various contexts without using specific delimiters
+  (e.g the same expression "4<=3+x" is interpreted either in "nat",
+  "positive", "N" (previously "entier"), "Z", "R", depending on which
+  interpretation scope is currently open) [see documentation for details]
+- Notation now mandatorily requires a precedence and associativity
+  (default was to set precedence to 1 and associativity to none)
+
+Revision of the standard library
+
+- Many lemmas and definitions names have been made more uniform mostly 
+  in Arith, NArith, ZArith and Reals (e.g : "times" -> "Pmult",
+  "times_sym" -> "Pmult_comm", "Zle_Zmult_pos_right" ->
+  "Zmult_le_compat_r", "SUPERIEUR" -> "Gt", "ZERO" -> "Z0")
+- Order and names of arguments of basic lemmas on nat, Z, positive and R
+  have been made uniform.
+- Notions of Coq initial state are declared with (strict) implicit arguments
+- eq merged with eqT: old eq disappear, new eq (written =) is old eqT
+  and new eqT is syntactic sugar for new eq (notation == is an alias
+  for = and is written as it, exceptional source of incompatibilities)
+- Similarly, ex, ex2, all, identity are merged with exT, exT2, allT, identityT
+- Arithmetical notations for nat, positive, N, Z, R, without needing
+  any backquote or double-backquotes delimiters.
+- In Lists: new concrete notations; argument of nil is now implicit
+- All changes in the library are taken in charge by the translator
+
+Semantical changes during translation
+
+- Recursive keyword set by default (and no longer needed) in Tactic Definition
+- Set Implicit Arguments is strict by default in new syntax
+- reductions in hypotheses of the form "... in H" now apply to the type
+  also if H is a local definition
+- etc
+
+Gallina
+
+- New syntax of the form "Inductive bool : Set := true, false : bool." for
+  enumerated types
+- Experimental syntax of the form p.(fst) for record projections
+  (activable with option "Set Printing Projections" which is
+   recognized by the translator)
+
+Known problems of the automatic translation
+
+- iso-latin-1 characters are no longer supported: move your files to
+  7-bits ASCII or unicode before translation (swith to unicode is
+  automatically done if a file is loaded and saved again by coqide)
+- Renaming in ZArith: incompatibilities in Coq user contribs due to
+  merging names INZ, from Reals, and inject_nat.
+- Renaming and new lemmas in ZArith: may clash with names used by users
+- Restructuration of ZArith: replace requirement of specific modules
+  in ZArith by "Require Import ZArith_base" or "Require Import ZArith"
+- Some implicit arguments must be made explicit before translation: typically
+  for "length nil", the implicit argument of length must be made explicit
+- Grammar rules, Infix notations and V7.4 Notations must be updated wrt the
+  new scheme for syntactic extensions (see translator documentation)
+- Unsafe for annotation Cases when constructors coercions are used or when
+  annotations are eta-reduced predicates
+ 
+
+Changes from V7.4 to V8.0beta old syntax
+========================================
+
+Logic
+
+- Set now predicative by default
+- New option -impredicative-set to set Set impredicative
+- The standard library doesn't need impredicativity of Set and is
+  compatible with the classical axioms which contradict Set impredicativity
+
+Syntax for arithmetic
+
+- Notation "=" and "<>" in Z and R are no longer implicitly in Z or R
+  (with possible introduction of a coercion), use <Z>...=... or
+  <Z>...<>... instead
+- Locate applied to a simple string (e.g. "+") searches for all
+  notations containing this string
+
+Vernacular commands
+
+- "Declare ML Module" now allows to import .cma files. This avoids to use a
+   bunch of "Declare ML Module" statements when using several ML files.
+- "Set Printing Width n" added, allows to change the size of width printing
+   (TODO : doc).
+- "Implicit Variables Type x,y:t" (new syntax: "Implicit Types x y:t")
+  assigns default types for binding variables.
+- Declarations of Hints and Notation now accept a "Local" flag not to
+  be exported outside the current file even if not in section
+- "Print Scopes" prints all notations
+- New command "About name" for light printing of type, implicit arguments, etc.
+- New command "Admitted" to declare incompletely proven statement as axioms
+- New keyword "Conjecture" to declare an axiom intended to be provable
+- SearchAbout can now search for lemmas referring to more than one constant
+  and on substrings of the name of the lemma
+- "Print Implicit" displays the implicit arguments of a constant
+- Locate now searches for all names having a given suffix
+- New command "Functional Scheme" for building an induction principle
+  from a function defined by case analysis and fix.
+
+Commands
+
+- new coqtop/coqc option -dont-load-proofs not to load opaque proofs in memory
+
+Implicit arguments
+
+- Inductive in sections declared with implicits now "discharged" with
+  implicits (like constants and variables)
+- Implicit Arguments flags are now synchronous with reset
+- New switch "Unset/Set Printing Implicits" (new syntax: "Unset/Set Printing
+  Implicit") to globally control printing of implicits
+
+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
+
+Library
+
+- New file about the factorial function in Arith
+- An additional elimination Acc_iter for Acc, simplier than Acc_rect. 
+  This new elimination principle is used for definition well_founded_induction.
+- New library NArith on binary natural numbers
+- R is now of type Set
+- Restructuration in ZArith library
+  - "true_sub" used in Zplus now a definition, not a local one (source
+  of incompatibilities in proof referring to true_sub, may need extra Unfold)
+  - Some lemmas about minus moved from fast_integer to Arith/Minus.v
+  (le_minus, lt_mult_left) (theoretical source of incompatibilities)
+  - Several lemmas moved from auxiliary.v and zarith_aux.v to
+  fast_integer.v (theoretical source of incompatibilities)
+  - Variables names of iff_trans changed (source of incompatibilities)
+  - ZArith lemmas named OMEGA something or fast_ something, and lemma new_var 
+    are now out of ZArith (except OMEGA2)
+  - Redundant ZArith lemmas have been renamed: for the following pairs,
+  use the second name (Zle_Zmult_right2, Zle_mult_simpl), (OMEGA2,
+  Zle_0_plus), (Zplus_assoc_l, Zplus_assoc), (Zmult_one, Zmult_1_n),
+  (Zmult_assoc_l, Zmult_assoc), (Zmult_minus_distr, Zmult_Zminus_distr_l)
+  (add_un_double_moins_un_xO, is_double_moins_un),
+  (Rlt_monotony_rev,Rlt_monotony_contra) (source of incompatibilities)
+- Few minor changes (no more implicit arguments in
+  Zmult_Zminus_distr_l and Zmult_Zminus_distr_r, lemmas moved from
+  Zcomplements to other files) (rare source of incompatibilities)
+- New lemmas provided by users added
+
+Tactic language
+
+- Fail tactic now accepts a failure message
+- Idtac tactic now accepts a message
+- New primitive tactic "FreshId" (new syntax: "fresh") to generate new names
+- Debugger prints levels of calls
+
+Tactics
+
+- Replace can now replace proofs also
+- Fail levels are now decremented at "Match Context" blocks only and
+  if the right-hand-side of "Match term With" are tactics, these
+  tactics are never evaluated immediately and do not induce
+  backtracking (in contrast with "Match Context")
+- Quantified names now avoid global names of the current module (like
+  Intro names did) [source of rare incompatibilities: 2 changes in the set of
+  user contribs]
+- NewDestruct/NewInduction accepts intro patterns as introduction names
+- NewDestruct/NewInduction now work for non-inductive type using option "using"
+- A NewInduction naming bug for inductive types with functional
+  arguments (e.g. the accessibility predicate) has been fixed (source
+  of incompatibilities)
+- Symmetry now applies to hypotheses too
+- Inversion now accept option "as [ ... ]" to name the hypotheses
+- Contradiction now looks also for contradictory hypotheses stating ~A and A
+  (source of incompatibility)
+- "Contradiction c" try to find an hypothesis in context which
+  contradicts the type of c
+- Ring applies to new library NArith (require file NArithRing)
+- Field now works on types in Set
+- Auto with reals now try to replace le by ge (Rge_le is no longer an
+  immediate hint), resulting in shorter proofs
+- Instantiate now works in hyps (syntax : Instantiate in ...)
+- Some new tactics : EConstructor, ELeft, Eright, ESplit, EExists
+- New tactic "functional induction" to perform case analysis and
+  induction following the definition of a function.
+- Clear now fails when trying to remove a local definition used by
+  a constant appearing in the current goal
+
+Extraction (See details in contrib/extraction/CHANGES)
+
+- The old commands: 	(Recursive) Extraction Module M.
+  are now:              (Recursive) Extraction Library M. 
+  To use these commands, M should come from a library M.v 
+- The other syntax Extraction & Recursive Extraction now accept 
+  module names as arguments. 
+
+Bugs
+
+- see coq-bugs server for the complete list of fixed bugs
+
+Miscellaneous
+
+- Implicit parameters of inductive types definition now taken into
+  account for infering other implicit arguments
+
+Incompatibilities
+
+- Persistence of true_sub (4 incompatibilities in Coq user contributions)
+- Variable names of some constants changed for a better uniformity (2 changes
+  in Coq user contributions)
+- Naming of quantified names in goal now avoid global names (2 occurrences)
+- NewInduction naming for inductive types with functional arguments
+  (no incompatibility in Coq user contributions)
+- Contradiction now solve more goals (source of 2 incompatibilities)
+- Merge of eq and eqT may exceptionally result in subgoals now
+  solved automatically
+- Redundant pairs of ZArith lemmas may have different names: it may
+  cause "Apply/Rewrite with" to fail if using the first name of a pair
+  of redundant lemmas (this is solved by renaming the variables bound by
+  "with"; 3 incompatibilities in Coq user contribs)
+- ML programs referring to constants from fast_integer.v must use 
+  "Coqlib.gen_constant_modules Coqlib.zarith_base_modules" instead
+
+Changes from V7.3.1 to V7.4
+===========================
+
+Symbolic notations
+
+- Introduction of a notion of scope gathering notations in a consistent set;
+  a notation sets has been developped for nat, Z and R (undocumented)
+- New command "Notation" for declaring notations simultaneously for
+  parsing and printing (see chap 10 of the reference manual)
+- Declarations with only implicit arguments now handled (e.g. the
+  argument of nil can be set implicit; use !nil to refer to nil
+  without arguments)
+- "Print Scope sc" and "Locate ntn" allows to know to what expression a 
+  notation is bound
+- New defensive strategy for printing or not implicit arguments to ensure
+  re-type-checkability of the printed term
+- In Grammar command, the only predefined non-terminal entries are ident,
+  global, constr and pattern (e.g. nvar, numarg disappears); the only
+  allowed grammar types are constr and pattern; ast and ast list are no
+  longer supported; some incompatibilities in Grammar: when a syntax is a 
+  initial segment of an other one,  Grammar does not work, use Notation
+
+Library
+
+- Lemmas in Set from Compare_dec.v (le_lt_dec, ...) and Wf_nat.v
+  (lt_wf_rec, ...) are now transparent. This may be source of
+  incompatibilities.
+- Syntactic Definitions Fst, Snd, Ex, All, Ex2, AllT, ExT, ExT2,
+  ProjS1, ProjS2, Error, Value and Except are turned to
+  notations. They now must be applied (incompatibilities only in
+  unrealistic cases).
+- More efficient versions of Zmult and times (30% faster)
+- Reals: the library is now divided in 6 parts (Rbase, Rfunctions,
+  SeqSeries, Rtrigo, Ranalysis, Integration). New tactics: Sup and
+  RCompute. See Reals.v for details.
+
+Modules
+
+- Beta version, see doc chap 2.5 for commands and chap 5 for theory
+
+Language
+
+- Inductive definitions now accept ">" in constructor types to declare
+  the corresponding constructor as a coercion.
+- Idem for assumptions declarations and constants when the type is mentionned.
+- The "Coercion" and "Canonical Structure" keywords now accept the
+  same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t".
+- Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u".
+- Remark's and Fact's now definitively behave as Theorem and Lemma: when
+  sections are closed, the full name of a Remark or a Fact has no longer a
+  section part (source of incompatibilities)
+- Opaque Local's (i.e. built by tactics and ended by Qed), do not
+  survive section closing any longer; as a side-effect, Opaque Local's
+  now appear in the local context of proofs; their body is hidden
+  though (source of incompatibilities); use one of Remark/Fact/Lemma/Theorem
+  instead to simulate the old behaviour of Local (the section part of
+  the name is not kept though)
+
+ML tactic and vernacular commands
+
+- "Grammar tactic" and "Grammar vernac" of type "ast" are no longer
+  supported (only "Grammar tactic simple_tactic" of type "tactic"
+  remains available).
+- Concrete syntax for ML written vernacular commands and tactics is
+  now declared at ML level using camlp4 macros TACTIC EXTEND et VERNAC
+  COMMAND EXTEND.
+- "Check n c" now "n:Check c", "Eval n ..." now "n:Eval ..."
+- "Proof with T" (* no documentation *)
+-  SearchAbout id - prints all theorems which contain id in their type
+
+Tactic definitions
+
+- Static globalisation of identifiers and global references (source of
+  incompatibilities, especially, Recursive keyword is required for
+  mutually recursive definitions).
+- New evaluation semantics: no more partial evaluation at definition time;
+  evaluation of all Tactic/Meta Definition, even producing terms, expect
+  a proof context to be evaluated (especially "()" is no longer needed).
+- Debugger now shows the nesting level and the reasons of failure
+
+Tactics
+
+- Equality tactics (Rewrite, Reflexivity, Symmetry, Transitivity) now
+  understand JM equality
+- Simpl and Change now apply to subterms also
+- "Simpl f" reduces subterms whose head constant is f
+- Double Induction now referring to hypotheses like "Intros until"
+- "Inversion" now applies also on quantified hypotheses (naming as
+  for Intros until)
+- NewDestruct now accepts terms with missing hypotheses
+- NewDestruct and NewInduction now accept user-provided elimination scheme
+- NewDestruct and NewInduction now accept user-provided introduction names
+- Omega could solve goals such as ~`x<y` |- `x>=y` but failed when the
+  hypothesis was unfolded to `x < y` -> False. This is fixed. In addition,
+  it can also recognize 'False' in the hypothesis and use it to solve the
+  goal.
+- Coercions now handled in "with" bindings
+- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses 
+   when an hypothesis x=t or x:=t or t=x exists
+- Fresh names for Assert and Pose now based on collision-avoiding
+  Intro naming strategy (exceptional source of incompatibilities)
+- LinearIntuition (* no documentation *)
+- Unfold expects a correct evaluable argument
+- Clear expects existing hypotheses
+
+Extraction (See details in contrib/extraction/CHANGES and README):
+
+- An experimental Scheme extraction is provided.
+- Concerning Ocaml, extracted code is now ensured to always type-check, 
+  thanks to automatic inserting of Obj.magic.
+- Experimental extraction of Coq new modules to Ocaml modules.
+
+Proof rendering in natural language
+
+- Export of theories to XML for publishing and rendering purposes now
+  includes proof-trees (see http://www.cs.unibo.it/helm)
+
+Miscellaneous
+
+- Printing Coercion now used through the standard keywords Set/Add, Test, Print
+- "Print Term id" is an alias for "Print id"
+- New switch "Unset/Set Printing Symbols" to control printing of
+  symbolic notations
+- Two new variants of implicit arguments are available
+   - "Unset/Set Contextual Implicits" tells to consider implicit also the
+     arguments inferable from the context (e.g. for nil or refl_eq)
+   - "Unset/Set Strict Implicits" tells to consider implicit only the
+     arguments that are inferable in any case (i.e. arguments that occurs
+     as argument of rigid constants in the type of the remaining arguments;
+     e.g. the witness of an existential is not strict since it can vanish when
+     applied to a predicate which does not use its argument)
+
+Incompatibilities
+
+- "Grammar tactic ... : ast" and "Grammar vernac ... : ast" are no
+  longer supported, use TACTIC EXTEND and VERNAC COMMAND EXTEND on the
+  ML-side instead
+- Transparency of le_lt_dec and co (leads to some simplification in
+  proofs; in some cases, incompatibilites is solved by declaring locally 
+  opaque the relevant constant)
+- Opaque Local do not now survive section closing (rename them into
+  Remark/Lemma/... to get them still surviving the sections; this
+  renaming allows also to solve incompatibilites related to now
+  forbidden calls to the tactic Clear)
+- Remark and Fact have no longer (very) long names (use Local instead in case
+  of name conflict)
+
+Bugs
+
+- Improved localisation of errors in Syntactic Definitions
+- Induction principle creation failure in presence of let-in fixed (#238)
+- Inversion bugs fixed (#212 and #220)
+- Omega bug related to Set fixed (#180)
+- Type-checking inefficiency of nested destructuring let-in fixed (#216)
+- Improved handling of let-in during holes resolution phase (#239)
+
+Efficiency
+
+- Implementation of a memory sharing strategy reducing memory
+  requirements by an average ratio of 3.
+
+Changes from V7.3 to V7.3.1
+===========================
+
+Bug fixes
+
+  - Corrupted Field tactic and Match Context tactic construction fixed
+  - Checking of names already existing in Assert added (PR#182)
+  - Invalid argument bug in Exact tactic solved (PR#183)
+  - Colliding bound names bug fixed (PR#202)
+  - Wrong non-recursivity test for Record fixed (PR#189)
+  - Out of memory/seg fault bug related to parametric inductive fixed (PR#195)
+  - Setoid_replace/Setoid_rewrite bug wrt "==" fixed
+
+Misc
+
+  - Ocaml version >= 3.06 is needed to compile Coq from sources
+  - Simplification of fresh names creation strategy for Assert, Pose and 
+    LetTac (PR#192)
+
+Changes from V7.2 to V7.3
+=========================
+
+Language
+
+- Slightly improved compilation of pattern-matching (slight source of
+  incompatibilities)
+- Record's now accept anonymous fields "_" which does not build projections
+- Changes in the allowed elimination sorts for certain class of inductive
+  definitions : an inductive definition without constructors
+  of Sort Prop can be eliminated on sorts Set and Type A "singleton"
+  inductive definition (one constructor with arguments in the sort Prop
+  like conjunction of two propositions or equality) can be eliminated
+  directly on sort Type (In V7.2, only the sorts Prop and Set were allowed)
+
+Tactics
+
+- New tactic "Rename x into y" for renaming hypotheses
+- New tactics "Pose x:=u" and "Pose u" to add definitions to local context
+- Pattern now working on partially applied subterms
+- Ring no longer applies irreversible congruence laws of mult but
+  better applies congruence laws of plus (slight source of incompatibilities).
+- Field now accepts terms to be simplified as arguments (as for Ring). This
+  extension has been also implemented using the toplevel tactic language.
+- Intuition does no longer unfold constants except "<->" and "~". It
+  can be parameterized by a tactic. It also can introduce dependent
+  product if needed (source of incompatibilities)
+- "Match Context" now matching more recent hypotheses first and failing only 
+  on user errors and Fail tactic (possible source of incompatibilities)
+- Tactic Definition's without arguments now allowed in Coq states
+- Better simplification and discrimination made by Inversion (source
+  of incompatibilities)
+
+Bugs
+
+- "Intros H" now working like "Intro H" trying first to reduce if not a product
+- Forward dependencies in Cases now taken into account
+- Known bugs related to Inversion and let-in's fixed
+- Bug unexpected Delta with let-in now fixed
+
+Extraction (details in contrib/extraction/CHANGES or documentation)
+
+- Signatures of extracted terms are now mostly expunged from dummy arguments.
+- Haskell extraction is now operational (tested & debugged).  
+
+Standard library
+
+- Some additions in [ZArith]: three files (Zcomplements.v, Zpower.v
+  and Zlogarithms.v) moved from contrib/omega in order to be more
+  visible, one Zsgn function, more induction principles (Wf_Z.v and
+  tail of Zcomplements.v), one more general Euclid theorem
+- Peano_dec.v and Compare_dec.v now part of Arith.v
+
+Tools
+
+- new option -dump-glob to coqtop to dump globalizations (to be used by the 
+  new documentation tool coqdoc; see http://www.lri.fr/~filliatr/coqdoc) 
+
+User Contributions
+
+- CongruenceClosure (congruence closure decision procedure)
+  [Pierre Corbineau, ENS Cachan]
+- MapleMode (an interface to embed Maple simplification procedures over
+  rational fractions in Coq)
+  [David Delahaye, Micaela Mayero, Chalmers University]
+- Presburger: A formalization of Presburger's algorithm 
+  [Laurent Thery, INRIA Sophia Antipolis]
+- Chinese has been rewritten using Z from ZArith as datatype
+  ZChinese is the new version, Chinese the obsolete one
+  [Pierre Letouzey, LRI Orsay]
+
+Incompatibilities
+
+- Ring: exceptional incompatibilities (1 above 650 in submitted user
+  contribs, leading to a simplification)
+- Intuition: does not unfold any definition except "<->" and "~"
+- Cases: removal of some extra Cases in configurations of the form
+  "Cases ... of C _ => ... | _ D => ..."  (effects on 2 definitions of
+  submitted user contributions necessitating the removal of now superfluous
+  proof steps in 3 different proofs)
+- Match Context, in case of incompatibilities because of a now non
+  trapped error (e.g. Not_found or Failure), use instead tactic Fail
+  to force Match Context trying the next clause
+- Inversion: better simplification and discrimination may occasionally
+  lead to less subgoals and/or hypotheses and different naming of hypotheses
+- Unification done by Apply/Elim has been changed and may exceptionally lead
+  to incompatible instantiations
+- Peano_dec.v and Compare_dec.v parts of Arith.v make Auto more
+  powerful if these files were not already required (1 occurrence of
+  this in submitted user contribs)
+
+Changes from V7.1 to V7.2
+=========================
+
+Language
+
+- Automatic insertion of patterns for local definitions in the type of
+  the constructors of an inductive types (for compatibility with V6.3
+  let-in style)
+- Coercions allowed in Cases patterns
+- New declaration "Canonical Structure id = t : I" to help resolution of
+  equations of the form (proj ?)=a; if proj(e)=a then a is canonically 
+  equipped with the remaining fields in e, i.e. ? is instantiated by e
+
+Tactics
+
+- New tactic "ClearBody H" to clear the body of definitions in local context
+- New tactic "Assert H := c" for forward reasoning
+- Slight improvement in naming strategy for NewInduction/NewDestruct
+- Intuition/Tauto do not perform useless unfolding and work up to conversion
+
+Extraction (details in contrib/extraction/CHANGES or documentation)
+
+- Syntax changes: there are no more options inside the extraction commands. 
+  New commands for customization and options have been introduced instead. 
+- More optimizations on extracted code. 
+- Extraction tests are now embedded in 14 user contributions. 
+
+Standard library
+
+- In [Relations], Rstar.v and Newman.v now axiom-free. 
+- In [Sets], Integers.v now based on nat
+- In [Arith], more lemmas in Min.v, new file Max.v, tail-recursive
+  plus and mult added to Plus.v and Mult.v respectively
+- New directory [Sorting] with a proof of heapsort (dragged from 6.3.1 lib)
+- In [Reals], more lemmas in Rbase.v, new lemmas on square, square root and
+  trigonometric functions (R_sqr.v - Rtrigo.v); a complementary approach
+  and new theorems about continuity and derivability in Ranalysis.v;  some
+  properties in plane geometry such as translation, rotation or similarity
+  in Rgeom.v; finite sums and Chasles property in Rsigma.v
+
+Bugs
+
+- Confusion between implicit args of locals and globals of same base name fixed
+- Various incompatibilities wrt inference of "?" in V6.3.1 fixed
+- Implicits in infix section variables bug fixed
+- Known coercions bugs fixed
+
+- Apply "universe anomaly" bug fixed
+- NatRing now working
+- "Discriminate 1", "Injection 1", "Simplify_eq 1" now working
+- NewInduction bugs with let-in and recursively dependent hypotheses fixed
+- Syntax [x:=t:T]u now allowed as mentioned in documentation
+
+- Bug with recursive inductive types involving let-in fixed
+- Known pattern-matching bugs fixed
+- Known Cases elimination predicate bugs fixed
+- Improved errors messages for pattern-matching and projections
+- Better error messages for ill-typed Cases expressions
+
+Incompatibilities
+
+- New naming strategy for NewInduction/NewDestruct may affect 7.1 compatibility
+- Extra parentheses may exceptionally be needed in tactic definitions.
+- Coq extensions written in Ocaml need to be updated (see dev/changements.txt
+  for a description of the main changes in the interface files of V7.2)
+- New behaviour of Intuition/Tauto may exceptionally lead to incompatibilities
+
+----------------------------------------------------------------------------
+Changes from V6.3.1 and V7.0 to V7.1
+====================================
+
+Notes:
+
+- items followed by (**) are important sources of incompatibilities
+- items followed by (*) may exceptionally be sources of incompatibilities
+- items followed by (+) have been introduced in version 7.0
+
+
+Main novelties
+==============
+
+References are to Coq V7.1 reference manual
+
+- New primitive let-in construct (see sections 1.2.8 and )
+- Long names (see sections 2.6 and 2.7)
+- New high-level tactic language (see chapter 10)
+- Improved search facilities (see section 5.2)
+- New extraction algorithm managing the Type level (see chapter 17)
+- New rewriting tactic for arbitrary equalities (see chapter 19)
+- New tactic Field to decide equalities on commutative fields (see 7.11)
+- New tactic Fourier to solve linear inequalities on reals numbers (see 7.11)
+- New tactics for induction/case analysis in "natural" style (see 7.7)
+- Deep restructuration of the code (safer, simpler and more efficient)
+- Export of theories to XML for publishing and rendering purposes
+  (see http://www.cs.unibo.it/helm)
+
+
+Details of changes
+==================
+
+Language: new "let-in" construction
+-----------------------------------
+
+- New construction for local definitions (let-in) with syntax [x:=u]t (*)(+)
+
+- Local definitions allowed in Record (a.k.a. record à la Randy Pollack)
+
+
+Language: long names
+--------------------
+
+- Each construction has a unique absolute names built from a base
+  name, the name of the module in which they are defined (Top if in
+  coqtop), and possibly an arbitrary long sequence of directory (e.g.
+  "Coq.Lists.PolyList.flat_map" where "Coq" means that "flat_map" is part
+  of Coq standard library, "Lists" means it is defined in the Lists
+  library and "PolyList" means it is in the file Polylist) (+)
+
+- Constructions can be referred by their base name, or, in case of
+  conflict, by a "qualified" name, where the base name is prefixed
+  by the module name (and possibly by a directory name, and so
+  on). A fully qualified name is an absolute name which always refer
+  to the construction it denotes (to preserve the visibility of
+  all constructions, no conflict is allowed for an absolute name) (+)
+
+- Long names are available for modules with the possibility of using
+  the directory name as a component of the module full name (with
+  option -R to coqtop and coqc, or command Add LoadPath) (+)
+
+- Improved conflict resolution strategy (the Unix PATH model),
+  allowing more constructions to be referred just by their base name
+
+
+Language: miscellaneous
+-----------------------
+
+- The names of variables for Record projections _and_ for induction principles
+  (e.g. sum_ind) is now based on the first letter of their type (main
+  source of incompatibility) (**)(+)
+
+- Most typing errors have now a precise location in the source (+)
+
+- Slightly different mechanism to solve "?" (*)(+)
+
+- More arguments may be considered implicit at section closing (*)(+)
+
+- Bug with identifiers ended by a number greater than 2^30 fixed (+)
+
+- New visibility discipline for Remark, Fact and Local: Remark's and
+  Fact's now survive at the end of section, but are only accessible using a
+  qualified names as soon as their strength expires; Local's disappear and
+  are moved into local definitions for each construction persistent at
+  section closing
+
+
+Language: Cases
+---------------
+
+- Cases no longer considers aliases inferable from dependencies in types (*)(+)
+
+- A redundant clause in Cases is now an error (*)
+
+
+Reduction
+---------
+
+- New reduction flags "Zeta" and "Evar" in Eval Compute, for inlining of
+  local definitions and instantiation of existential variables
+
+- Delta reduction flag does not perform Zeta and Evar reduction any more (*)
+
+- Constants declared as opaque (using Qed) can no longer become
+  transparent (a constant intended to be alternatively opaque and
+  transparent must be declared as transparent (using Defined)); a risk
+  exists (until next Coq version) that Simpl and Hnf reduces opaque
+  constants (*)
+
+
+New tactics
+-----------
+
+- New set of tactics to deal with types equipped with specific
+  equalities (a.k.a. Setoids, e.g. nat equipped with eq_nat) [by C. Renard]
+
+- New tactic Assert, similar to Cut but expected to be more user-friendly
+
+- New tactic NewDestruct and NewInduction intended to replace Elim
+  and Induction, Case and Destruct in a more user-friendly way (see
+  restrictions in the reference manual)
+
+- New tactic ROmega: an experimental alternative (based on reflexion) to Omega
+  [by P. Crégut]
+
+- New tactic language Ltac (see reference manual) (+)
+
+- New versions of Tauto and Intuition, fully rewritten in the new Ltac
+  language; they run faster and produce more compact proofs; Tauto is
+  fully compatible but, in exchange of a better uniformity, Intuition
+  is slightly weaker (then use Tauto instead) (**)(+)
+
+- New tactic Field to decide equalities on commutative fields (as a
+  special case, it works on real numbers) (+)
+
+- New tactic Fourier to solve linear inequalities on reals numbers
+  [by L. Pottier] (+)
+
+- New tactics dedicated to real numbers: DiscrR, SplitRmult, SplitAbsolu (+)
+
+
+Changes in existing tactics
+---------------------------
+
+- Reduction tactics in local definitions apply only to the body
+
+- New syntax of the form "Compute in Type of H." to require a reduction on
+  the types of local definitions
+
+- Inversion, Injection, Discriminate, ... apply also on the
+  quantified premises of a goal (using the "Intros until" syntax)
+
+- Decompose has been fixed but hypotheses may get different names (*)(+)
+
+- Tauto now manages uniformly hypotheses and conclusions of the form
+  "t=t" which all are considered equivalent to "True". Especially,
+  Tauto now solves goals of the form "H : ~ t = t |- A".
+
+- The "Let" tactic has been renamed "LetTac" and is now based on the
+  primitive "let-in" (+)
+
+- Elim can no longer be used with an elimination schema different from
+  the one defined at definition time of the inductive type. To overload
+  an elimination schema, use "Elim <hyp> using <name of the new schema>"
+  (*)(+)
+
+- Simpl no longer unfolds the recursive calls of a mutually defined 
+  fixpoint (*)(+)
+
+- Intro now fails if the hypothesis name already exists (*)(+)
+
+- "Require Prolog" is no longer needed (i.e. it is available by default) (*)(+)
+
+- Unfold now fails on a non unfoldable identifier (*)(+)
+
+- Unfold also applies on definitions of the local context
+
+- AutoRewrite now deals only with the main goal and it is the purpose of
+  Hint Rewrite to deal with generated subgoals (+)
+
+- Redundant or incompatible instantiations in Apply ... with ... are now
+  correctly managed (+)
+
+
+Efficiency
+----------
+
+- Excessive memory uses specific to V7.0 fixed
+
+- Sizes of .vo files vary a lot compared to V6.3 (from -30% to +300%
+  depending on the developments)
+
+- An improved reduction strategy for lazy evaluation
+
+- A more economical mechanism to ensure logical consistency at the Type level;
+  warning: this is experimental and may produce "universes" anomalies
+  (please report)
+
+
+Concrete syntax of constructions
+--------------------------------
+
+- Only identifiers starting with "_" or a letter, and followed by letters,
+  digits, "_" or "'" are allowed (e.g. "$" and "@" are no longer allowed) (*)
+
+- A multiple binder like (a:A)(a,b:(P a))(Q a) is no longer parsed as
+  (a:A)(a0:(P a))(b:(P a))(Q a0) but as (a:A)(a0:(P a))(b:(P a0))(Q a0) (*)(+)
+
+- A dedicated syntax has been introduced for Reals (e.g ``3+1/x``) (+)
+
+- Pretty-printing of Infix notations fixed. (+)
+
+
+Parsing and grammar extension
+-----------------------------
+
+- More constraints when writing ast 
+
+  - "{...}" and the macros $LIST, $VAR, etc. now expect a metavariable
+    (an identifier starting with $) (*)
+  - identifiers should starts with a letter or "_" and be followed
+     by letters, digits, "_" or "'" (other characters are still
+     supported but it is not advised to use them) (*)(+)
+
+- Entry "command" in "Grammar" and quotations (<<...>> stuff) is
+  renamed "constr" as in "Syntax" (+)
+
+- New syntax "[" sentence_1 ... sentence_n"]." to group sentences (useful
+  for Time and to write grammar rules abbreviating several commands) (+)
+
+- The default parser for actions in the grammar rules (and for
+  patterns in the pretty-printing rules) is now the one associated to
+  the grammar (i.e. vernac, tactic or constr); no need then for
+  quotations as in <:vernac:<...>>; to return an "ast", the grammar
+  must be explicitly typed with tag ": ast" or ": ast list", or if a
+  syntax rule, by using <<...>> in the patterns (expression inside
+  these angle brackets are parsed as "ast"); for grammars other than
+  vernac, tactic or constr, you may explicitly type the action with
+  tags ": constr", ": tactic", or ":vernac" (**)(+)
+
+- Interpretation of names in Grammar rule is now based on long names,
+  which allows to avoid problems (or sometimes tricks;) related to
+  overloaded names (+)
+
+
+New commands
+------------
+
+- New commands "Print XML All", "Show XML Proof", ... to show or
+  export theories to XML to be used with Helm's publishing and rendering
+  tools (see http://www.cs.unibo.it/helm) (by Claudio Sacerdoti Coen) (+)
+
+- New commands to manually set implicit arguments (+)
+
+  - "Implicits ident." to activate the implicit arguments mode just for ident
+  - "Implicits ident [num1 num2 ...]." to explicitly give which
+     arguments have to be considered as implicit
+
+- New SearchPattern/SearchRewrite (by Yves Bertot) (+)
+
+- New commands "Debug on"/"Debug off" to activate/deactivate the tactic
+  language debugger (+)
+
+- New commands to map physical paths to logical paths (+)
+  - Add LoadPath physical_dir as logical_dir
+  - Add Rec LoadPath physical_dir as logical_dir
+
+
+Changes in existing commands
+----------------------------
+
+- Generalization of the usage of qualified identifiers in tactics
+  and commands about globals, e.g. Decompose, Eval Delta; 
+  Hints Unfold, Transparent, Require
+
+- Require synchronous with Reset; Require's scope stops at Section ending (*)
+
+- For a module indirectly loaded by a "Require" but not exported,
+  the command "Import module" turns the constructions defined in the
+  module accessible by their short name, and activates the Grammar,
+  Syntax, Hint, ... declared in the module (+)
+
+- The scope of the "Search" command can be restricted to some modules (+)
+
+- Final dot in command (full stop/period) must be followed by a blank
+  (newline, tabulation or whitespace) (+)
+
+- Slight restriction of the syntax for Cbv Delta: if present, option [-myconst]
+  must immediately follow the Delta keyword (*)(+)
+
+- SearchIsos currently not supported
+
+- Add ML Path is now implied by Add LoadPath (+)
+
+- New names for the following commands (+)
+
+  AddPath -> Add LoadPath
+  Print LoadPath -> Print LoadPath
+  DelPath -> Remove LoadPath
+  AddRecPath -> Add Rec LoadPath
+  Print Path -> Print Coercion Paths
+
+  Implicit Arguments On -> Set Implicit Arguments
+  Implicit Arguments Off -> Unset Implicit Arguments
+
+  Begin Silent -> Set Silent
+  End Silent -> Unset Silent.
+
+
+Tools
+-----
+
+- coqtop (+)
+
+  - Two executables: coqtop.byte and coqtop.opt (if supported by the platform)
+  - coqtop is a link to the more efficient executable (coqtop.opt if present)
+  - option -full is obsolete (+)
+
+- do_Makefile renamed into coq_makefile (+)
+
+- New option -R to coqtop and coqc to map a physical directory to a logical
+  one (+)
+
+- coqc no longer needs to create a temporary file
+
+- No more warning if no initialization file .coqrc exists
+
+
+Extraction
+----------
+
+- New algorithm for extraction able to deal with "Type" (+)
+  (by J.-C. Filliâtre and P. Letouzey)
+
+
+Standard library
+----------------
+
+- New library on maps on integers (IntMap, contributed by Jean Goubault)
+
+- New lemmas about integer numbers [ZArith]
+
+- New lemmas and a "natural" syntax for reals [Reals] (+)
+
+- Exc/Error/Value renamed into Option/Some/None (*)
+
+
+New user contributions
+----------------------
+
+- Constructive complex analysis and the Fundamental Theorem of Algebra [FTA]
+  (Herman Geuvers, Freek Wiedijk, Jan Zwanenburg, Randy Pollack,
+   Henk Barendregt, Nijmegen)
+
+- A new axiomatization of ZFC set theory [Functions_in_ZFC]
+  (C. Simpson, Sophia-Antipolis)
+
+- Basic notions of graph theory [GRAPHS-BASICS] (Jean Duprat, Lyon)
+
+- A library for floating-point numbers [Float] (Laurent Théry, Sylvie Boldo,
+  Sophia-Antipolis)
+
+- Formalisation of CTL and TCTL temporal logic [CtlTctl] (Carlos
+  Daniel Luna,Montevideo)
+
+- Specification and verification of the Railroad Crossing Problem
+  in CTL and TCTL [RailroadCrossing] (Carlos Daniel Luna,Montevideo)
+
+- P-automaton and the ABR algorithm [PAutomata]
+  (Christine Paulin, Emmanuel Freund, Orsay)
+
+- Semantics of a subset of the C language [MiniC] 
+  (Eduardo Giménez, Emmanuel Ledinot, Suresnes) 
+
+- Correctness proofs of the following imperative algorithms:
+  Bresenham line drawing algorithm [Bresenham], Marché's minimal edition
+  distance algorithm [Diff] (Jean-Christophe Filliâtre, Orsay)
+
+- Correctness proofs of Buchberger's algorithm [Buchberger] and RSA
+  cryptographic algorithm [Rsa] (Laurent Théry, Sophia-Antipolis)
+
+- Correctness proof of Stalmarck tautology checker algorithm
+  [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis)
diff --git a/COPYRIGHT b/COPYRIGHT
new file mode 100644
index 00000000..ac7d87df
--- /dev/null
+++ b/COPYRIGHT
@@ -0,0 +1,34 @@
+The Coq proof assistant V7 and V8 includes software developed by the 
+Coq development team inside the LogiCal project, at INRIA, CNRS and
+University Paris Sud. 
+
+Copyright 1999-2004 The Coq development team, 
+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 Courtieu, Lemme (contrib/funind)
+	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
+first-order intuitionistic logic.  Jprover was originally implemented
+by Stephan Schmitt and then integrated into MetaPRL by Aleksey
+Nogin. After this, Huang extracted the necessary ML-codes from MetaPRL
+and then integrated it into Coq.
+	
+The file CREDITS contains a list of past contributors
+The credits section in Reference Manual introduction details
+contributions.
+
+The Coq development Team (march 2004)
+	Bruno Barras (INRIA)
+	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)
\ No newline at end of file
diff --git a/CREDITS b/CREDITS
new file mode 100644
index 00000000..12cd8e65
--- /dev/null
+++ b/CREDITS
@@ -0,0 +1,115 @@
+
+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.
+
+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
+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
+
+
+The following directories contain independent contributions supported 
+by the Coq development team :
+contrib/cc
+	developed by Pierre Corbineau (ENS Cachan, 2001)
+contrib/correctness
+	developed by Jean-Christophe Filliâtre (LRI, 1999-2001)
+contrib/extraction
+	developed by Pierre Letouzey (LRI, 2000-2004)
+contrib/field
+	developed by David Delahaye and Micaela Mayero (INRIA-LogiCal, 2001)
+contrib/first-order 
+	developed by Pierre Corbineau (LRI, 2003-2004)
+contrib/fourier
+	developed by Loïc Pottier (INRIA-Lemme, 2001)
+contrib/funind
+	developed by Pierre Courtieu (INRIA-Lemme, 2003-2004)
+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"
+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)
+contrib/ring
+	developed by Samuel Boutin (INRIA-Coq, 1996) and Patrick 
+	Loiseleur (LRI, 1997-1999)
+contrib/xml
+	developed by Claudio Sacerdoti (Univ. Bologna, 2000-2004) 
+	as part of the HELM and MoWGLI project
+
+parsing/search.ml
+	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"
+
+Many discussions within the Démons team 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
+
+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)
+
+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)
+
+
+***************************************************************************
+INRIA refers to :
+	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
+ENS Lyon refers to :
+	Ecole Normale Supérieure de Lyon
+****************************************************************************
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 00000000..ccfc65e0
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,248 @@
+
+            INSTALLATION PROCEDURES FOR THE COQ V8.0 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:
+
+     - Objective Caml version 3.06 or later
+       (available at http://caml.inria.fr/)
+  
+   Until now, it has mainly been tested on Sun workstations running Solaris,
+   and DEC alpha and Pentium workstations running Linux. By FTP, Coq
+   comes as a single compressed tar-file. You have probably already
+   decompressed it if you are reading this document.
+
+
+QUICK INSTALLATION PROCEDURE.
+=============================
+
+1. ./configure
+2. make world
+3. make install (you may need superuser rights)
+4. make clean
+
+
+INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
+=================================================
+
+1- Check that you have the Objective Caml compiler version 3.06 (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. 
+
+   To get Coq in native-code, (it runs 4 to 10 times faster than
+   bytecode, but it takes more time to get compiled and the binary is
+   bigger), you will also need the "ocamlopt" (or its native code version
+   "ocamlopt.opt") command.
+
+2- Check that you have Camlp4 installed on your 
+   computer and that the command "camlp4" lies in a directory which
+   is present in your $PATH environment variable path.
+   (You need Camlp4 in both bytecode and native versions if
+   your platform supports it).
+
+   Note: in the latest ocaml distributions, camlp4 comes with ocaml so
+   you do not have to check this point anymore.
+
+3- The uncompression and un-tarring of the distribution file gave birth 
+   to a directory named "coq-8.xx". You can rename this directory and put 
+   it wherever you want. Just keep in mind that you will need some spare
+   space during the compilation (reckon on about 50 Mb of disk space
+   for the whole system in native-code compilation). Once installed, the
+   binaries take about 14 Mb, and the library about 9 Mb.
+
+4- First you need to configure the system. It is done automatically with
+   the command:
+
+	./configure <options>
+
+   The "configure" script will ask you for directories where to put
+   the Coq binaries, standard library, man pages, etc. It will propose
+   you some default values.
+
+   The "configure" script accepts the following options:
+
+-prefix <dir>
+	Binaries, library, man pages and Emacs mode will be respectively
+	installed in <dir>/bin, <dir>/lib/coq, <dir>/man and
+	<dir>/lib/emacs/site-lisp
+
+-bindir <dir>                   (default: /usr/local/bin)
+        Directory where the binaries will be installed
+
+-libdir <dir>                   (default: /usr/local/lib/coq)
+        Directory where the Coq standard library will be installed
+
+-mandir <dir>                   (default: /usr/local/man)
+        Directory where the Coq manual pages will be installed
+
+-emacslib <dir>			(default: /usr/local/lib/emacs/site-lisp)
+	Directory where the Coq Emacs mode will be installed
+
+-arch <value>			(default is the result of the command "arch")
+	An arbitrary architecture name for your machine (useful when
+	compiling Coq on two different architectures for which the
+	result of "arch" is the same, e.g. Sun OS and Solaris)
+
+-local
+        Compile Coq to run in its source directory. The installation (step 6)
+        is not necessary in that case.
+
+-opt
+        Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt 
+        compiler instead of ocamlopt). Makes compilation faster (recommended).
+
+-nowarnings
+	Disable the Objective Caml compiler warnings. This option has no
+	effect on the result of the compilation.
+
+5- Still in the root directory, do
+
+	make world
+
+   to compile Coq in Objective Caml bytecode (and native-code if supported).
+
+   This will compile the entire system. This phase can take more or less time,
+   depending on your architecture and is fairly verbose. 
+
+6- You can now install the Coq system. Executables, libraries, manual pages
+   and emacs mode are copied in some standard places of your system, defined at
+   configuration time (step 3). Just do
+
+	umask 022
+       	make install
+
+   Of course, you may need superuser rights to do that.
+   To use the Coq emacs mode you also need to put the following lines
+   in you .emacs file:
+
+        (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
+        (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+
+7- You can now clean all the sources. (You can even erase them.)
+
+	make clean
+
+
+INSTALLATION PROCEDURE FOR ADVANCED USERS.
+==========================================
+
+   If you wish to write tactics (and that really means that you belong
+   to advanced users !) you *must* keep the Coq sources, without cleaning
+   them. Therefore, to avoid a duplication of binaries and library, it is
+   not necessary to do the installation step (6- above).
+   You just have to tell it at configuration step (4- above) with the
+   option -local :
+
+	./configure -local <other options>
+
+   Then compile the sources as described in step 5 above. The resulting
+   binaries will reside in the subdirectory bin/.
+
+   If you want to compile the sources for debugging (i.e. with the option
+   -g of the Caml compiler) then add the -debug option at configuration
+   step :
+
+	./configure -debug <other options>
+
+   and then compile the sources (step 5). Then you must make a Coq toplevel
+   including your own tactics, which must be compiled with -g, with coqmktop.
+   See the chapter 16 of the Coq Reference Manual for details about how
+   to use coqmktop and the Objective Caml debugger with Coq.
+
+
+THE AVAILABLE COMMANDS.
+=======================
+
+   There are two Coq commands:
+	
+	coqtop		The Coq toplevel
+	coqc		The Coq compiler
+
+   There are actually two binaries for the interactive system, coqtop.byte
+   and coqtop.opt (respectively bytecode and native code versions of Coq). 
+   coqtop is a link to the fastest version, i.e. coqtop.opt if any, and
+   coqtop.byte otherwise. coqc also invokes the fastest version of Coq.
+   Options -opt and -byte to coqtop and coqc selects a particular binary.
+
+    * `coqtop' launches Coq in the interactive mode. The default state
+      (see the "-inputstate" option) is `initial.coq', which contains some 
+      basic logical definitions, the associated parsing and printing rules,
+      and the following tactic modules: Equality, Tauto, Inv, EAuto and Refine.
+
+    * `coqc' allows compilation of Coq files directly from the command line.
+      To compile a file foo.v, do:
+
+		coqc foo.v
+
+      It will produce a file foo.vo, that you can now load through the Coq 
+      command "Require". 
+
+   A detailed description of these commands and of their options is given
+   in the Reference Manual (which you can get by FTP, in the doc/ directory) 
+   and in the corresponding manual pages.
+
+
+COMMON PROBLEMS.
+================
+
+    * On some sites, when running `./configure', `pwd' returned a 
+    path which is not valid from another machine (it may look like 
+    "/tmp_mnt/foo/...") and, as a consequence, you won't be able to run
+    coqtop or coqc. The solution is to give the correct value, with
+
+	./configure -src <correct path> <other options>
+
+    * The `make install' procedure uses mkdirhier, a program that may
+   not be present on certain systems. To fix that, try to replace
+   mkdirhier with mkdir -p
+
+COMPILING FOR DIFFERENT ARCHITECTURES.
+======================================
+
+   This section explains how to compile Coq for several architecture,
+   sharing the same sources. The important fact is that some files are 
+   architecture dependent (.cmx, .o and executable  files for instance)
+   but others are not (.cmo and .vo). Consequently, you can :
+
+   o  save some time during compilation by not cleaning the architecture
+      independent files;
+
+   o  save some space during installation by sharing the Coq standard
+      library (which is fully architecture independent).
+
+   So, in order to compile Coq for a new architecture, proceed as follows:
+
+   * Omit step 7 above and clean only the architecture dependent files:
+     it is done automatically with the command
+
+		make archclean
+
+   * Configure the system for the new architecture:
+
+		./configure <options>
+
+     You can specify the same directory for the standard library but you
+     MUST specify a different directory for the binaries (of course).
+
+   * Compile and install the system as described in steps 5 and 6 above.
+
+
+MOVING BINARIES OR LIBRARY.
+===========================
+
+   If you move the binaries or the library, Coq will be "lost".
+   Running "coqtop" would then return an error message of the kind:
+
+	Error during initialization :
+	Error: Can't find file initial.coq on loadpath
+
+   If you really have (or want) to move the binaries or the library, then
+   you have to indicate their new places to Coq, using the options -bindir (for
+   the binaries directory) and -libdir (for the standard library directory) :
+
+	coqtop -bindir <new directory> -libdir <new directory>
diff --git a/INSTALL.ide b/INSTALL.ide
new file mode 100644
index 00000000..d8f1208b
--- /dev/null
+++ b/INSTALL.ide
@@ -0,0 +1,88 @@
+			CoqIde Installation procedure.
+
+CoqIde is a graphical interface to perform interactive proofs.
+You should be able to do everything you do in coqtop inside CoqIde 
+excepted dropping to the ml toplevel.
+
+DISCLAIMER: CoqIde is ongoing work. Eventhough it should never let you
+	    loose a proof, you may encounter unexpected bugs.
+ 	    Do not hesitate to send suggestions/bug reports.
+
+REQUIREMENT:
+	- OCaml >= 3.06 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.
+	  You may still compile CoqIde with older 2.0.x versions and 
+          use all features.
+	  Run 
+		"pkg-config --modversion gtk+-2.0"
+	  to check your version.
+	 All recent distributions have precompiled packages.
+	 Do not forget to install the developement headers packages.
+	 As for Debian/woody, 
+		apt-get install libgtk2.0-dev 
+	 should be enough.
+
+INSTALLATION
+ 0) For optimal performance, OCaml must support native threads (aka pthreads). 
+    If this not the case, this means that Coq computations will be slow and 
+    "make ide" will fail. Use "make bin/coqide.byte" instead. To fix this 
+    problem, just recompile OCaml from source and configure OCaml with : 
+	"./configure --with-pthreads". 
+    In case you install over an existing copy of OCaml, you should better 
+    empty the OCaml installation directory.
+
+ 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 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.
+    If you are in a hurry just run :
+    
+cd /tmp && \
+wget \
+ http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/dist/lablgtk-2.2.0.tar.gz && \
+tar zxvf lablgtk-2.2.0.tar.gz && \
+cd lablgtk-2.2.0 && \
+./configure && \
+make world && \
+make install
+
+   You must have write access to the OCaml standard library path.
+   If this fails read lablgtk-2.2.0/README.
+
+2) Go into your Coq source directory and, as usual, configure with:
+
+	./configure
+
+   This should detect the ability of making CoqIde.
+   Then compile with
+
+	make world
+
+   and install with
+
+	make install
+
+   In case you are upgrading from an old version you may need to run
+	make clean-ide
+
+3) You may now run bin/coqide
+
+
+NOTES
+There are three configuration files located in your $(HOME) dir. 
+ You may need to set HOME to some sensible value under Windows.
+
+- .coqiderc is generated by coqide itself. It may be edited by hand or 
+  by using the Preference menu from coqide. It will be generated the first time
+  you save your the preferences in Coqide.
+
+- .coqide-gtk2rc is a standard Gtk2 configuration file. A sample file can be
+  found in the coq lib "ide" subdir.
+
+- .coqide.keys is a standard Gtk2 accelerator dump. You may edit this file 
+  to change the default shortcuts for the menus.
+
+Read ide/FAQ for more informations.
diff --git a/INSTALL.macosx b/INSTALL.macosx
new file mode 100644
index 00000000..b756bdb7
--- /dev/null
+++ b/INSTALL.macosx
@@ -0,0 +1,16 @@
+INSTALLATION PROCEDURE FOR THE COQ V8.0 SYSTEM UNDER MACOS X
+------------------------------------------------------------
+
+1) Download archive coq-8.0-macosx.dmg.
+
+2) Double-click on its icon; it mounts a disk volume named "Coq V8.0".
+
+3) Open volume "Coq 8.0" and double-click on coq-8.0.pkg to launch the
+   installer (you'll need administrator permissions).
+
+4) Coq installs in /usr/local/bin, which should be in your PATH, and
+   can be used from a Terminal window: the interactive toplevel is
+   named coqtop and the compiler is coqc.
+
+If you have any trouble with this installation, please contact:
+coq-bugs@pauillac.inria.fr.
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/LICENSE b/LICENSE
new file mode 100644
index 00000000..b1e3f5a2
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,504 @@
+		  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
+
+           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
new file mode 100644
index 00000000..af8a8c07
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,1605 @@
+########################################################################
+#  v      #   The Coq Proof Assistant  /  The Coq Development Team     #
+# <O___,, # CNRS-Ecole 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: Makefile,v 1.459.2.10 2004/07/19 09:37:31 herbelin Exp $ 
+
+
+# Makefile for Coq
+#
+# To be used with GNU Make.
+#
+# This is the only Makefile. You won't find Makefiles in sub-directories
+# and this is done on purpose. If you are not yet convinced of the advantages
+# of a single Makefile, please read
+#    http://www.pcug.org.au/~millerp/rmch/recu-make-cons-harm.html
+# before complaining.
+# 
+# When you are working in a subdir, you can compile without moving to the
+# upper directory using "make -C ..", and the output is still understood
+# by Emacs' next-error.
+###########################################################################
+
+include config/Makefile
+
+noargument:
+	@echo "Please use either"
+	@echo "   ./configure"
+	@echo "   make world"
+	@echo "   make install"
+	@echo "   make clean"
+	@echo "or make archclean"
+	@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
+
+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
+
+###########################################################################
+# Compilation options
+###########################################################################
+
+# The SHOW and HIDE variables control whether make will echo complete commands 
+# or only abbreviated versions. 
+# Quiet mode is ON by default except if VERBOSE=1 option is given to make
+
+ifeq ($(VERBOSE),1)
+ SHOW = @true ""
+ HIDE = 
+else 
+ SHOW = @echo ""
+ HIDE = @
+endif
+
+LOCALINCLUDES=-I config -I tools -I tools/coqdoc \
+	      -I scripts -I lib -I kernel -I library \
+              -I proofs -I tactics -I pretyping \
+              -I interp -I toplevel -I parsing -I ide/utils \
+	      -I ide -I translate \
+              -I contrib/omega -I contrib/romega \
+	      -I contrib/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
+
+MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
+
+BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG)
+OPTFLAGS=$(MLINCLUDES) $(CAMLTIMEPROF)
+OCAMLDEP=ocamldep
+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'
+
+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
+
+BOOTCOQTOP=$(BESTCOQTOP) -boot $(COQOPTS)
+
+###########################################################################
+# Objects files 
+###########################################################################
+
+CLIBS=unix.cma
+
+CAMLP4OBJS=gramlib.cma
+
+CONFIG=\
+  config/coq_config.cmo
+
+LIBREP=\
+  lib/pp_control.cmo lib/pp.cmo lib/compat.cmo lib/util.cmo lib/bignat.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 
+
+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/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \
+  kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo
+
+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 
+
+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/tacred.cmo \
+  pretyping/pretype_errors.cmo pretyping/typing.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
+
+INTERP=\
+  parsing/lexer.cmo interp/topconstr.cmo interp/ppextend.cmo interp/symbols.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
+
+PROOFS=\
+  proofs/tacexpr.cmo proofs/proof_type.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
+
+TACTICS=\
+  tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \
+  tactics/nbtermdn.cmo tactics/tacticals.cmo \
+  tactics/hipattern.cmo tactics/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 \
+
+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/vernacinterp.cmo toplevel/mltop.cmo \
+  toplevel/vernacentries.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
+
+SPECTAC= tactics/tauto.ml4 tactics/eqdecide.ml4
+USERTAC = $(SPECTAC)
+ML4FILES += $(USERTAC) tactics/extraargs.ml4 tactics/extratactics.ml4 \
+	tactics/eauto.ml4 
+
+USERTACCMO=$(USERTAC:.ml4=.cmo)
+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/field/field.ml4 contrib/fourier/g_fourier.ml4 \
+  contrib/extraction/g_extraction.ml4 contrib/xml/xmlentries.ml4
+
+OMEGACMO=\
+  contrib/omega/omega.cmo contrib/omega/coq_omega.cmo \
+  contrib/omega/g_omega.cmo 
+
+ROMEGACMO=\
+  contrib/romega/omega2.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 
+
+FIELDCMO=\
+  contrib/field/field.cmo 
+
+XMLCMO=\
+  contrib/xml/unshare.cmo contrib/xml/xml.cmo contrib/xml/acic.cmo \
+  contrib/xml/doubleTypeInference.cmo \
+  contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
+  contrib/xml/proof2aproof.cmo \
+  contrib/xml/xmlcommand.cmo contrib/xml/proofTree2Xml.cmo \
+	contrib/xml/xmlentries.cmo 	
+
+FOURIERCMO=\
+  contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo \
+  contrib/fourier/g_fourier.cmo
+
+EXTRACTIONCMO=\
+  contrib/extraction/table.cmo\
+  contrib/extraction/mlutil.cmo\
+  contrib/extraction/modutil.cmo \
+  contrib/extraction/ocaml.cmo \
+  contrib/extraction/haskell.cmo \
+  contrib/extraction/scheme.cmo \
+  contrib/extraction/extraction.cmo \
+  contrib/extraction/common.cmo \
+  contrib/extraction/extract_env.cmo \
+  contrib/extraction/g_extraction.cmo
+
+JPROVERCMO=\
+  contrib/jprover/opname.cmo \
+  contrib/jprover/jterm.cmo contrib/jprover/jlogic.cmo \
+  contrib/jprover/jtunify.cmo contrib/jprover/jall.cmo \
+  contrib/jprover/jprover.cmo
+
+FUNINDCMO=\
+  contrib/funind/tacinvutils.cmo contrib/funind/tacinv.cmo 
+
+FOCMO=\
+  contrib/first-order/formula.cmo contrib/first-order/unify.cmo \
+  contrib/first-order/sequent.cmo contrib/first-order/rules.cmo \
+  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  
+
+ML4FILES += contrib/jprover/jprover.ml4 contrib/cc/cctac.ml4 \
+  contrib/funind/tacinv.ml4 contrib/first-order/g_ground.ml4
+
+CONTRIB=$(OMEGACMO) $(ROMEGACMO) $(RINGCMO) $(FIELDCMO) \
+	$(FOURIERCMO) $(EXTRACTIONCMO) $(JPROVERCMO) $(XMLCMO) \
+	$(CCCMO) $(FUNINDCMO) $(FOCMO)
+
+CMA=$(CLIBS) $(CAMLP4OBJS)
+CMXA=$(CMA:.cma=.cmxa)
+
+# Beware that highparsingnew.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)
+
+###########################################################################
+# Main targets (coqmktop, coqtop.opt, coqtop.byte)
+###########################################################################
+
+COQMKTOP=bin/coqmktop$(EXE) 
+COQC=bin/coqc$(EXE)
+COQTOPBYTE=bin/coqtop.byte$(EXE)
+COQTOPOPT=bin/coqtop.opt$(EXE)
+BESTCOQTOP=bin/coqtop.$(BEST)$(EXE)
+COQTOP=bin/coqtop$(EXE)
+
+COQBINARIES= $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(BESTCOQTOP) $(COQTOP)
+
+coqbinaries:: ${COQBINARIES}
+
+coq: coqlib tools coqbinaries coqlib7
+coq8: coqlib tools coqbinaries
+coq7: coqlib7 tools coqbinaries
+
+coqlib:: newtheories newcontrib
+
+coqlib7: theories7 contrib7
+
+coqlight: theories-light tools coqbinaries
+
+states7:: states7/initial.coq
+
+states:: states/initial.coq
+
+$(COQTOPOPT): $(COQMKTOP) $(CMX) $(USERTACCMX)
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@
+	$(STRIP) $@
+
+$(COQTOPBYTE): $(COQMKTOP) $(CMO) $(USERTACCMO)
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -top $(LOCALINCLUDES) $(CAMLDEBUG) -o $@
+
+$(COQTOP):
+	cd bin; ln -sf coqtop.$(BEST)$(EXE) coqtop$(EXE)
+
+# coqmktop 
+
+COQMKTOPCMO=$(CONFIG) scripts/tolink.cmo scripts/coqmktop.cmo 
+
+$(COQMKTOP): $(COQMKTOPCMO)
+	$(SHOW)'OCAMLC -o $@'	
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom str.cma unix.cma \
+          $(COQMKTOPCMO) $(OSDEPLIBS)
+
+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 ide = \""$(COQIDECMO)"\"" >> $@
+
+beforedepend:: scripts/tolink.ml
+
+# coqc
+
+COQCCMO=$(CONFIG) toplevel/usage.cmo scripts/coqc.cmo
+
+$(COQC): $(COQCCMO) $(COQTOPBYTE) $(BESTCOQTOP)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom unix.cma $(COQCCMO) $(OSDEPLIBS)
+
+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)
+library: $(LIBRARY)
+proofs: $(PROOFS)
+tactics: $(TACTICS)
+interp: $(INTERP)
+parsing: $(PARSING)
+pretyping: $(PRETYPING)
+highparsing: $(HIGHPARSING)
+highparsingnew: $(HIGHPARSINGNEW)
+toplevel: $(TOPLEVEL)
+hightactics: $(HIGHTACTICS)
+
+# target for libraries
+
+lib/lib.cma: $(LIBREP)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(LIBREP)
+
+lib/lib.cmxa: $(LIBREP:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(LIBREP:.cmo=.cmx)
+
+kernel/kernel.cma: $(KERNEL)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(KERNEL)
+
+kernel/kernel.cmxa: $(KERNEL:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(KERNEL:.cmo=.cmx)
+
+library/library.cma: $(LIBRARY)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(LIBRARY)
+
+library/library.cmxa: $(LIBRARY:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(LIBRARY:.cmo=.cmx)
+
+pretyping/pretyping.cma: $(PRETYPING)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PRETYPING)
+
+pretyping/pretyping.cmxa: $(PRETYPING:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PRETYPING:.cmo=.cmx)
+
+interp/interp.cma: $(INTERP)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(INTERP)
+
+interp/interp.cmxa: $(INTERP:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(INTERP:.cmo=.cmx)
+
+parsing/parsing.cma: $(PARSING)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PARSING)
+
+parsing/parsing.cmxa: $(PARSING:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PARSING:.cmo=.cmx)
+
+proofs/proofs.cma: $(PROOFS)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(PROOFS)
+
+proofs/proofs.cmxa: $(PROOFS:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(PROOFS:.cmo=.cmx)
+
+tactics/tactics.cma: $(TACTICS)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(TACTICS)
+
+tactics/tactics.cmxa: $(TACTICS:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(TACTICS:.cmo=.cmx)
+
+toplevel/toplevel.cma: $(TOPLEVEL)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(TOPLEVEL)
+
+toplevel/toplevel.cmxa: $(TOPLEVEL:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(TOPLEVEL:.cmo=.cmx)
+
+parsing/highparsing.cma: $(HIGHPARSING)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(HIGHPARSING)
+
+parsing/highparsing.cmxa: $(HIGHPARSING:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(HIGHPARSING:.cmo=.cmx)
+
+tactics/hightactics.cma: $(HIGHTACTICS) $(USERTACCMO)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(HIGHTACTICS) $(USERTACCMO)
+
+tactics/hightactics.cmxa: $(HIGHTACTICS:.cmo=.cmx) $(USERTACCMO:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(HIGHTACTICS:.cmo=.cmx) \
+		$(USERTACCMO:.cmo=.cmx)
+
+contrib/contrib.cma: $(CONTRIB)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(CONTRIB)
+
+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
+###########################################################################
+
+# target to build CoqIde
+coqide:: coqide-files coqide-binaries states
+
+COQIDEBYTE=bin/coqide.byte$(EXE)
+COQIDEOPT=bin/coqide.opt$(EXE)
+COQIDE=bin/coqide$(EXE)
+
+COQIDECMO=ide/utils/okey.cmo ide/utils/uoptions.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 \
+	  ide/utils/editable_cells.cmo ide/config_parser.cmo \
+	  ide/config_lexer.cmo ide/utf8_convert.cmo ide/preferences.cmo \
+	  ide/ideutils.cmo ide/blaster_window.cmo ide/undo.cmo \
+	  ide/find_phrase.cmo \
+          ide/highlight.cmo ide/coq.cmo ide/coq_commands.cmo \
+	  ide/coq_tactics.cmo  ide/command_windows.cmo ide/coqide.cmo
+
+COQIDECMX=$(COQIDECMO:.cmo=.cmx)
+COQIDEFLAGS=-thread -I +lablgtk2
+beforedepend:: ide/config_lexer.ml ide/find_phrase.ml ide/highlight.ml
+beforedepend:: ide/config_parser.mli ide/config_parser.ml
+beforedepend:: ide/utf8_convert.ml
+
+COQIDEVO=ide/utf8.vo
+
+$(COQIDEVO): states/initial.coq 
+	$(BOOTCOQTOP) -compile $*
+
+IDEFILES=$(COQIDEVO) ide/utf8.v ide/coq.png ide/.coqide-gtk2rc
+
+coqide-binaries: coqide-$(HASCOQIDE)
+coqide-no:
+coqide-byte: $(COQIDEBYTE) $(COQIDE)
+coqide-opt:  $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
+coqide-files: $(IDEFILES)
+
+clean-ide: 
+	rm -f $(COQIDEVO) $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE) 
+	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
+	rm -f ide/utf8_convert.ml
+
+$(COQIDEOPT): $(COQMKTOP) $(CMX) $(USERTACCMX) ide/ide.cmxa
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -ide -opt $(OPTFLAGS) -o $@
+	$(STRIP) $@
+
+$(COQIDEBYTE): $(COQMKTOP) $(CMO) $(USERTACCMO) ide/ide.cma
+	$(SHOW)'COQMKTOP -o $@'	
+	$(HIDE)$(COQMKTOP) -g -ide -top $(LOCALINCLUDES) $(CAMLDEBUG) -o $@
+
+$(COQIDE):
+	cd bin; ln -sf coqide.$(HASCOQIDE)$(EXE) coqide$(EXE)
+
+ide/%.cmo: ide/%.ml
+	$(SHOW)'OCAMLC    $<'	
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/%.cmi: ide/%.mli
+	$(SHOW)'OCAMLC    $<'	
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/%.cmx: ide/%.ml
+	$(SHOW)'OCAMLOPT  $<'	
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
+
+ide/utils/%.cmo: ide/%.ml
+	$(SHOW)'OCAMLC    $<'	
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/utils/%.cmi: ide/%.mli
+	$(SHOW)'OCAMLC    $<'	
+	$(HIDE)$(OCAMLC) -g $(COQIDEFLAGS) $(BYTEFLAGS) -c $<
+
+ide/utils/%.cmx: ide/%.ml
+	$(SHOW)'OCAMLOPT  $<'	
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $<
+
+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
+	rm -f ide/utf8_convert.ml
+	rm -f $(COQIDEVO) $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi)
+	rm -f $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
+
+ide/ide.cma: $(COQIDECMO)
+	$(SHOW)'OCAMLC -a -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $(COQIDECMO)
+
+ide/ide.cmxa: $(COQIDECMO:.cmo=.cmx)
+	$(SHOW)'OCAMLOPT -a -o $@'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $(COQIDECMO:.cmo=.cmx)
+
+# install targets
+
+FULLIDELIB=$(FULLCOQLIB)/ide
+
+install-coqide:: install-ide-$(HASCOQIDE) install-ide-files install-ide-info
+
+install-ide-no:
+
+install-ide-byte: 
+	$(MKDIR) $(FULLBINDIR)
+	cp $(COQIDEBYTE) $(FULLBINDIR)
+	cd $(FULLBINDIR); ln -sf coqide.byte$(EXE) coqide$(EXE)
+
+install-ide-opt:
+	$(MKDIR) $(FULLBINDIR)
+	cp $(COQIDEBYTE) $(COQIDEOPT) $(FULLBINDIR)
+	cd $(FULLBINDIR); ln -sf coqide.opt$(EXE) coqide$(EXE)
+
+install-ide-files:
+	$(MKDIR) $(FULLIDELIB)
+	cp $(IDEFILES) $(FULLIDELIB)
+
+install-ide-info:
+	$(MKDIR) $(FULLIDELIB)
+	cp ide/FAQ $(FULLIDELIB)
+
+###########################################################################
+# Pcoq: special binaries for debugging (coq-interface, parser)
+###########################################################################
+
+# target to build Pcoq
+pcoq: pcoq-binaries pcoq-files
+
+INTERFACE=\
+  contrib/interface/vtp.cmo contrib/interface/xlate.cmo \
+  contrib/interface/paths.cmo contrib/interface/translate.cmo \
+  contrib/interface/pbp.cmo \
+  contrib/interface/dad.cmo \
+  contrib/interface/history.cmo \
+  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)
+
+ifeq ($(BEST),opt)
+  COQINTERFACE=bin/coq-interface$(EXE) bin/coq-interface.opt$(EXE) bin/parser$(EXE) bin/parser.opt$(EXE)
+else
+  COQINTERFACE=bin/coq-interface$(EXE) bin/parser$(EXE)
+endif
+
+pcoq-binaries:: $(COQINTERFACE) 
+
+bin/coq-interface$(EXE): $(COQMKTOP) $(CMO) $(USERTACCMO) $(INTERFACE)
+	$(SHOW)'COQMKTOP -o $@'
+	$(HIDE)$(COQMKTOP) -top $(BYTEFLAGS) -o $@ $(INTERFACE)
+
+bin/coq-interface.opt$(EXE): $(COQMKTOP) $(CMX) $(USERTACCMX) $(INTERFACECMX)
+	$(SHOW)'COQMKTOP -o $@'
+	$(HIDE)$(COQMKTOP) -opt $(OPTFLAGS) -o $@ $(INTERFACECMX)
+
+PARSERCODE=contrib/interface/line_parser.cmo contrib/interface/vtp.cmo \
+           contrib/interface/xlate.cmo contrib/interface/parse.cmo
+PARSERCMO=$(PARSERREQUIRES) $(PARSERCODE)
+PARSERCMX= $(PARSERREQUIRESCMX) $(PARSERCODE:.cmo=.cmx)
+
+bin/parser$(EXE): $(PARSERCMO)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) -linkall -custom -cclib -lunix $(OPTFLAGS) -o $@ \
+	  dynlink.cma $(CMA) $(PARSERCMO)
+
+bin/parser.opt$(EXE): $(PARSERCMX)
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) -linkall -cclib -lunix $(OPTFLAGS) -o $@ \
+	  $(CMXA) $(PARSERCMX)
+
+INTERFACEVO=
+
+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/coq-interface$(EXE) bin/coq-interface.opt$(EXE)
+
+# install targets
+install-pcoq:: install-pcoq-binaries install-pcoq-files install-pcoq-manpages
+
+install-pcoq-binaries::
+	$(MKDIR) $(FULLBINDIR)
+	cp $(COQINTERFACE) $(FULLBINDIR)
+
+install-pcoq-files::
+	$(MKDIR) $(FULLCOQLIB)/contrib/interface
+	cp $(INTERFACERC) $(FULLCOQLIB)/contrib/interface
+
+PCOQMANPAGES=man/coq-interface.1 man/parser.1
+
+install-pcoq-manpages:
+	$(MKDIR) $(FULLMANDIR)/man1
+	cp $(PCOQMANPAGES) $(FULLMANDIR)/man1
+
+###########################################################################
+# tests
+###########################################################################
+
+check:: world pcoq
+	cd test-suite; \
+	env COQBIN=../bin COQLIB=.. ./check -$(BEST) | tee check.log
+	if grep -F 'Error!' test-suite/check.log ; then false; fi
+
+###########################################################################
+# theories and contrib files
+###########################################################################
+
+INITVO=\
+ theories/Init/Notations.vo \
+ 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
+
+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
+
+ARITHVO=\
+ theories/Arith/Arith.vo        theories/Arith/Gt.vo          \
+ theories/Arith/Between.vo      theories/Arith/Le.vo          \
+ theories/Arith/Compare.vo      theories/Arith/Lt.vo          \
+ theories/Arith/Compare_dec.vo  theories/Arith/Min.vo         \
+ theories/Arith/Div2.vo         theories/Arith/Minus.vo       \
+ theories/Arith/Mult.vo         theories/Arith/Even.vo        \
+ theories/Arith/EqNat.vo        theories/Arith/Peano_dec.vo   \
+ 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 
+
+SORTINGVO=\
+ theories/Sorting/Heap.vo	theories/Sorting/Permutation.vo \
+ theories/Sorting/Sorting.vo
+ 
+BOOLVO=\
+ theories/Bool/Bool.vo  	theories/Bool/IfProp.vo \
+ theories/Bool/Zerob.vo 	theories/Bool/DecBool.vo \
+ theories/Bool/Sumbool.vo 	theories/Bool/BoolEq.vo \
+ theories/Bool/Bvector.vo
+
+NARITHVO=\
+ theories/NArith/BinPos.vo	theories/NArith/Pnat.vo \
+ theories/NArith/BinNat.vo	theories/NArith/NArith.vo
+
+ZARITHVO=\
+ theories/ZArith/BinInt.vo      theories/ZArith/Wf_Z.vo \
+ theories/ZArith/ZArith.vo      theories/ZArith/ZArith_dec.vo \
+ 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/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
+
+LISTSVO=\
+ theories/Lists/MonoList.vo \
+ theories/Lists/ListSet.vo   	theories/Lists/Streams.vo \
+ theories/Lists/TheoryList.vo   theories/Lists/List.vo
+
+SETSVO=\
+ theories/Sets/Classical_sets.vo    theories/Sets/Permut.vo \
+ theories/Sets/Constructive_sets.vo theories/Sets/Powerset.vo \
+ theories/Sets/Cpo.vo               theories/Sets/Powerset_Classical_facts.vo \
+ theories/Sets/Ensembles.vo         theories/Sets/Powerset_facts.vo \
+ theories/Sets/Finite_sets.vo       theories/Sets/Relations_1.vo \
+ theories/Sets/Finite_sets_facts.vo theories/Sets/Relations_1_facts.vo \
+ theories/Sets/Image.vo             theories/Sets/Relations_2.vo \
+ theories/Sets/Infinite_sets.vo     theories/Sets/Relations_2_facts.vo \
+ theories/Sets/Integers.vo          theories/Sets/Relations_3.vo \
+ theories/Sets/Multiset.vo          theories/Sets/Relations_3_facts.vo \
+ theories/Sets/Partial_Order.vo     theories/Sets/Uniset.vo
+
+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/Allmaps.vo    theories/IntMap/Mapiter.vo \
+ theories/IntMap/Fset.vo       theories/IntMap/Maplists.vo \
+ theories/IntMap/Lsort.vo      theories/IntMap/Mapsubset.vo \
+ theories/IntMap/Mapaxioms.vo  theories/IntMap/Map.vo \
+
+RELATIONSVO=\
+ theories/Relations/Newman.vo \
+ theories/Relations/Operators_Properties.vo \
+ theories/Relations/Relation_Definitions.vo \
+ theories/Relations/Relation_Operators.vo \
+ theories/Relations/Relations.vo \
+ theories/Relations/Rstar.vo
+
+WELLFOUNDEDVO=\
+ theories/Wellfounded/Disjoint_Union.vo \
+ theories/Wellfounded/Inclusion.vo \
+ theories/Wellfounded/Inverse_Image.vo \
+ theories/Wellfounded/Lexicographic_Exponentiation.vo \
+ theories/Wellfounded/Transitive_Closure.vo \
+ theories/Wellfounded/Union.vo \
+ theories/Wellfounded/Wellfounded.vo \
+ theories/Wellfounded/Well_Ordering.vo \
+ theories/Wellfounded/Lexicographic_Product.vo 
+
+REALSBASEVO=\
+ theories/Reals/Rdefinitions.vo \
+ theories/Reals/Raxioms.vo      theories/Reals/RIneq.vo \
+ theories/Reals/DiscrR.vo       theories/Reals/Rbase.vo \
+
+REALS_basic= 
+
+REALS_all=\
+ 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    theories/Reals/Rfunctions.vo \
+ theories/Reals/Rseries.vo      theories/Reals/SeqProp.vo \
+ theories/Reals/Rcomplete.vo    theories/Reals/PartSum.vo \
+ theories/Reals/AltSeries.vo    theories/Reals/Binomial.vo \
+ theories/Reals/Rsigma.vo       theories/Reals/Rprod.vo \
+ theories/Reals/Cauchy_prod.vo  theories/Reals/Alembert.vo \
+ theories/Reals/SeqSeries.vo    theories/Reals/Rtrigo_fun.vo \
+ theories/Reals/Rtrigo_def.vo   theories/Reals/Rtrigo_alt.vo \
+ theories/Reals/Cos_rel.vo      theories/Reals/Cos_plus.vo \
+ theories/Reals/Rtrigo.vo       theories/Reals/Rlimit.vo \
+ theories/Reals/Rderiv.vo       theories/Reals/RList.vo \
+ theories/Reals/Ranalysis1.vo   theories/Reals/Ranalysis2.vo \
+ theories/Reals/Ranalysis3.vo   theories/Reals/Rtopology.vo \
+ theories/Reals/MVT.vo          theories/Reals/PSeries_reg.vo \
+ theories/Reals/Exp_prop.vo     theories/Reals/Rtrigo_reg.vo \
+ theories/Reals/Rsqrt_def.vo    theories/Reals/R_sqrt.vo \
+ theories/Reals/Rtrigo_calc.vo  theories/Reals/Rgeom.vo \
+ theories/Reals/Sqrt_reg.vo     theories/Reals/Ranalysis4.vo \
+ theories/Reals/Rpower.vo       theories/Reals/Ranalysis.vo \
+ theories/Reals/NewtonInt.vo    theories/Reals/RiemannInt_SF.vo \
+ theories/Reals/RiemannInt.vo   theories/Reals/Integration.vo \
+ theories/Reals/Reals.vo
+
+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)
+
+NEWTHEORIESLIGHTVO = $(INITVO) $(LOGICVO) $(ARITHVO)
+OLDTHEORIESLIGHTVO = $(NEWTHEORIESLIGHTVO:theories%.vo:theories7%.vo)
+
+theories: $(THEORIESVO)
+theories-light: $(NEWTHEORIESLIGHTVO)
+
+logic: $(LOGICVO)
+arith: $(ARITHVO)
+bool: $(BOOLVO)
+narith: $(NARITHVO)
+zarith: $(ZARITHVO)
+lists: $(LISTVO) $(LISTSVO)
+sets: $(SETSVO)
+intmap: $(INTMAPVO)
+relations: $(RELATIONSVO)
+wellfounded: $(WELLFOUNDEDVO)
+# reals
+reals: $(REALSVO)
+allreals: $(ALLREALS)
+setoids: $(SETOIDSVO)
+sorting: $(SORTINGVO)
+
+noreal: logic arith bool zarith lists sets intmap relations wellfounded \
+	setoids sorting
+
+###########################################################################
+# contribs (interface not included)
+###########################################################################
+
+OMEGAVO=\
+ contrib/omega/OmegaLemmas.vo contrib/omega/Omega.vo
+
+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
+
+FIELDVO=\
+ contrib/field/Field_Compl.vo     contrib/field/Field_Theory.vo \
+ contrib/field/Field_Tactic.vo    contrib/field/Field.vo
+
+XMLVO= 
+
+FOURIERVO=\
+ contrib/fourier/Fourier_util.vo    contrib/fourier/Fourier.vo
+
+FUNINDVO= 
+
+JPROVERVO= 
+
+CCVO=\
+ contrib/cc/CCSolve.vo
+
+CONTRIBVO = $(OMEGAVO) $(ROMEGAVO) $(RINGVO) $(FIELDVO) $(XMLVO) \
+	    $(FOURIERVO) $(JPROVERVO) $(CCVO) $(FUNINDVO)
+
+$(CONTRIBVO): states/initial.coq
+
+contrib: $(CONTRIBVO) $(CONTRIBCMO)
+omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO)
+ring: $(RINGVO) $(RINGCMO)
+xml: $(XMLVO) $(XMLCMO)
+extraction: $(EXTRACTIONCMO)
+field: $(FIELDVO) $(FIELDCMO)
+fourier: $(FOURIERVO) $(FOURIERCMO)
+jprover: $(JPROVERVO) $(JPROVERCMO)
+funind: $(FUNINDCMO) $(FUNINDVO)
+cc: $(CCVO) $(CCCMO)
+
+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)
+
+###########################################################################
+# rules to make theories, contrib and states
+###########################################################################
+
+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/$*
+
+theories/Init/%.vo: $(BESTCOQTOP) theories/Init/%.v
+	$(BOOTCOQTOP) -nois -compile theories/Init/$*
+
+theories/%.vo: theories/%.v states/initial.coq
+	$(BOOTCOQTOP) -compile theories/$*
+
+contrib/%.vo: contrib/%.v
+	$(BOOTCOQTOP) -compile contrib/$*
+
+contrib/extraction/%.vo: contrib/extraction/%.v states/barestate.coq $(COQC)
+	$(BOOTCOQTOP) -is states/barestate.coq -compile $*
+
+contrib7/extraction/%.vo: contrib7/extraction/%.v states/barestate.coq $(COQC)
+	$(BOOTCOQTOP) $(TRANSLATE) -is states7/barestate.coq -compile $*
+
+clean::
+	rm -f states/*.coq states7/*.coq
+	rm -f theories/*/*.vo theories7/*/*.vo
+	rm -f contrib/*/*.cm[io] contrib/*.cma contrib/*/*.vo contrib7/*/*.vo 
+
+archclean::
+	rm -f contrib/*/*.cmx contrib/*.cmxa contrib/*.a contrib/*/*.[so]
+
+# globalizations (for coqdoc)
+
+glob.dump::
+	rm -f glob.dump
+	rm -f theories/*/*.vo
+	$(MAKE) GLOB="-dump-glob glob.dump" world
+
+###########################################################################
+# tools
+###########################################################################
+
+COQDEP=bin/coqdep$(EXE)
+COQMAKEFILE=bin/coq_makefile$(EXE)
+GALLINA=bin/gallina$(EXE)
+COQTEX=bin/coq-tex$(EXE)
+COQWC=bin/coqwc$(EXE)
+COQDOC=bin/coqdoc$(EXE)
+
+TOOLS=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) \
+      $(COQWC) $(COQDOC)
+
+tools:: $(TOOLS) dev/top_printers.cmo
+
+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)
+
+beforedepend:: tools/coqdep_lexer.ml $(COQDEP)
+
+GALLINACMO=tools/gallina_lexer.cmo tools/gallina.cmo
+
+$(GALLINA): $(GALLINACMO)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ $(GALLINACMO)
+
+beforedepend:: tools/gallina_lexer.ml
+
+$(COQMAKEFILE): tools/coq_makefile.cmo
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -o $@ tools/coq_makefile.cmo
+
+$(COQTEX): tools/coq-tex.cmo
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -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
+
+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
+
+$(COQDOC): $(COQDOCCMO)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -custom -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
+###########################################################################
+
+MINICOQCMO=$(CONFIG) $(LIBREP) $(KERNEL) \
+	   parsing/lexer.cmo parsing/g_minicoq.cmo \
+	   toplevel/fhimsg.cmo toplevel/minicoq.cmo
+
+MINICOQ=bin/minicoq$(EXE)
+
+$(MINICOQ): $(MINICOQCMO)
+	$(SHOW)'OCAMLC -o $@'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ -custom $(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 "//").
+
+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
+
+install-byte::
+	$(MKDIR) $(FULLBINDIR)
+	cp $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(FULLBINDIR)
+	cd $(FULLBINDIR); ln -sf coqtop.byte$(EXE) coqtop$(EXE)
+
+install-opt::
+	$(MKDIR) $(FULLBINDIR)
+	cp $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(COQTOPOPT) $(FULLBINDIR)
+	cd $(FULLBINDIR); ln -sf coqtop.opt$(EXE) coqtop$(EXE)
+
+install-tools::
+	$(MKDIR) $(FULLBINDIR)
+	cp $(TOOLS) $(FULLBINDIR)
+
+LIBFILES=$(OLDTHEORIESVO) $(OLDCONTRIBVO)
+LIBFILESLIGHT=$(OLDTHEORIESLIGHTVO)
+
+NEWLIBFILES=$(NEWTHEORIESVO) $(NEWCONTRIBVO)
+NEWLIBFILESLIGHT=$(NEWTHEORIESLIGHTVO)
+
+install-library: install-library7 install-library8
+
+install-library8:
+	$(MKDIR) $(FULLCOQLIB)
+	for f in $(NEWLIBFILES); 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
+
+install-library-light:
+	$(MKDIR) $(FULLCOQLIB)
+	for f in $(LIBFILESLIGHT) $(NEWLIBFILESLIGHT); 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 \
+	  $(MKDIR) $(FULLCOQLIB)/`dirname $$f`; \
+	  cp $$f $(FULLCOQLIB)/`dirname $$f`; \
+        done
+
+install-coq-info: install-coq-manpages install-emacs install-latex
+
+MANPAGES=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
+	man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \
+	man/coqwc.1 man/coqdoc.1 \
+	man/coq_makefile.1 man/coqmktop.1
+
+install-coq-manpages:
+	$(MKDIR) $(FULLMANDIR)/man1
+	cp $(MANPAGES) $(FULLMANDIR)/man1
+
+install-emacs:
+	$(MKDIR) $(FULLEMACSLIB)
+	cp tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB)
+
+# command to update TeX' kpathsea database
+#UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null
+
+install-latex:
+	$(MKDIR) $(FULLCOQDOCDIR)
+	cp tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR)	
+#	-$(UPDATETEX)
+
+###########################################################################
+# Documentation
+# Literate programming (with ocamlweb)
+###########################################################################
+
+.PHONY: doc
+
+doc: doc/coq.tex
+	$(MAKE) -C doc coq.ps minicoq.dvi
+
+LPLIB = lib/doc.tex $(LIBREP:.cmo=.mli)
+LPKERNEL = kernel/doc.tex $(KERNEL:.cmo=.mli)
+LPLIBRARY = library/doc.tex $(LIBRARY:.cmo=.mli)
+LPPRETYPING = pretyping/doc.tex pretyping/rawterm.mli $(PRETYPING:.cmo=.mli)
+LPINTERP = $(INTERP:.cmo=.mli)
+LPPARSING = $(PARSING:.cmo=.mli) $(HIGHPARSING:.cmo=.mli)
+LPPROOFS = proofs/doc.tex $(PROOFS:.cmo=.mli)
+LPTACTICS = tactics/doc.tex $(TACTICS:.cmo=.mli) $(HIGHTACTICS:.cmo=.mli)
+LPTOPLEVEL = toplevel/doc.tex $(TOPLEVEL:.cmo=.mli)
+LPFILES = doc/macros.tex doc/intro.tex $(LPLIB) $(LPKERNEL) $(LPLIBRARY) \
+	  $(LPPRETYPING) $(LPPROOFS) $(LPTACTICS) $(LPTOPLEVEL)
+
+doc/coq.tex: $(LPFILES)
+	ocamlweb -p "\usepackage{epsfig}" $(LPFILES) -o doc/coq.tex
+#	ocamlweb $(LPFILES) -o doc/coq.tex
+
+clean::
+	rm -f doc/coq.tex
+
+###########################################################################
+# Emacs tags
+###########################################################################
+
+# NB: the -maxdepth 3 is for excluding files from contrib/extraction/test
+
+tags:
+	find . -maxdepth 3 -regex ".*\.ml[i4]?" | sort -r | xargs \
+	etags --language=none\
+	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/and[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/type[ \t]+\([^ \t]+\)/\1/" \
+              "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/val[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/module[ \t]+\([^ \t]+\)/\1/"
+
+otags: 
+	find . -maxdepth 3 -name "*.ml" -o -name "*.mli" \
+	| sort -r | xargs otags
+	find . -maxdepth 3 -name "*.ml4" | sort -r | xargs \
+	etags --append --language=none\
+	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/and[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/type[ \t]+\([^ \t]+\)/\1/" \
+              "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/val[ \t]+\([^ \t]+\)/\1/" \
+	      "--regex=/module[ \t]+\([^ \t]+\)/\1/"
+
+
+###########################################################################
+### Special rules
+###########################################################################
+
+# grammar modules with camlp4
+
+ML4FILES += parsing/lexer.ml4 parsing/q_util.ml4 parsing/q_coqast.ml4 \
+            parsing/g_prim.ml4 parsing/pcoq.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\
+  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
+
+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 
+
+GRAMMARCMO=$(GRAMMARNEEDEDCMO) $(CAMLP4EXTENSIONSCMO) $(GRAMMARSCMO)
+
+parsing/grammar.cma: $(GRAMMARCMO)
+	$(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 \
+	   parsing/g_vernac.ml4 parsing/g_proofs.ml4 \
+	   parsing/g_cases.ml4 \
+	   parsing/g_constr.ml4 parsing/g_module.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 \
+
+# beforedepend:: $(GRAMMARCMO)
+
+# beforedepend:: parsing/pcoq.ml parsing/extend.ml
+
+# toplevel/mltop.ml4 (ifdef Byte)
+
+toplevel/mltop.cmo: toplevel/mltop.byteml
+	$(SHOW)'OCAMLC    $<'	
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c -impl $< -o $@
+
+toplevel/mltop.cmx: toplevel/mltop.optml
+	$(SHOW)'OCAMLOPT  $<'	
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $< -o $@
+
+toplevel/mltop.byteml: toplevel/mltop.ml4
+	$(SHOW)'CAMLP4O   $<'	
+	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo -DByte -impl $< > $@ || rm -f $@
+
+toplevel/mltop.optml: toplevel/mltop.ml4
+	$(SHOW)'CAMLP4O   $<'	
+	$(HIDE)$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo -impl $< > $@ || rm -f $@
+
+ML4FILES += toplevel/mltop.ml4
+
+clean::
+	rm -f toplevel/mltop.byteml toplevel/mltop.optml
+
+# files compiled with -rectypes
+
+kernel/term.cmo: kernel/term.ml
+	$(SHOW)'OCAMLC    -rectypes $<' 
+	$(HIDE)$(OCAMLC) -rectypes $(BYTEFLAGS) -c $<
+
+kernel/term.cmx: kernel/term.ml
+	$(SHOW)'OCAMLOPT  -rectypes $<'
+	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $<
+
+library/nametab.cmo: library/nametab.ml
+	$(SHOW)'OCAMLC    -rectypes $<'
+	$(HIDE)$(OCAMLC) -rectypes $(BYTEFLAGS) -c $<
+
+library/nametab.cmx: library/nametab.ml
+	$(SHOW)'OCAMLOPT  -rectypes $<'
+	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $<
+
+proofs/tacexpr.cmo: proofs/tacexpr.ml
+	$(SHOW)'OCAMLC    -rectypes $<'
+	$(HIDE)$(OCAMLC) -rectypes $(BYTEFLAGS) -c $<
+
+proofs/tacexpr.cmx: proofs/tacexpr.ml
+	$(SHOW)'OCAMLOPT  -rectypes $<'
+	$(HIDE)$(OCAMLOPT) -rectypes $(OPTFLAGS) -c $<
+
+# files compiled with camlp4 because of macros
+
+lib/compat.cmo: lib/compat.ml4
+	$(SHOW)'OCAMLC4  $<' 
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) -D$(CAMLVERSION) -impl" -c -impl $<
+
+lib/compat.cmx: lib/compat.ml4
+	$(SHOW)'OCAMLOPT  $<' 
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) -D$(CAMLVERSION) -impl" -c -impl $<
+
+# files compiled with camlp4 because of streams syntax
+
+ML4FILES += lib/pp.ml4 			\
+         lib/compat.ml4 	       	\
+	 contrib/xml/xml.ml4		\
+	 contrib/xml/acic2Xml.ml4	\
+	 contrib/xml/proofTree2Xml.ml4	\
+	 contrib/interface/line_parser.ml4	\
+	 tools/coq_makefile.ml4		\
+	 tools/coq-tex.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.cmo: parsing/lexer.ml4
+#	$(SHOW)'OCAMLC4   $<'
+#	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` pr_o.cmo -impl" -c -impl $<
+
+
+
+###########################################################################
+# Default rules
+###########################################################################
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml4 .v .vo .el .elc
+
+.ml.cmo:
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c $<
+
+.mli.cmi:
+	$(SHOW)'OCAMLC    $<'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -c $<
+
+.ml.cmx:
+	$(SHOW)'OCAMLOPT  $<'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c $<
+
+.mll.ml:
+	$(SHOW)'OCAMLLEX  $<'
+	$(HIDE)ocamllex $<
+
+.mly.ml:
+	$(SHOW)'OCAMLYACC $<'
+	$(HIDE)ocamlyacc $<
+
+.mly.mli:
+	$(SHOW)'OCAMLYACC $<'
+	$(HIDE)ocamlyacc $<
+
+.ml4.cmx:
+	$(SHOW)'OCAMLOPT4 $<'
+	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` -impl" -c -impl $<
+
+.ml4.cmo:
+	$(SHOW)'OCAMLC4   $<'
+	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` -impl" -c -impl $<
+
+#.v.vo:
+#	$(BOOTCOQTOP) -compile $*
+
+.el.elc:
+	echo "(setq load-path (cons \".\" load-path))" > $*.compile
+	echo "(byte-compile-file \"$<\")" >> $*.compile
+	- $(EMACS) -batch -l $*.compile
+	rm -f $*.compile        
+
+###########################################################################
+# Cleaning
+###########################################################################
+
+archclean::
+	rm -f config/*.cmx* config/*.[soa]
+	rm -f lib/*.cmx* lib/*.[soa]
+	rm -f kernel/*.cmx* kernel/*.[soa]
+	rm -f library/*.cmx* library/*.[soa]
+	rm -f proofs/*.cmx* proofs/*.[soa]
+	rm -f tactics/*.cmx* tactics/*.[soa]
+	rm -f interp/*.cmx* interp/*.[soa]
+	rm -f parsing/*.cmx* parsing/*.[soa]
+	rm -f pretyping/*.cmx* pretyping/*.[soa]
+	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]
+	rm -f dev/*.cmx* dev/*.[soa]
+
+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 */*.pp[iox] contrib/*/*.pp[iox]
+
+cleanconfig::
+	rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7
+
+###########################################################################
+# Dependencies
+###########################################################################
+
+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
+
+# Build dependencies ignoring failures in building ml files from ml4 files
+# This is useful to rebuild dependencies when they are strongly corrupted:
+# by making scratchdepend, one gets dependencies OK for .ml files and
+# .ml4 files not using fancy parsers. This is sufficient to get beforedepend
+# and depend targets successfully built
+scratchdepend:: dependp4
+	-$(MAKE) -k -f Makefile.dep $(ML4FILESML)
+	$(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend
+	$(MAKE) depend
+
+
+# Computing the dependencies in camlp4 files is tricky.
+# We proceed in several steps:
+
+ML4FILESML = $(ML4FILES:.ml4=.ml)
+
+# Expresses dependencies of the .ml4 files w.r.t their grammars
+dependp4::
+	rm -f .depend.camlp4
+	for f in $(ML4FILES); do \
+	  printf "%s" `dirname $$f`/`basename $$f .ml4`".ml: " >> .depend.camlp4; \
+	  echo `$(CAMLP4DEPS) $$f` >> .depend.camlp4; \
+	done
+
+# Produce the .ml files using Makefile.dep
+ml4filesml:: .depend.camlp4
+	$(MAKE) -f Makefile.dep $(ML4FILESML)
+
+depend: beforedepend dependp4 ml4filesml
+# 1. We express dependencies of the .ml files w.r.t their grammars
+# 2. Then we are able to produce the .ml files using Makefile.dep
+# 3. We compute the dependencies inside the .ml files using ocamldep
+	$(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend
+# 4. We express dependencies of .cmo and .cmx files w.r.t their grammars
+	for f in $(ML4FILES); do \
+	  printf "%s" `dirname $$f`/`basename $$f .ml4`".cmo: " >> .depend; \
+	  echo `$(CAMLP4DEPS) $$f` >> .depend; \
+	  printf "%s" `dirname $$f`/`basename $$f .ml4`".cmx: " >> .depend; \
+	  echo `$(CAMLP4DEPS) $$f` >> .depend; \
+	done
+# 5. Finally, we erase the generated .ml files
+	rm -f $(ML4FILESML)
+# 6. 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
+
+ml4clean::
+	rm -f $(ML4FILESML)
+
+clean::
+	rm -f $(ML4FILESML)
+
+# this sets up developper supporting stuff
+devel:	
+	touch .depend.devel
+	$(MAKE) -f dev/Makefile.devel setup-devel
+	$(MAKE) dev/top_printers.cmo
+
+include .depend
+include .depend.coq
+include .depend.coq7
+
+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
new file mode 100644
index 00000000..30690fac
--- /dev/null
+++ b/Makefile.dep
@@ -0,0 +1,15 @@
+#######################################################################
+#  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       #
+#######################################################################
+
+# This Makefile is designed to make the .ml files corresponding to .ml4 files
+
+include Makefile
+include .depend.camlp4
+
+.ml4.ml:
+	$(CAMLP4O) $(CAMLP4EXTENDFLAGS) pr_o.cmo `$(CAMLP4DEPS) $<` -impl $< > $@ || rm -f $@
diff --git a/README b/README
new file mode 100644
index 00000000..f801891e
--- /dev/null
+++ b/README
@@ -0,0 +1,79 @@
+
+            		THE COQ V8.0 SYSTEM
+            		===================
+
+INSTALLATION.
+=============
+
+   See the file INSTALL for installation procedure.
+
+
+DOCUMENTATION.
+==============
+
+   The documentation of Coq V8.0 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.
+
+
+CHANGES.
+========
+
+   There is a file named CHANGES that explains the differences and the
+   incompatibilities since last versions. If you upgrade Coq, please read
+   it carefully.
+
+
+AVAILABILITY.
+=============
+
+   Coq is available by anonymous FTP on ftp.inria.fr:
+
+	host:	    ftp.inria.fr (192.93.2.54)
+	directory:  INRIA/LogiCal/coq/
+
+THE COQ CLUB.
+=============
+
+   The Coq Club moderated mailing list is meant to be a standard way to
+   discuss questions about the Coq system and related topics. The submission
+   address is:
+
+	coq-club@coq.inria.fr
+
+   The topics to be discussed in the club should include:
+
+     * technical problems;
+
+     * questions about proof developments;
+
+     * suggestions and questions about the implementation;
+
+     * announcements of proofs;
+
+     * theoretical questions about typed lambda-calculi which are
+       closely related to Coq.
+
+   To be added to, or removed from, the mailing list, please write to:
+
+	coq-club-request@coq.inria.fr
+
+   Please use also this address for any questions/suggestions about the
+   Coq Club. It might sometimes take a few days before your messages get
+   forwarded.
+
+
+BUGS REPORT.
+============
+
+   Send your bug reports by filling a form at
+
+        http://coq.inria.fr/bin/coq-bugs
+
+   or by E-mail to
+
+	coq-bugs@coq.inria.fr
+
+   To be effective, bug reports should mention the Caml version used
+   to compile and run Coq, the Coq version (coqtop -v), the configuration
+   used, and include a complete source example leading to the bug.
diff --git a/README.win b/README.win
new file mode 100644
index 00000000..4d698e93
--- /dev/null
+++ b/README.win
@@ -0,0 +1,43 @@
+THE COQ V8.0 SYSTEM
+===================
+
+    This file contains remarks specific to the windows port of Coq.
+
+INSTALLATION.
+=============
+
+    See the file INSTALL.win for installation procedure.
+
+COMPILATION.
+============
+
+    If you want to install coq, you had better transfer the precompiled
+    distribution. If you really need to recompile under Windows, here
+    are some indications:
+
+    1- Install ocaml version 3.06 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://sources.redhat.com/cygwin/.
+
+    3- Under cygwin, type successively
+
+        ./configure
+        make world
+        make install
+        make clean
+
+    4- Though not nescessary, you can find useful:
+         - Windows version of (X)Emacs: it is a powerful environment for
+           developpers with coloured syntax, modes for compilation and debug,
+           and many more. It is free. See: http://www.gnu.org/software.
+         - Windows cvs client (very useful if you have access to the Coq
+           archive).
+
+    If you are lost, you could find help at: coq-bugs@pauillac.inria.fr.
+
+    Good luck :-)
+
+    The Coq Team.
diff --git a/config/Makefile.template b/config/Makefile.template
new file mode 100644
index 00000000..cd49db89
--- /dev/null
+++ b/config/Makefile.template
@@ -0,0 +1,107 @@
+##################################
+#
+#  Configuration file for Coq
+# 
+##################################
+
+#############################################################################
+#
+#  This file is generated by the script "configure"
+#
+#  DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !! 
+#
+#  If something is wrong below, then rerun the script "configure"
+#  with the good options (see the file INSTALL).
+#
+#############################################################################
+
+# Local use (no installation)
+LOCAL=LOCALINSTALLATION
+
+# Paths for true installation
+# BINDIR=path where coqtop, coqc, coqmktop, coq-tex, coqdep, gallina and
+#        do_Makefile will reside
+# 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"
+EMACS=EMACSCOMMAND
+
+# Path to Coq distribution
+COQTOP=COQTOPDIRECTORY
+VERSION=COQVERSION
+
+# Directory containing Camlp4 binaries. Can be empty if camlp4 is in the PATH
+CAMLP4BIN=CAMLP4BINDIRECTORY
+
+# Ocaml version number
+CAMLVERSION=CAMLTAG
+
+# Camlp4 library directory (avoid CAMLP4LIB used on Windows)
+CAMLP4O=CAMLP4TOOL
+MYCAMLP4LIB=CAMLP4LIBDIRECTORY
+
+# Objective-Caml compile command 
+OCAMLC=BYTECAMLC
+OCAMLOPT=NATIVECAMLC
+
+# Caml link command and Caml make top command
+CAMLLINK=BYTECAMLC
+CAMLOPTLINK=NATIVECAMLC
+CAMLMKTOP=ocamlmktop
+
+# Compilation debug flag
+CAMLDEBUG=COQDEBUGFLAG
+
+# Compilation profile flag
+CAMLTIMEPROF=COQPROFILEFLAG
+
+# The best compiler: native (=opt) or bytecode (=byte) if no native compiler
+BEST=BESTCOMPILER
+
+# For Camlp4 use
+P4=$(COQTOP)/bin/$(ARCH)/call_camlp4 -I $(COQTOP)/src/parsing
+P4DEP=$(COQTOP)/bin/$(ARCH)/camlp4dep
+
+# Your architecture
+# Can be obtain by UNIX command arch
+ARCH=ARCHITECTURE
+
+# Supplementary libs for some systems, currently:
+#  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket
+#  . others     : -cclib -lunix
+#  . windows	: -cclib -lunix
+
+OSDEPLIBS=OSDEPENDENTLIBS
+
+# executable files extension, currently:
+#  Unix systems:
+#  Win32 systems : .exe
+EXE=EXECUTEEXTENSION
+
+# the command MKDIR (try to replace it with mkdirhier if you have problems)
+MKDIR=mkdir -p
+
+# where to put the coqdoc.sty style file
+COQDOCDIR=COQDOCDIRECTORY
+
+# command to update TeX' kpathsea database
+#MKTEXLSR=MKTEXLSRCOMMAND
+
+#the command STRIP 
+# Unix systems and profiling: true
+# Unix systems and no profiling: strip
+# Win32 systems: true (actually strip is bogus)
+STRIP=STRIPCOMMAND
+
+# Options for reals (all/basic)
+REALS=REALSOPT
+
+# CoqIde (no/byte/opt)
+HASCOQIDE=COQIDEOPT
+
+# 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
new file mode 100644
index 00000000..1d88358a
--- /dev/null
+++ b/config/coq_config.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq_config.mli,v 1.9.16.1 2004/07/16 19:29:58 herbelin Exp $ i*)
+
+val local : bool        (* local use (no installation) *)
+
+val bindir : string     (* where the binaries are installed *)
+val coqlib : string     (* where the std library is installed *)
+
+val coqtop : string     (* where are the sources *)
+
+val camllib : string    (* for Dynlink *)
+
+val camlp4lib : string  (* where is the library of Camlp4 *)
+
+val best : string       (* byte/opt *)
+val arch : string       (* architecture *)
+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 *)
+
+val theories_dirs : string list
+val contrib_dirs : string list
+
+val exec_extension : string (* "" under Unix, ".exe" under MS-windows *)
diff --git a/config/giveostype.ml b/config/giveostype.ml
new file mode 100644
index 00000000..e657bc79
--- /dev/null
+++ b/config/giveostype.ml
@@ -0,0 +1 @@
+print_string Sys.os_type;;
diff --git a/configure b/configure
new file mode 100755
index 00000000..923eee76
--- /dev/null
+++ b/configure
@@ -0,0 +1,542 @@
+#!/bin/sh
+
+##################################
+#
+#  Configuration script for Coq
+# 
+##################################
+
+VERSION=8.0pl1
+DATE="Jul 2004"
+
+# a local which command for sh
+which () {
+IFS=":" # set words separator in PATH to be ':' (it allows spaces in dirnames)
+for i in $PATH; do
+  if test -z "$i"; then i=.; fi 
+  if [ -f "$i/$1" ] ; then
+	IFS=" "
+        echo "$i/$1"
+	break
+  fi
+done
+}
+
+bytecamlc=ocamlc
+nativecamlc=ocamlopt
+camlp4o=camlp4o
+coq_debug_flag=
+coq_profile_flag=
+best_compiler=opt
+
+local=false
+bindir_spec=no
+libdir_spec=no
+mandir_spec=no
+emacslib_spec=no
+emacs_spec=no
+coqdocdir_spec=no
+reals_opt=no
+reals=all
+arch_spec=no
+coqide_spec=no
+
+COQTOP=`pwd`
+
+
+# Parse command-line arguments
+
+while : ; do
+  case "$1" in
+    "") break;;
+    -prefix|--prefix) bindir_spec=yes
+                      bindir=$2/bin
+                      libdir_spec=yes
+		      libdir=$2/lib/coq
+                      mandir_spec=yes
+		      mandir=$2/man
+		      coqdocdir_spec=yes
+		      coqdocdir=$2/share/texmf/tex/latex/misc
+		      shift;;
+    -local|--local) local=true
+                    bindir_spec=yes
+                    bindir=$COQTOP/bin
+                    libdir_spec=yes
+		    libdir=$COQTOP
+                    mandir_spec=yes
+		    mandir=$COQTOP/man
+                    emacslib_spec=yes
+		    emacslib=$COQTOP/tools/emacs
+		    coqdocdir_spec=yes
+		    coqdocdir=$COQTOP/tools/coqdoc
+		    reals_opt=yes
+		    reals=all;;
+    -src|--src) COQTOP=$2
+	        shift;;
+    -bindir|--bindir) bindir_spec=yes
+                      bindir=$2
+		      shift;;
+    -libdir|--libdir) libdir_spec=yes
+                      libdir=$2
+		      shift;;
+    -mandir|--mandir) mandir_spec=yes
+                      mandir=$2
+		      shift;;
+    -emacslib|--emacslib) emacslib_spec=yes
+                          emacslib=$2
+			  shift;;
+    -emacs |--emacs) emacs_spec=yes
+		     emacs=$2
+		     shift;;
+    -coqdocdir|--coqdocdir) coqdocdir_spec=yes
+	              coqdocdir=$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
+                nativecamlc=ocamlopt.opt;;
+    -reals|--reals) reals_opt=yes
+		    reals=$2
+		    shift;;
+    -coqide|--coqide) coqide_spec=yes
+		      COQIDE=$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;;
+  esac
+  shift
+done
+
+
+# compile date
+DATEPGM=`which date`
+case $DATEPGM in
+    "") echo "I can't find the program \"date\" in your path."
+        echo "Please give me the current date"
+	read COMPILEDATE;;
+    *)  COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;;
+esac
+
+# Architecture
+
+case $arch_spec in
+    no) if test -x /bin/arch ; then
+	    ARCH=`/bin/arch`
+	elif test -x /usr/bin/arch ; then
+	    ARCH=`/usr/bin/arch`
+	elif test -x /usr/ucb/arch ; then
+	    ARCH=`/usr/ucb/arch`
+	elif test -x /bin/uname && (/bin/uname -s | grep -q -i CYGWIN) ; then
+	    ARCH=win32
+	    # cygwin returns a name of the form /cygdrive/c/... 
+	    # that coqc does not understand; need to transform it
+	    COQTOP=`echo $COQTOP | sed -e "s#.*cygdrive.\(.\)#\1:#"`
+	elif test -x /usr/bin/uname ; then
+	    ARCH=`/usr/bin/uname -s`
+	else
+	    echo "I can not automatically find the name of your architecture"
+	    echo -n\
+              "Give me a name, please [win32 for Win95, Win98 or WinNT]: "
+	    read ARCH
+	fi;;
+    yes) ARCH=$arch
+esac
+
+# bindir, libdir, mandir, etc.
+
+case $ARCH in
+  win32)
+	 bindir_def=C:\\coq\\bin
+	 libdir_def=C:\\coq\\lib
+	 mandir_def=C:\\coq\\man
+	 emacslib_def=C:\\coq\\emacs;;
+  *)
+	 bindir_def=/usr/local/bin
+	 libdir_def=/usr/local/lib/coq
+	 mandir_def=/usr/local/man
+	 emacslib_def=/usr/share/emacs/site-lisp
+         coqdocdir_def=/usr/share/texmf/tex/latex/misc;;
+esac
+
+emacs_def=emacs
+
+case $bindir_spec in
+    no) echo "Where should I install the Coq binaries [$bindir_def] ?"
+        read BINDIR
+	
+	case $BINDIR in
+	    "") BINDIR=$bindir_def;;
+	    *) true;;
+	esac;;
+    yes) BINDIR=$bindir;;
+esac
+
+case $libdir_spec in
+    no) echo "Where should I install the Coq library [$libdir_def] ?"
+        read LIBDIR
+	
+	case $LIBDIR in
+	    "") LIBDIR=$libdir_def;;
+	    *) true;;
+	esac;;
+    yes) LIBDIR=$libdir;;
+esac
+
+case $mandir_spec in
+    no) echo "Where should I install the Coq man pages [$mandir_def] ?"
+        read MANDIR
+	
+	case $MANDIR in
+	    "") MANDIR=$mandir_def;;
+	    *) true;;
+	esac;;
+    yes) MANDIR=$mandir;;
+esac
+
+case $emacslib_spec in
+    no) echo "Where should I install the Coq Emacs mode [$emacslib_def] ?"
+        read EMACSLIB
+	
+	case $EMACSLIB in
+	    "") EMACSLIB=$emacslib_def;;
+	    *) true;;
+	esac;;
+    yes) EMACSLIB=$emacslib;;
+esac
+
+case $coqdocdir_spec in
+    no) echo "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def] ?"
+        read COQDOCDIR
+	
+	case $COQDOCDIR in
+	    "") COQDOCDIR=$coqdocdir_def;;
+	    *) true;;
+	esac;;
+    yes) COQDOCDIR=$coqdocdir;;
+esac
+
+case $reals_opt in
+    no) echo "Should I compile the complete theory of real analysis [Y/N, default is Y] ?"
+	read reals_ans
+
+	case $reals_ans in
+	    "N"|"n"|"No"|"NO"|"no")
+		    reals=basic;;
+		*) reals=all;;
+	esac;;
+    yes) true;;
+esac
+
+# case $emacs_spec in
+#     no) echo "Which Emacs command should I use to compile coq.el [$emacs_def] ?"
+#         read EMACS
+	
+# 	case $EMACS in
+# 	    "") EMACS=$emacs_def;;
+# 	    *) true;;
+# 	esac;;
+#     yes) EMACS=$emacs;;
+# esac
+
+# OS dependent libraries
+
+case $ARCH in
+  sun4*) OS=`uname -r`
+	case $OS in
+	   5*) OS="Sun Solaris $OS"
+	       OSDEPLIBS="-cclib -lunix -cclib -lnsl -cclib -lsocket";;
+	   *) OS="Sun OS $OS"
+	      OSDEPLIBS="-cclib -lunix"
+        esac;;
+  alpha) OSDEPLIBS="-cclib -lunix";;
+  win32) OS="Win32" 
+	 OSDEPLIBS="-cclib -lunix";;
+  *) OSDEPLIBS="-cclib -lunix"
+esac
+
+# executable extension
+
+case $ARCH in
+    win32) EXE=".exe";;
+    *) EXE=""
+esac
+
+# 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 "$CAMLC" in
+		"") CAMLC=/usr/local/bin/$bytecamlc;;
+		*/ocamlc|*/ocamlc.opt) true;;
+		*/) CAMLC="${CAMLC}"$bytecamlc;;
+		*) CAMLC="${CAMLC}"/$bytecamlc;;
+	esac
+	bytecamlc="$CAMLC"
+	nativecamlc=`dirname "$CAMLC"`/$nativecamlc;;
+esac
+
+if test ! -f "$CAMLC" ; then
+	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' `
+
+case $CAMLVERSION in
+  1.*|2.*|3.00|3.01|3.02|3.03|3.03alpha|3.04|3.05beta|3.05)
+	echo "Your version of Objective-Caml is $CAMLVERSION."
+	echo "You need Objective-Caml 3.06 or later !"
+	echo "Configuration script failed!"
+	exit 1;;
+  ?*)	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!"
+     exit 1;;
+esac
+
+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
+fi
+
+# For coqmktop
+
+#CAMLLIB=`"$CAMLC" -v | sed -n -e 's|.*directory:* *\(.*\)$|\1|p' `
+CAMLLIB=`"$CAMLC" -where`
+
+# Camlp4 (greatly simplified since merged with ocaml)
+
+CAMLP4BIN=${CAMLBIN}
+
+#case $OS in
+#  Win32)
+    CAMLP4LIB=+camlp4
+# ;;
+#  *)
+#    CAMLP4LIB=${CAMLLIB}/camlp4
+#esac
+
+# lablgtk2 and CoqIDE
+
+if [ "$coqide_spec" = "no" ] ; then
+if test -x "${CAMLLIB}/lablgtk2" ; then
+    if grep -q -w convert_with_fallback "${CAMLLIB}/lablgtk2/glib.mli" ; then
+	if test -f "${CAMLLIB}/threads/threads.cmxa" ; then
+            echo "LablGtk2 found, native threads: native CoqIde will be available"
+	    COQIDE=opt;
+        else
+            echo "LablGtk2 found, no native threads: bytecode CoqIde will be available"
+	    COQIDE=byte
+	fi;
+    else
+        echo "LablGtk2 found but too old: CoqIde will not be available"
+        COQIDE=no;
+    fi
+else
+    echo "LablGtk2 not found: CoqIde will not be available"
+    COQIDE=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
+
+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;;
+#esac
+
+# Summary of the configuration
+
+echo ""
+echo "  Coq top directory                 : $COQTOP"
+echo "  Architecture                      : $ARCH"
+if test ! -z "$OS" ; then
+  echo "  Operating system                  : $OS"
+fi
+echo "  OS dependent libraries            : $OSDEPLIBS"
+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 "$reals" = "all"; then
+echo "  Reals theory                      : All"
+else
+echo "  Reals theory                      : Basic"
+fi
+echo "  CoqIde                            : $COQIDE"
+echo ""
+
+echo "  Paths for true installation:"
+echo "    binaries   will be copied in $BINDIR"
+echo "    library    will be copied in $LIBDIR"
+echo "    man pages  will be copied in $MANDIR"
+echo "    emacs mode will be copied in $EMACSLIB"
+echo ""
+
+#####################################################
+# Building the $COQTOP/config/coq_config.ml file
+#####################################################
+
+# damned backslashes under M$Windows
+case $ARCH in
+    win32)
+	CAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'`
+	BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
+	LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
+  	MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
+   	EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
+	;;
+esac
+
+mlconfig_file=$COQTOP/config/coq_config.ml
+rm -f $mlconfig_file
+cat << END_OF_COQ_CONFIG > $mlconfig_file
+(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)
+
+let local = $local
+let bindir = "$BINDIR" 
+let coqlib = "$LIBDIR"
+let coqtop = "$COQTOP"
+let camllib = "$CAMLLIB"
+let camlp4lib = "$CAMLP4LIB"
+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"
+
+END_OF_COQ_CONFIG
+
+# to be sure printf is found on windows when spaces occur in PATH variable
+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)
+}
+
+echo "let theories_dirs = [" >> $mlconfig_file
+subdirs theories
+echo "]" >> $mlconfig_file
+
+echo "let contrib_dirs = [" >> $mlconfig_file
+subdirs contrib
+echo "]" >> $mlconfig_file
+
+chmod a-w $mlconfig_file
+
+
+###############################################
+# Building the $COQTOP/config/Makefile file
+###############################################
+
+rm -f $COQTOP/config/Makefile
+
+# damned backslashes under M$Windows (bis)
+case $ARCH in
+    win32)
+	BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
+	LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
+  	MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
+   	EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
+	;;
+esac
+
+sed -e "s|LOCALINSTALLATION|$local|" \
+    -e "s|COQTOPDIRECTORY|$COQTOP|" \
+    -e "s|COQVERSION|$VERSION|" \
+    -e "s|BINDIRDIRECTORY|$BINDIR|" \
+    -e "s|COQLIBDIRECTORY|$LIBDIR|" \
+    -e "s|MANDIRDIRECTORY|$MANDIR|" \
+    -e "s|EMACSLIBDIRECTORY|$EMACSLIB|" \
+    -e "s|EMACSCOMMAND|$EMACS|" \
+    -e "s|COQDOCDIRECTORY|$COQDOCDIR|" \
+    -e "s|MKTEXLSRCOMMAND|$MKTEXLSR|" \
+    -e "s|ARCHITECTURE|$ARCH|" \
+    -e "s|OSDEPENDENTLIBS|$OSDEPLIBS|" \
+    -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
+    -e "s|CAMLLIBDIRECTORY|$CAMLLIB|" \
+    -e "s|CAMLTAG|$CAMLTAG|" \
+    -e "s|CAMLP4BINDIRECTORY|$CAMLP4BIN|" \
+    -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
+    -e "s|CAMLP4TOOL|$camlp4o|" \
+    -e "s|COQDEBUGFLAG|$coq_debug_flag|" \
+    -e "s|COQPROFILEFLAG|$coq_profile_flag|" \
+    -e "s|BESTCOMPILER|$best_compiler|" \
+    -e "s|EXECUTEEXTENSION|$EXE|" \
+    -e "s|BYTECAMLC|$bytecamlc|" \
+    -e "s|NATIVECAMLC|$nativecamlc|" \
+    -e "s|STRIPCOMMAND|$STRIPCOMMAND|" \
+    -e "s|REALSOPT|$reals|" \
+    -e "s|COQIDEOPT|$COQIDE|" \
+      $COQTOP/config/Makefile.template > $COQTOP/config/Makefile
+
+chmod a-w $COQTOP/config/Makefile
+
+##################################################
+# Building the $COQTOP/dev/ocamldebug-v7 file
+####################################################
+
+if test "$coq_debug_flag" = "-g" ; then
+  rm -f $COQTOP/dev/ocamldebug-v7
+  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|$CAMLP4LIBFORCAMLDEBUG|" \
+      $COQTOP/dev/ocamldebug-v7.template > $COQTOP/dev/ocamldebug-v7
+  chmod a-w,a+x $COQTOP/dev/ocamldebug-v7
+fi
+
+echo "If anything in the above is wrong, please restart './configure'"
+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.5 2004/07/17 17:06:51 herbelin Exp $
diff --git a/contrib/cc/CCSolve.v b/contrib/cc/CCSolve.v
new file mode 100644
index 00000000..fab6f775
--- /dev/null
+++ b/contrib/cc/CCSolve.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $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/README b/contrib/cc/README
new file mode 100644
index 00000000..073b140e
--- /dev/null
+++ b/contrib/cc/README
@@ -0,0 +1,20 @@
+
+cctac: congruence-closure for coq
+
+author: Pierre Corbineau, 
+	Stage de DEA au LSV, ENS Cachan
+	Thèse au LRI, Université Paris Sud XI 
+
+Files :
+
+- ccalgo.ml : congruence closure algorithm
+- ccproof.ml : proof generation code
+- cctac.ml4 : the tactic itself
+- CCSolve.v : a small Ltac tactic based on congruence 
+
+Known Bugs : the congruence tactic can fail due to type dependencies.
+
+Related documents:
+	Peter J. Downey, Ravi Sethi, and Robert E. Tarjan.
+	Variations on the common subexpression problem.
+	JACM, 27(4):758-771, October 1980.	
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
new file mode 100644
index 00000000..e73a6221
--- /dev/null
+++ b/contrib/cc/ccalgo.ml
@@ -0,0 +1,357 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ccalgo.ml,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+
+(* This file implements the basic congruence-closure algorithm by *)
+(* Downey,Sethi and Tarjan. *)
+
+open Util
+open Names
+open Term
+
+let init_size=251
+
+type pa_constructor=
+    {head_constr: int;
+     arity:int;
+     nhyps:int;
+     args:int list;
+     term_head:int}
+
+
+module PacMap=Map.Make(struct type t=int*int let compare=compare end) 
+
+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}
+
+(* Signature table *)
+
+module ST=struct
+  
+  (* l: sign -> term r: term -> sign *)
+	
+  type t = {toterm:(int*int,int) Hashtbl.t;
+	    tosign:(int,int*int) Hashtbl.t}
+	
+  let empty ()=
+    {toterm=Hashtbl.create init_size;
+     tosign=Hashtbl.create init_size}
+      
+  let enter t sign st=
+    if Hashtbl.mem st.toterm sign then 
+	anomaly "enter: signature already entered"
+    else 
+	Hashtbl.replace st.toterm sign t;
+	Hashtbl.replace st.tosign t sign
+	  
+  let query sign st=Hashtbl.find st.toterm sign
+	  
+  let delete t st=
+    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
+	  
+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 representative=
+      {mutable nfathers:int;
+       mutable fathers:int list;
+       mutable constructors:pa_constructor PacMap.t;
+       mutable inductives:(int * int) IndMap.t}
+
+  type cl = Rep of representative| Eqto of int*equality
+
+  type vertex = Leaf| Node of (int*int) 
+
+  type node = 
+      {clas:cl;
+       vertex:vertex;
+       term:term;
+       mutable node_constr: int PacMap.t}    
+
+  type t={mutable size:int;
+          map:(int,node) Hashtbl.t;
+          syms:(term,int) Hashtbl.t;
+	  sigtable:ST.t}
+
+  let empty ():t={size=0;
+		  map=Hashtbl.create init_size;
+		  syms=Hashtbl.create init_size;
+		  sigtable=ST.empty ()}
+
+  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"
+
+  let get_constructor uf i=
+    match (Hashtbl.find uf.map i).term with
+	Constructor (cstr,_,_)->cstr
+      | _ -> anomaly "get_constructor: not a constructor"
+
+
+  let fathers uf i=
+    (get_representative uf i).fathers
+	  
+  let size uf i=
+    (get_representative uf i).nfathers
+
+  let add_father uf i t=
+    let r=get_representative uf i in
+      r.nfathers<-r.nfathers+1;
+      r.fathers<-t::r.fathers 
+
+  let pac_map uf i=
+    (get_representative uf i).constructors  
+
+  let pac_arity uf i sg=
+    (PacMap.find sg (get_representative uf i).constructors).arity
+
+  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
+  
+  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
+	
+  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 new_representative pm im=
+    {nfathers=0;
+     fathers=[];
+     constructors=pm;
+     inductives=im}
+
+  let rec add uf t= 
+    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}
+	      | 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}
+	  in
+	    Hashtbl.add 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 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 join_path uf i j=
+    assert (find uf i=find uf j);
+    min_path (down_path uf i [],down_path uf j [])
+      
+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
+      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
+	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
+	  
+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 check_equal uf (i1,i2) = UF.find uf i1 = UF.find uf i2
+
+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
new file mode 100644
index 00000000..47cdb3ea
--- /dev/null
+++ b/contrib/cc/ccalgo.mli
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: ccalgo.mli,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+
+type pa_constructor
+    (*{head: int; arity: int; args: (int * int) list}*)
+
+module PacMap:Map.S with type key=int * int 
+
+type term = 
+    Symb of Term.constr 
+  | Appli of term * term 
+  | Constructor of Names.constructor*int*int
+
+type rule = 
+    Congruence 
+  | Axiom of Names.identifier
+  | Injection of int*int*int*int
+
+type equality =
+    {lhs : int; 
+     rhs : int; 
+     rule : rule}
+
+module ST :
+sig
+  type t
+  val empty : unit -> t
+  val enter : int -> int * int -> t -> unit
+  val query : int * int -> t -> int
+  val delete : int -> t -> unit
+  val delete_list : int list -> t -> unit
+end
+  
+module UF :
+sig
+  type t 
+  exception Discriminable of int * int * int * int * t 
+  val empty : unit -> t
+  val find : t -> int -> int
+  val size : t -> int -> int
+  val get_constructor : t -> int -> Names.constructor
+  val pac_arity : t -> int -> int * int -> int
+  val mem_node_pac : t -> int -> int * int -> int 
+  val add_pacs : t -> int -> pa_constructor PacMap.t -> 
+    int list * equality list
+  val term : t -> int -> term    
+  val subterms : t -> int -> int * int
+  val add : t -> term -> int
+  val union : t -> int -> int -> equality -> int list * equality list
+  val join_path : t -> int -> int -> 
+    ((int*int)*equality) list*
+    ((int*int)*equality) list
+end
+  
+
+val combine_rec : UF.t -> int list -> equality list
+val process_rec : UF.t -> equality list -> int list
+
+val cc : UF.t -> unit
+  
+val make_uf :
+  (Names.identifier * (term * term)) list -> UF.t
+
+val add_one_diseq : UF.t -> (term * term) -> int * int
+
+val add_disaxioms : 
+  UF.t -> (Names.identifier * (term * term)) list -> 
+  (Names.identifier * (int * int)) list
+  
+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
new file mode 100644
index 00000000..fa525e65
--- /dev/null
+++ b/contrib/cc/ccproof.ml
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ccproof.ml,v 1.8.2.1 2004/07/16 19:29:58 herbelin Exp $ *)
+
+(* 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 Ccalgo
+  
+type proof=
+    Ax of identifier
+  | SymAx of identifier
+  | Refl of term
+  | Trans of proof*proof
+  | Congr of proof*proof
+  | Inject of proof*constructor*int*int 
+		  
+let pcongr=function
+    Refl t1, Refl t2 -> Refl (Appli (t1,t2))
+  | p1, p2 -> Congr (p1,p2)
+
+let rec ptrans=function
+    Refl _, p ->p
+  | p, Refl _ ->p
+  | Trans(p1,p2), p3 ->ptrans(p1,ptrans (p2,p3))
+  | Congr(p1,p2), Congr(p3,p4) ->pcongr(ptrans(p1,p3),ptrans(p2,p4))
+  | Congr(p1,p2), Trans(Congr(p3,p4),p5) ->
+      ptrans(pcongr(ptrans(p1,p3),ptrans(p2,p4)),p5)
+  | p1, p2 ->Trans (p1,p2)
+	
+let rec psym=function
+    Refl p->Refl p
+  | SymAx s->Ax s
+  | Ax s-> SymAx s
+  | Inject (p,c,n,a)-> Inject (psym p,c,n,a)
+  | Trans (p1,p2)-> ptrans (psym p2,psym p1)
+  | Congr (p1,p2)-> pcongr (psym p1,psym p2)
+	
+let pcongr=function
+    Refl t1, Refl t2 ->Refl (Appli (t1,t2))
+  | p1, p2 -> Congr (p1,p2)
+
+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
+	ptrans (path_proof i li,psym (path_proof j lj))
+  
+  and edge_proof ((i,j),eq)=
+    let pi=equal_proof i eq.lhs in
+    let pj=psym (equal_proof j eq.rhs) in
+    let pij=
+      match eq.rule with 
+	  Axiom s->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" 
+    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 path_proof i=function
+      [] -> Refl (UF.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   
+      pcongr (equal_proof i1 j1, equal_proof i2 j2)
+	
+  and discr_proof i ci j cj=
+    let p=equal_proof i j 
+    and p1=constr_proof i i ci 0 
+    and p2=constr_proof j j cj 0 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
+
+let rec nth_arg t n=
+  match t with 
+      Appli (t1,t2)-> 
+	if n>0 then 
+	  nth_arg t1 (n-1)
+	else t2
+    | _ -> anomaly "nth_arg: not enough args"
+
+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)
+    | Refl t-> t,t
+    | Trans (p1,p2)->
+	let (s1,t1)=type_proof axioms p1 
+	and (t2,s2)=type_proof axioms p2 in
+	  if t1=t2 then (s1,s2) else anomaly "invalid cc transitivity"
+    | Congr (p1,p2)->
+	let (i1,j1)=type_proof axioms p1
+	and (i2,j2)=type_proof axioms p2 in
+	  Appli (i1,i2),Appli (j1,j2)
+    | Inject (p,c,n,a)->
+	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
new file mode 100644
index 00000000..887ed070
--- /dev/null
+++ b/contrib/cc/ccproof.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        *)
+(************************************************************************)
+
+(* $Id: ccproof.mli,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+
+open Ccalgo
+open Names
+
+type proof =
+    Ax of identifier
+  | SymAx of identifier
+  | 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
+
+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 ]
+
+
diff --git a/contrib/cc/cctac.ml4 b/contrib/cc/cctac.ml4
new file mode 100644
index 00000000..49fe46fe
--- /dev/null
+++ b/contrib/cc/cctac.ml4
@@ -0,0 +1,247 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/contrib/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v
new file mode 100644
index 00000000..b352045a
--- /dev/null
+++ b/contrib/correctness/ArrayPermut.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+
+(****************************************************************************)
+(*                    Permutations of elements in arrays                    *)
+(*                        Definition and properties                         *)
+(****************************************************************************)
+
+Require Import ProgInt.
+Require Import Arrays.
+Require Export Exchange.
+
+Require Import 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 :
+      forall (t t':array n A) (i j:Z), exchange t t' i j -> permut t t'
+  | permut_refl : forall t:array n A, permut t t
+  | permut_sym : forall t t':array n A, permut t t' -> permut t' t
+  | permut_trans :
+      forall t t' t'':array n A, permut t t' -> permut t' t'' -> permut t t''.
+
+Hint 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 :
+      forall (t t':array n A) (i j:Z),
+        (g <= i <= d)%Z ->
+        (g <= j <= d)%Z -> exchange t t' i j -> sub_permut g d t t'
+  | sub_permut_refl : forall t:array n A, sub_permut g d t t
+  | sub_permut_sym :
+      forall t t':array n A, sub_permut g d t t' -> sub_permut g d t' t
+  | sub_permut_trans :
+      forall t t' t'':array n A,
+        sub_permut g d t t' -> sub_permut g d t' t'' -> sub_permut g d t t''.
+
+Hint 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) := forall i:Z, (g <= i <= d)%Z -> #t [i] = #t' [i].
+
+(* array_id is an equivalence relation *)
+
+Lemma array_id_refl :
+ forall (n:Z) (A:Set) (t:array n A) (g d:Z), array_id t t g d.
+Proof.
+unfold array_id in |- *.
+auto with datatypes.
+Qed.
+
+Hint Resolve array_id_refl: v62 datatypes.
+
+Lemma array_id_sym :
+ forall (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 in |- *. intros.
+symmetry  in |- *; auto with datatypes.
+Qed.
+
+Hint Resolve array_id_sym: v62 datatypes.
+
+Lemma array_id_trans :
+ forall (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 in |- *. intros.
+apply trans_eq with (y := #t' [i]); auto with datatypes.
+Qed.
+
+Hint Resolve array_id_trans: v62 datatypes.
+
+(* Outside the segment [g,d] the elements are equal *)
+
+Lemma sub_permut_id :
+ forall (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. simple induction 1; intros.
+elim H2; intros.
+unfold array_id in |- *; 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.
+Qed.
+
+Hint Resolve sub_permut_id.
+
+Lemma sub_permut_eq :
+ forall (n:Z) (A:Set) (t t':array n A) (g d:Z),
+   sub_permut g d t t' ->
+   forall i:Z, (0 <= i < g)%Z \/ (d < i < n)%Z -> #t [i] = #t' [i].
+Proof.
+intros n A t t' g d Htt' i Hi.
+elim (sub_permut_id Htt'). unfold array_id in |- *. 
+intros.
+elim Hi; [ intro; apply H; omega | intro; apply H0; omega ].
+Qed.
+
+(* sub_permut is a particular case of permutation *)
+
+Lemma sub_permut_is_permut :
+ forall (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. simple induction 1; intros; eauto with datatypes.
+Qed.
+
+Hint 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 :
+ forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
+   (d < g)%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
+Proof.
+intros N A t t' g g' d d' Hdg.
+simple induction 1; intros.
+absurd (g <= d)%Z; omega.
+auto with datatypes.
+auto with datatypes.
+eauto with datatypes.
+Qed.
+
+(* A sub-permutation on a segment may be extended to any segment that
+ * contains the first one.
+ *)
+
+Lemma sub_permut_extension :
+ forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z),
+   (g' <= g)%Z -> (d <= d')%Z -> sub_permut g d t t' -> sub_permut g' d' t t'.
+Proof.
+intros N A t t' g g' d d' Hgg' Hdd'.
+simple 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.
+Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v
new file mode 100644
index 00000000..1659917a
--- /dev/null
+++ b/contrib/correctness/Arrays.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        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: Arrays.v,v 1.9.2.1 2004/07/16 19:29:59 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 : forall (n:Z) (T:Set), T -> array n T.
+
+Parameter access : forall (n:Z) (T:Set), array n T -> Z -> T.
+
+Parameter store : forall (n:Z) (T:Set), array n T -> Z -> T -> array n T.
+
+
+(* Axioms *)
+
+Axiom
+  new_def :
+    forall (n:Z) (T:Set) (v0:T) (i:Z),
+      (0 <= i < n)%Z -> access (new n v0) i = v0.
+
+Axiom
+  store_def_1 :
+    forall (n:Z) (T:Set) (t:array n T) (v:T) (i:Z),
+      (0 <= i < n)%Z -> access (store t i v) i = v.
+
+Axiom
+  store_def_2 :
+    forall (n:Z) (T:Set) (t:array n T) (v:T) (i j:Z),
+      (0 <= i < n)%Z ->
+      (0 <= j < n)%Z -> i <> j -> access (store t i v) j = access t j.
+
+Hint Resolve new_def store_def_1 store_def_2: datatypes v62.
+
+(* A tactic to simplify access in arrays *)
+
+Ltac array_access 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 at level 0).
\ No newline at end of file
diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v
new file mode 100644
index 00000000..899d7007
--- /dev/null
+++ b/contrib/correctness/Arrays_stuff.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_stuff.v,v 1.2.16.1 2004/07/16 19:29:59 herbelin Exp $ *)
+
+Require Export Exchange.
+Require Export ArrayPermut.
+Require Export Sorted.
+
diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v
new file mode 100644
index 00000000..a2ad2f50
--- /dev/null
+++ b/contrib/correctness/Correctness.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: Correctness.v,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *)
+
+(* 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 "'".
+*)
\ No newline at end of file
diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v
new file mode 100644
index 00000000..7dc5218e
--- /dev/null
+++ b/contrib/correctness/Exchange.v
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+(****************************************************************************)
+(*                   Exchange of two elements in an array                   *)
+(*                        Definition and properties                         *)
+(****************************************************************************)
+
+Require Import ProgInt.
+Require Import 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)%Z ->
+      (0 <= j < n)%Z ->
+      #t [i] = #t' [j] ->
+      #t [j] = #t' [i] ->
+      (forall k:Z, (0 <= k < n)%Z -> k <> i -> k <> j -> #t [k] = #t' [k]) ->
+      exchange t t' i j.
+    
+(* Properties about exchanges *)
+
+Lemma exchange_1 :
+ forall (n:Z) (A:Set) (t:array n A) (i j:Z),
+   (0 <= i < n)%Z ->
+   (0 <= j < n)%Z -> #(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.
+Qed.
+
+Hint Resolve exchange_1: v62 datatypes.
+
+
+Lemma exchange_proof :
+ forall (n:Z) (A:Set) (t:array n A) (i j:Z),
+   (0 <= i < n)%Z ->
+   (0 <= j < n)%Z -> exchange (store (store t i #t [j]) j #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 #t [j]) #t [i] H_j H_k not_j_k).
+auto with datatypes.
+Qed.
+
+Hint Resolve exchange_proof: v62 datatypes.
+
+
+Lemma exchange_sym :
+ forall (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.
+Qed.
+
+Hint Resolve exchange_sym: v62 datatypes.
+
+
+Lemma exchange_id :
+ forall (n:Z) (A:Set) (t t':array n A) (i j:Z),
+   exchange t t' i j ->
+   i = j -> forall k:Z, (0 <= k < n)%Z -> #t [k] = #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.
+Qed.
+
+Hint Resolve exchange_id: v62 datatypes.
\ No newline at end of file
diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v
new file mode 100644
index 00000000..bce19870
--- /dev/null
+++ b/contrib/correctness/ProgBool.v
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+Require Import ZArith.
+Require Export Bool_nat.
+Require Export Sumbool.
+
+Definition annot_bool :
+  forall b:bool, {b' : bool | if b' then b = true else b = false}.
+Proof.
+intro b.
+exists b. case b; trivial.
+Qed.
+
+
+(* Logical connectives *)
+
+Definition spec_and (A B C D:Prop) (b:bool) := if b then A /\ C else B \/ D.
+
+Definition prog_bool_and :
+  forall Q1 Q2:bool -> Prop,
+    sig Q1 ->
+    sig 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.
+Qed.
+
+Definition spec_or (A B C D:Prop) (b:bool) := if b then A \/ C else B /\ D.
+
+Definition prog_bool_or :
+  forall Q1 Q2:bool -> Prop,
+    sig Q1 ->
+    sig 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.
+Qed.
+
+Definition spec_not (A B:Prop) (b:bool) := if b then B else A.
+
+Definition prog_bool_not :
+  forall Q:bool -> Prop, sig 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.
+Qed.
diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v
new file mode 100644
index 00000000..c26e3553
--- /dev/null
+++ b/contrib/correctness/ProgInt.v
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: ProgInt.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+Require Export ZArith.
+Require Export ZArith_dec.
+
+Theorem Znotzero : forall x:Z, {x <> 0%Z} + {x = 0%Z}.
+Proof.
+intro x. elim (Z_eq_dec x 0); auto.
+Qed.
\ No newline at end of file
diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
new file mode 100644
index 00000000..40253f33
--- /dev/null
+++ b/contrib/correctness/ProgramsExtraction.v
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2.16.1 2004/07/16 19:30:00 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/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v
new file mode 100644
index 00000000..1ca4b63e
--- /dev/null
+++ b/contrib/correctness/Programs_stuff.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Programs_stuff.v,v 1.1.16.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+Require Export Arrays_stuff.
diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v
new file mode 100644
index 00000000..2efe54a4
--- /dev/null
+++ b/contrib/correctness/Sorted.v
@@ -0,0 +1,202 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+Require Export Arrays.
+Require Import ArrayPermut.
+
+Require Import ZArithRing.
+Require Import Omega.
+Open Local Scope Z_scope.
+
+Set Implicit Arguments.
+
+(* Definition *)
+
+Definition sorted_array (N:Z) (A:array N Z) (deb fin:Z) :=
+  deb <= fin -> forall x:Z, x >= deb -> x < fin -> #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 :
+ forall (N:Z) (A:array N Z) (n m:Z),
+   sorted_array A n m ->
+   forall k:Z,
+     k >= n -> forall i:Z, 0 <= i -> k + i <= m -> #A [k] <= #A [k + i].
+Proof.
+intros N A n m H_sorted k H_k i H_i.
+pattern i in |- *. apply natlike_ind.
+intro.
+replace (k + 0) with k; omega. (*** Ring `k+0` => BUG ***)
+
+intros.
+apply Zle_trans with (m := #A [k + x]).
+apply H0; omega.
+
+unfold Zsucc in |- *.
+replace (k + (x + 1)) with (k + x + 1).
+unfold sorted_array in H_sorted.
+apply H_sorted; omega.
+
+omega.
+
+assumption.
+Qed.
+
+(* one element and any of the following *)
+
+Lemma sorted_elements :
+ forall (N:Z) (A:array N Z) (n m k l:Z),
+   sorted_array A n m ->
+   k >= n -> l < N -> k <= l -> l <= m -> #A [k] <= #A [l].
+Proof.
+intros.
+replace l with (k + (l - k)).
+apply sorted_elements_1 with (n := n) (m := m);
+ [ assumption | omega | omega | omega ].
+omega.
+Qed.
+
+Hint Resolve sorted_elements: datatypes v62.
+
+(* A sub-array of a sorted array is sorted *)
+
+Lemma sub_sorted_array :
+ forall (N:Z) (A:array N Z) (deb fin i j:Z),
+   sorted_array A deb fin ->
+   i >= deb -> j <= fin -> i <= j -> sorted_array A i j.
+Proof.
+unfold sorted_array in |- *.
+intros.
+apply H; omega.
+Qed.
+
+Hint Resolve sub_sorted_array: datatypes v62.
+
+(* Extension on the left of the property of being sorted *)
+
+Lemma left_extension :
+ forall (N:Z) (A:array N Z) (i j:Z),
+   i > 0 ->
+   j < N ->
+   sorted_array A i j -> #A [i - 1] <= #A [i] -> sorted_array A (i - 1) j.
+Proof.
+intros; unfold sorted_array in |- *; 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.
+Qed.
+
+(* Extension on the right *)
+
+Lemma right_extension :
+ forall (N:Z) (A:array N Z) (i j:Z),
+   i >= 0 ->
+   j < N - 1 ->
+   sorted_array A i j -> #A [j] <= #A [j + 1] -> sorted_array A i (j + 1).
+Proof.
+intros; unfold sorted_array in |- *; intros.
+elim (Z_lt_ge_dec x j).
+intro Hcut. 
+apply H1; omega.
+
+intro HCut.
+replace x with j; [ assumption | omega ].
+Qed.
+
+(* Substitution of the leftmost value by a smaller value *) 
+
+Lemma left_substitution :
+ forall (N:Z) (A:array N Z) (i j v:Z),
+   i >= 0 ->
+   j < N ->
+   sorted_array A i j -> 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 in |- *; 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 := #A [i]); [ assumption | apply H_sorted; omega ].
+
+rewrite store_def_2; try omega.
+rewrite store_def_2; try omega.
+apply H_sorted; omega.
+omega.
+Qed.
+
+(* Substitution of the rightmost value by a larger value *)
+
+Lemma right_substitution :
+ forall (N:Z) (A:array N Z) (i j v:Z),
+   i >= 0 ->
+   j < N ->
+   sorted_array A i j -> #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 in |- *; 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 := #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.
+Qed.
+
+(* Affectation outside of the sorted region *)
+
+Lemma no_effect :
+ forall (N:Z) (A:array N Z) (i j k 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 in |- *; intros. 
+rewrite store_def_2; try omega.
+rewrite store_def_2; try omega.
+apply H1; assumption.
+Qed.
+
+Lemma sorted_array_id :
+ forall (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 in |- *.
+intros Hgd x H1x H2x.
+rewrite <- (Hid x); [ idtac | omega ].
+rewrite <- (Hid (x + 1)); [ idtac | omega ].
+apply Hsorted; assumption.
+Qed.
\ No newline at end of file
diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v
new file mode 100644
index 00000000..e3fff08d
--- /dev/null
+++ b/contrib/correctness/Tuples.v
@@ -0,0 +1,98 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2.2.1 2004/07/16 19:30:00 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 : forall (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 : forall (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 :
+      forall (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 :
+      forall (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 :
+      forall (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 :
+      forall (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 :
+      forall (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 :
+      forall (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 :
+      forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> dep_tuple_3 T1 T2 T3 P.
+
diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v
new file mode 100644
index 00000000..8c983a72
--- /dev/null
+++ b/contrib/correctness/examples/Handbook.v
@@ -0,0 +1,232 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: Handbook.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+
+(* This file contains proofs of programs taken from the
+ * "Handbook of Theoretical Computer Science", volume B,
+ * chapter "Methods and Logics for Proving Programs", by P. Cousot,
+ * pp 841--993, Edited by J. van Leeuwen (c) Elsevier Science Publishers B.V.
+ * 1990.
+ * 
+ * Programs are refered to by numbers and pages.
+ *)
+
+Require Correctness.
+
+Require Sumbool.
+Require Omega.
+Require Zcomplements.
+Require Zpower.
+
+(****************************************************************************)
+
+(* program (2) page 853 to compute x^y (annotated version is (25) page 860) *)
+
+(* en attendant... *)
+Parameter Zdiv2  : Z->Z.
+
+Parameter Zeven_odd_dec : (x:Z){`x=2*(Zdiv2 x)`}+{`x=2*(Zdiv2 x)+1`}.
+Definition Zodd_dec := [z:Z](sumbool_not ? ? (Zeven_odd_dec z)).
+Definition Zodd_bool := [z:Z](bool_of_sumbool ? ? (Zodd_dec z)).
+
+Axiom axiom1 : (x,y:Z) `y>0` -> `x*(Zpower x (Zpred y)) = (Zpower x y)`.
+Axiom axiom2 : (x:Z)`x>0` -> `(Zdiv2 x)<x`.
+Axiom axiom3 : (x,y:Z) `y>=0` -> `(Zpower (x*x) (Zdiv2 y)) = (Zpower x y)`.
+
+Global Variable X : Z ref.
+Global Variable Y : Z ref.
+Global Variable Z_ : Z ref.
+
+Correctness pgm25
+  { `Y >= 0` }
+  begin
+    Z_ := 1;
+    while !Y <> 0 do
+      { invariant `Y >= 0` /\ `Z_ * (Zpower X Y) = (Zpower X@0 Y@0)`
+        variant Y }
+      if (Zodd_bool !Y) then begin
+      	Y := (Zpred !Y);
+	Z_ := (Zmult !Z_ !X)
+      end else begin
+      	Y := (Zdiv2 !Y);	
+	X := (Zmult !X !X)
+      end
+    done
+  end
+  { Z_ = (Zpower X@ Y@) }.
+Proof.
+Split.
+Unfold Zpred; Unfold Zwf; Omega.
+Split.
+Unfold Zpred; Omega.
+Decompose [and] Pre2.
+Rewrite <- H0.
+Replace `Z_1*X0*(Zpower X0 (Zpred Y0))` with `Z_1*(X0*(Zpower X0 (Zpred Y0)))`.
+Apply f_equal with f := (Zmult Z_1).
+Apply axiom1.
+Omega.
+
+Auto.
+Symmetry.
+Apply Zmult_assoc_r.
+
+Split.
+Unfold Zwf.
+Repeat (Apply conj).
+Omega.
+
+Omega.
+
+Apply axiom2. Omega.
+
+Split.
+Omega.
+
+Decompose [and] Pre2.
+Rewrite <- H0.
+Apply f_equal with f:=(Zmult Z_1).
+Apply axiom3. Omega.
+
+Omega.
+
+Decompose [and] Post6.
+Rewrite <- H2.
+Rewrite H0.
+Simpl.
+Omega.
+
+Save.
+
+
+(****************************************************************************)
+
+(* program (178) page 934 to compute the factorial using global variables
+ * annotated version is (185) page 939
+ *)
+
+Parameter Zfact : Z -> Z.
+
+Axiom axiom4 : `(Zfact 0) = 1`.
+Axiom axiom5 : (x:Z) `x>0` -> `(Zfact (x-1))*x=(Zfact x)`.
+
+Correctness pgm178
+let rec F (u:unit) : unit { variant X } =
+  { `X>=0` }
+  (if !X = 0 then
+    Y := 1
+  else begin
+    label L;
+    X := (Zpred !X);
+    (F tt);
+    X := (Zs !X);
+    Y := (Zmult !Y !X)
+  end)
+  { `X=X@` /\ `Y=(Zfact X@)` }.
+Proof.
+Rewrite Test1. Rewrite axiom4. Auto.
+Unfold Zwf. Unfold Zpred. Omega.
+Unfold Zpred. Omega.
+Unfold Zs. Unfold Zpred in Post3. Split.
+Omega.
+Decompose [and] Post3.
+Rewrite H.
+Replace `X0+(-1)+1` with X0.
+Rewrite H0.
+Replace `X0+(-1)` with `X0-1`.
+Apply axiom5.
+Omega.
+Omega.
+Omega.
+Save.
+
+
+(****************************************************************************)
+
+(* program (186) page 939 "showing the usefulness of auxiliary variables" ! *)
+
+Global Variable N : Z ref.
+Global Variable S : Z ref.
+
+Correctness pgm186
+let rec F (u:unit) : unit { variant N } =
+  { `N>=0` }
+  (if !N > 0 then begin
+    label L;
+    N := (Zpred !N);
+    (F tt);
+    S := (Zs !S);
+    (F tt);
+    N := (Zs !N)
+  end)
+  { `N=N@` /\ `S=S@+(Zpower 2 N@)-1` }.
+Proof.
+Unfold Zwf. Unfold Zpred. Omega.
+Unfold Zpred. Omega.
+Decompose [and] Post5. Rewrite H. Unfold Zwf. Unfold Zpred. Omega.
+Decompose [and] Post5. Rewrite H. Unfold Zpred. Omega.
+Split.
+Unfold Zpred in Post5. Omega.
+Decompose [and] Post4. Rewrite H0. 
+Decompose [and] Post5. Rewrite H2. Rewrite H1. 
+Replace `(Zpower 2 N0)` with `2*(Zpower 2 (Zpred N0))`. Omega.
+Symmetry.
+Replace `(Zpower 2 N0)` with `(Zpower 2 (1+(Zpred N0)))`.
+Replace `2*(Zpower 2 (Zpred N0))` with `(Zpower 2 1)*(Zpower 2 (Zpred N0))`.
+Apply Zpower_exp.
+Omega.
+Unfold Zpred. Omega.
+Auto.
+Replace `(1+(Zpred N0))` with N0; [ Auto | Unfold Zpred; Omega ].
+Split.
+Auto.
+Replace N0 with `0`; Simpl; Omega.
+Save.
+
+
+(****************************************************************************)
+
+(* program (196) page 944 (recursive factorial procedure with value-result
+ * parameters)
+ *)
+
+Correctness pgm196
+let rec F (U:Z) (V:Z ref) : unit { variant U } =
+  { `U >= 0` }
+  (if U = 0 then
+    V := 1
+  else begin
+    (F (Zpred U) V);	
+    V := (Zmult !V U)
+  end)
+  { `V = (Zfact U)` }.
+Proof.
+Symmetry. Rewrite Test1. Apply axiom4.
+Unfold Zwf. Unfold Zpred. Omega.
+Unfold Zpred. Omega.
+Rewrite Post3. 
+Unfold Zpred. Replace `U0+(-1)` with `U0-1`. Apply axiom5.
+Omega.
+Omega.
+Save.
+
+(****************************************************************************)
+
+(* program (197) page 945 (L_4 subset of Pascal) *)
+
+(*
+procedure P(X:Z; procedure Q(Z:Z));
+  procedure L(X:Z); begin Q(X-1) end;
+  begin if X>0 then P(X-1,L) else Q(X) end;
+
+procedure M(N:Z);
+  procedure R(X:Z); begin writeln(X) (* => RES := !X *) end;
+  begin P(N,R) end.
+*)
diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v
new file mode 100644
index 00000000..dcfcec87
--- /dev/null
+++ b/contrib/correctness/examples/exp.v
@@ -0,0 +1,204 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(*i $Id: exp.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ i*)
+
+(* Efficient computation of X^n using
+ * 
+ *    X^(2n)   =     (X^n) ^ 2
+ *    X^(2n+1) = X . (X^n) ^ 2
+ *
+ * Proofs of both fonctional and imperative programs.
+ *)
+
+Require Even.
+Require Div2.
+Require Correctness.
+Require ArithRing.
+Require ZArithRing.
+
+(* The specification uses the traditional definition of X^n *)
+
+Fixpoint power [x,n:nat] : nat :=
+  Cases n of
+    O      => (S O)
+  | (S n') => (mult x (power x n'))
+  end.
+
+Definition square := [n:nat](mult n n).
+
+
+(* Three lemmas are necessary to establish the forthcoming proof obligations *)
+
+(* n = 2*(n/2) => (x^(n/2))^2 = x^n *)
+
+Lemma exp_div2_0 : (x,n:nat)
+     n=(double (div2 n)) 
+  -> (square (power x (div2 n)))=(power x n).
+Proof.
+Unfold square.
+Intros x n. Pattern n. Apply ind_0_1_SS.
+Auto.
+
+Intro. (Absurd (1)=(double (0)); Auto).
+
+Intros. Simpl.
+Cut n0=(double (div2 n0)).
+Intro. Rewrite <- (H H1).
+Ring.
+
+Simpl in H0.
+Unfold double in H0.
+Simpl in H0.
+Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
+(Injection H0; Auto).
+Save.
+
+(* n = 2*(n/2)+1 => x*(x^(n/2))^2 = x^n *)
+
+Lemma exp_div2_1 : (x,n:nat) 
+     n=(S (double (div2 n)))
+  -> (mult x (square (power x (div2 n))))=(power x n).
+Proof.
+Unfold square.
+Intros x n. Pattern n. Apply ind_0_1_SS.
+
+Intro. (Absurd (0)=(S (double (0))); Auto).
+
+Auto.
+
+Intros. Simpl.
+Cut n0=(S (double (div2 n0))).
+Intro. Rewrite <- (H H1).
+Ring.
+
+Simpl in H0.
+Unfold double in H0.
+Simpl in H0.
+Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0.
+(Injection H0; Auto).
+Save.
+
+(* x^(2*n) = (x^2)^n *)
+
+Lemma power_2n : (x,n:nat)(power x (double n))=(power (square x) n).
+Proof.
+Unfold double. Unfold square.
+Induction n.
+Auto.
+
+Intros.
+Simpl.
+Rewrite <- H.
+Rewrite <- (plus_n_Sm n0 n0).
+Simpl.
+Auto with arith.
+Save.
+
+Hints Resolve exp_div2_0 exp_div2_1.
+
+
+(* Functional version.
+ * 
+ * Here we give the functional program as an incomplete CIC term,
+ * using the tactic Refine.
+ *
+ * On this example, it really behaves as the tactic Program.
+ *)
+
+(*
+Lemma f_exp : (x,n:nat) { y:nat | y=(power x n) }.
+Proof.
+Refine [x:nat]
+  (well_founded_induction nat lt lt_wf
+    [n:nat]{y:nat | y=(power x n) }
+    [n:nat]
+    [f:(p:nat)(lt p n)->{y:nat | y=(power x p) }]
+      	     Cases (zerop n) of 
+               (left _) => (exist ? ? (S O) ?)
+      	     | (right _) => 
+      	       	  let (y,H) = (f (div2 n) ?) in 
+      	       	  Cases (even_odd_dec n) of
+      	       	    (left _) => (exist ? ? (mult y y) ?)
+                  | (right _) => (exist ? ? (mult x (mult y y)) ?)
+		  end
+	     end).
+Proof.
+Rewrite a. Auto.
+Exact (lt_div2 n a).
+Change (square y)=(power x n). Rewrite H. Auto with arith.
+Change (mult x (square y))=(power x n). Rewrite H. Auto with arith.
+Save.
+*)
+
+(* Imperative version. *)
+
+Definition even_odd_bool := [x:nat](bool_of_sumbool ? ? (even_odd_dec x)).
+
+Correctness i_exp
+  fun (x:nat)(n:nat) ->
+    let y = ref (S O) in
+    let m = ref x in
+    let e = ref n in
+    begin
+      while (notzerop_bool !e) do
+        { invariant (power x n)=(mult y (power m e)) as Inv
+          variant e for lt }
+        (if not (even_odd_bool !e) then y := (mult !y !m))
+          { (power x n) = (mult y (power m (double (div2 e)))) as Q };
+        m := (square !m);
+        e := (div2 !e)
+      done;
+      !y
+    end
+    { result=(power x n) }
+.
+Proof.
+Rewrite (odd_double e0 Test1) in Inv. Rewrite Inv. Simpl. Auto with arith.
+
+Rewrite (even_double e0 Test1) in Inv. Rewrite Inv. Reflexivity.
+
+Split.
+Exact (lt_div2 e0 Test2).
+
+Rewrite Q. Unfold double. Unfold square.
+Simpl. 
+Change (mult y1 (power m0 (double (div2 e0))))
+     = (mult y1 (power (square m0) (div2 e0))).
+Rewrite (power_2n m0 (div2 e0)). Reflexivity.
+
+Auto with arith.
+
+Decompose [and] Inv.
+Rewrite H. Rewrite H0.
+Auto with arith.
+Save.
+
+
+(* Recursive version. *)
+
+Correctness r_exp
+  let rec exp (x:nat) (n:nat) : nat { variant n for lt} =
+    (if (zerop_bool n) then
+       (S O)
+     else
+       let y = (exp x (div2 n)) in
+       if (even_odd_bool n) then
+         (mult y y)
+       else
+         (mult x (mult y y))
+    ) { result=(power x n) }
+.
+Proof.
+Rewrite Test2. Auto.
+Exact (lt_div2 n0 Test2).
+Change (square y)=(power x0 n0). Rewrite Post7. Auto with arith.
+Change (mult x0 (square y))=(power x0 n0). Rewrite Post7. Auto with arith.
+Save.
diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v
new file mode 100644
index 00000000..accd60c2
--- /dev/null
+++ b/contrib/correctness/examples/exp_int.v
@@ -0,0 +1,218 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: exp_int.v,v 1.4 2001/04/11 07:56:19 filliatr Exp $ *)
+
+(* Efficient computation of X^n using
+ * 
+ *    X^(2n)   =     (X^n) ^ 2
+ *    X^(2n+1) = X . (X^n) ^ 2
+ *
+ * Proofs of both fonctional and imperative programs.
+ *)
+
+Require Zpower.
+Require Zcomplements.
+
+Require Correctness.
+Require ZArithRing.
+Require Omega.
+
+Definition Zdouble := [n:Z]`2*n`.
+
+Definition Zsquare := [n:Z](Zmult n n).
+
+(* Some auxiliary lemmas about Zdiv2 are necessary *)
+
+Lemma Zdiv2_ge_0 : (x:Z) `x >= 0` -> `(Zdiv2 x) >= 0`.
+Proof.
+Destruct x; Auto with zarith.
+Destruct p; Auto with zarith.
+Simpl. Omega.
+Intros. (Absurd `(NEG p) >= 0`; Red; Auto with zarith).
+Save.
+
+Lemma Zdiv2_lt : (x:Z) `x > 0` -> `(Zdiv2 x) < x`.
+Proof.
+Destruct x.
+Intro. Absurd `0 > 0`; [ Omega | Assumption ].
+Destruct p; Auto with zarith.
+
+Simpl.
+Intro p0.
+Replace (POS (xI p0)) with `2*(POS p0)+1`.
+Omega.
+Simpl. Auto with zarith.
+
+Intro p0.
+Simpl.
+Replace (POS (xO p0)) with `2*(POS p0)`.
+Omega.
+Simpl. Auto with zarith.
+
+Simpl. Omega.
+
+Intros. 
+Absurd `(NEG p) > 0`; Red; Auto with zarith.
+Elim p; Auto with zarith.
+Omega.
+Save.
+
+(* A property of Zpower:  x^(2*n) = (x^2)^n *)
+
+Lemma Zpower_2n : 
+  (x,n:Z)`n >= 0` -> (Zpower x (Zdouble n))=(Zpower (Zsquare x) n).
+Proof.
+Unfold Zdouble.
+Intros x n Hn.
+Replace `2*n` with `n+n`.
+Rewrite Zpower_exp.
+Pattern n.
+Apply natlike_ind.
+
+Simpl. Auto with zarith.
+
+Intros.
+Unfold Zs.
+Rewrite Zpower_exp.
+Rewrite Zpower_exp.
+Replace (Zpower x `1`) with x.
+Replace (Zpower (Zsquare x) `1`) with (Zsquare x).
+Rewrite <- H0.
+Unfold Zsquare.
+Ring.
+
+Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
+
+Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
+
+Omega.
+Omega.
+Omega.
+Omega.
+Omega.
+Assumption.
+Assumption.
+Omega.
+Save.
+
+
+(* The program *)
+
+Correctness i_exp
+  fun (x:Z)(n:Z) ->
+    { `n >= 0` }
+   (let y = ref 1 in
+    let m = ref x in
+    let e = ref n in
+    begin
+      while !e > 0 do
+        { invariant (Zpower x n)=(Zmult y (Zpower m e)) /\ `e>=0` as Inv
+          variant e }
+        (if not (Zeven_odd_bool !e) then y := (Zmult !y !m))
+          { (Zpower x n) = (Zmult y (Zpower m (Zdouble (Zdiv2 e)))) as Q };
+        m := (Zsquare !m);
+        e := (Zdiv2 !e)
+      done;
+      !y
+    end)
+    { result=(Zpower x n) }
+.
+Proof.
+(* Zodd *)
+Decompose [and] Inv.
+Rewrite (Zodd_div2 e0 H0 Test1) in H. Rewrite H.
+Rewrite Zpower_exp.
+Unfold Zdouble.
+Replace (Zpower m0 `1`) with m0.
+Ring.
+Unfold Zpower; Unfold Zpower_pos; Simpl; Ring.
+Generalize (Zdiv2_ge_0 e0); Omega.
+Omega.
+(* Zeven *)
+Decompose [and] Inv.
+Rewrite (Zeven_div2 e0 Test1) in H. Rewrite H.
+Auto with zarith.
+Split.
+(* Zwf *)
+Unfold Zwf.
+Repeat Split.
+Generalize (Zdiv2_ge_0 e0); Omega.
+Omega.
+Exact (Zdiv2_lt e0 Test2).
+(* invariant *)
+Split.
+Rewrite Q. Unfold Zdouble. Unfold Zsquare.
+Rewrite (Zpower_2n).
+Trivial.
+Generalize (Zdiv2_ge_0 e0); Omega.
+Generalize (Zdiv2_ge_0 e0); Omega.
+Split; [ Ring | Assumption ].
+(* exit fo loop *)
+Decompose [and] Inv.
+Cut `e0 = 0`. Intro.
+Rewrite H1. Rewrite H.
+Simpl; Ring.
+Omega.
+Save.
+
+
+(* Recursive version. *)
+
+Correctness r_exp
+  let rec exp (x:Z) (n:Z) : Z { variant n } =
+    { `n >= 0` }
+    (if n = 0 then
+       1
+     else
+       let y = (exp x (Zdiv2 n)) in
+       (if (Zeven_odd_bool n) then
+       	  (Zmult y y)
+        else
+          (Zmult x (Zmult y y))) { result=(Zpower x n) as Q }
+    ) 
+    { result=(Zpower x n) }
+.
+Proof.
+Rewrite Test2. Auto with zarith.
+(* w.f. *)
+Unfold Zwf.
+Repeat Split.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Omega.
+Generalize (Zdiv2_lt n0) ; Omega.
+(* rec. call *)
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+(* invariant: case even *)
+Generalize (Zeven_div2 n0 Test1).
+Intro Heq. Rewrite Heq.
+Rewrite Post4.
+Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
+Rewrite Zpower_exp.
+Auto with zarith.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Omega.
+(* invariant: cas odd *)
+Generalize (Zodd_div2 n0 Pre1 Test1).
+Intro Heq. Rewrite Heq.
+Rewrite Post4.
+Rewrite Zpower_exp.
+Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`.
+Rewrite Zpower_exp.
+Replace `(Zpower x0 1)` with x0.
+Ring.
+Unfold Zpower; Unfold Zpower_pos; Simpl. Omega.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Omega.
+Generalize (Zdiv2_ge_0 n0) ; Omega.
+Omega.
+Save.
diff --git a/contrib/correctness/examples/extract.v b/contrib/correctness/examples/extract.v
new file mode 100644
index 00000000..e225ba18
--- /dev/null
+++ b/contrib/correctness/examples/extract.v
@@ -0,0 +1,43 @@
+
+(* Tests d'extraction *)
+
+Require ProgramsExtraction.
+Save State Ici "test extraction".
+
+(* exp *)
+
+Require exp.
+Write Caml File "exp" [ i_exp r_exp ].
+
+(* exp_int *)
+
+Restore State Ici.
+Require exp_int.
+Write Caml File "exp_int" [ i_exp r_exp ].
+
+(* fact *)
+
+Restore State Ici.
+Require fact.
+Initialize x with (S (S (S O))).
+Initialize y with O.
+Write Caml File "fact" [ factorielle ].
+
+(* fact_int *)
+
+Restore State Ici.
+Require fact_int.
+Initialize x with `3`.
+Initialize y with `0`.
+Write Caml File "fact_int" [ factorielle ].
+
+(* Handbook *)
+
+Restore State Ici.
+Require Handbook.
+Initialize X with `3`.
+Initialize Y with `3`.
+Initialize Z with `3`.
+Initialize N with `3`.
+Initialize S with `3`.
+Write Caml File "Handbook" [ pgm178 pgm186 pgm196 ].
diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v
new file mode 100644
index 00000000..e480c806
--- /dev/null
+++ b/contrib/correctness/examples/fact.v
@@ -0,0 +1,69 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: fact.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+
+(* Proof of an imperative program computing the factorial (over type nat) *)
+
+Require Correctness.
+Require Omega.
+Require Arith.
+
+Fixpoint fact [n:nat] : nat :=
+  Cases n of
+    O     => (S O)
+  | (S p) => (mult n (fact p))
+  end.
+
+(* (x * y) * (x-1)! = y * x!  *)
+
+Lemma fact_rec : (x,y:nat)(lt O x) ->
+  (mult (mult x y) (fact (pred x))) = (mult y (fact x)).
+Proof.
+Intros x y H.
+Generalize (mult_sym x y). Intro H1. Rewrite H1.
+Generalize (mult_assoc_r y x (fact (pred x))). Intro H2. Rewrite H2.
+Apply (f_equal nat nat [x:nat](mult y x)).
+Generalize H. Elim x; Auto with arith.
+Save.
+
+
+(* we declare two variables x and y *)
+
+Global Variable x : nat ref.
+Global Variable y : nat ref.
+
+(* we give the annotated program *)
+
+Correctness factorielle 
+  begin
+    y := (S O);
+    while (notzerop_bool !x) do
+      { invariant (mult y (fact x)) = (fact x@0) as I
+        variant x for lt }
+      y := (mult !x !y);
+      x := (pred !x)
+    done
+  end
+  { y = (fact x@0) }.
+Proof.
+Split.
+(* decreasing of the variant *)
+Omega.
+(* preservation of the invariant *)
+Rewrite <- I. Exact (fact_rec x0 y1 Test1).
+(* entrance of loop *)
+Auto with arith.
+(* exit of loop *)
+Elim I. Intros H1 H2.
+Rewrite H2 in H1.
+Rewrite <- H1.
+Auto with arith.
+Save.
diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v
new file mode 100644
index 00000000..cb2b0460
--- /dev/null
+++ b/contrib/correctness/examples/fact_int.v
@@ -0,0 +1,195 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: fact_int.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *)
+
+(* Proof of an imperative program computing the factorial (over type Z) *)
+
+Require Correctness.
+Require Omega.
+Require ZArithRing.
+
+(* We define the factorial as a relation... *)
+
+Inductive fact : Z -> Z -> Prop :=
+    fact_0 : (fact `0` `1`)
+  | fact_S : (z,f:Z) (fact z f) -> (fact (Zs z) (Zmult (Zs z) f)).
+
+(* ...and then we prove that it contains a function *)
+
+Lemma fact_function : (z:Z) `0 <= z` -> (EX f:Z | (fact z f)).
+Proof.
+Intros.
+Apply natlike_ind with P:=[z:Z](EX f:Z | (fact z f)).
+Split with `1`.
+Exact fact_0.
+
+Intros.
+Elim H1.
+Intros.
+Split with `(Zs x)*x0`.
+Exact (fact_S x x0 H2).
+
+Assumption.
+Save.
+
+(* This lemma should belong to the ZArith library *)
+
+Lemma Z_mult_1 : (x,y:Z)`x>=1`->`y>=1`->`x*y>=1`.
+Proof.
+Intros.
+Generalize H.
+Apply natlike_ind with P:=[x:Z]`x >= 1`->`x*y >= 1`.
+Omega.
+
+Intros.
+Simpl.
+Elim (Z_le_lt_eq_dec `0` x0 H1).
+Simpl.
+Unfold Zs.
+Replace `(x0+1)*y` with `x0*y+y`.
+Generalize H2.
+Generalize `x0*y`.
+Intro.
+Intros.
+Omega.
+
+Ring.
+
+Intros.
+Rewrite <- b.
+Omega.
+
+Omega.
+Save.
+
+(* (fact x f) implies x>=0 and f>=1 *)
+
+Lemma fact_pos : (x,f:Z)(fact x f)-> `x>=0` /\ `f>=1`.
+Proof.
+Intros.
+(Elim H; Auto).
+Omega.
+
+Intros.
+(Split; Try Omega).
+(Apply Z_mult_1; Try Omega).
+Save.
+
+(* (fact 0 x) implies x=1 *)
+
+Lemma fact_0_1 : (x:Z)(fact `0` x) -> `x=1`.
+Proof.
+Intros.
+Inversion H.
+Reflexivity.
+
+Elim (fact_pos z f H1).
+Intros.
+(Absurd `z >= 0`; Omega).
+Save.
+
+
+(* We define the loop invariant : y * x! = x0! *)
+
+Inductive invariant [y,x,x0:Z] : Prop :=
+  c_inv : (f,f0:Z)(fact x f)->(fact x0 f0)->(Zmult y f)=f0
+       -> (invariant y x x0).
+
+(* The following lemma is used to prove the preservation of the invariant *)
+
+Lemma fact_rec : (x0,x,y:Z)`0 < x` ->
+    (invariant y x x0) 
+ -> (invariant `x*y` (Zpred x) x0).
+Proof.
+Intros x0 x y H H0.
+Elim H0.
+Intros.
+Generalize H H0 H3.
+Elim H1.
+Intros.
+Absurd `0 < 0`; Omega.
+
+Intros.
+Apply c_inv with f:=f1 f0:=f0.
+Cut `z+1+-1 = z`. Intro eq_z. Rewrite <- eq_z in H4.
+Assumption.
+
+Omega.
+
+Assumption.
+
+Rewrite (Zmult_sym (Zs z) y).                     
+Rewrite (Zmult_assoc_r y (Zs z) f1).
+Auto.
+Save.
+
+
+(* This one is used to prove the proof obligation at the exit of the loop *)
+
+Lemma invariant_0 : (x,y:Z)(invariant y `0` x)->(fact x y).
+Proof.
+Intros.
+Elim H.
+Intros.
+Generalize (fact_0_1 f H0).
+Intro.
+Rewrite H3 in H2.
+Simpl in H2.
+Replace y with `y*1`.
+Rewrite H2.
+Assumption.
+
+Omega.
+Save.
+
+
+(* At last we come to the proof itself *************************************)
+
+(* we declare two variable x and y *)
+
+Global Variable x : Z ref.
+Global Variable y : Z ref.
+
+(* and we give the annotated program *)
+
+Correctness factorielle 
+  { `0 <= x` }
+  begin
+    y := 1;
+    while !x <> 0 do
+      { invariant `0 <= x` /\ (invariant y x x@0) as Inv
+        variant x for (Zwf ZERO) }
+      y := (Zmult !x !y);
+      x := (Zpred !x)
+    done
+  end
+  { (fact x@0 y) }.
+Proof.
+Split.
+(* decreasing *)
+Unfold Zwf. Unfold Zpred. Omega.
+(* preservation of the invariant *)
+Split.
+  Unfold Zpred; Omega.
+  Cut `0 < x0`. Intro Hx0.
+  Decompose [and] Inv.
+  Exact (fact_rec x x0 y1 Hx0 H0).
+  Omega.
+(* entrance of the loop *)
+Split; Auto.
+Elim (fact_function x Pre1). Intros.
+Apply c_inv with f:=x0 f0:=x0; Auto.
+Omega.
+(* exit of the loop *)
+Decompose [and] Inv.
+Rewrite H0 in H2.
+Exact (invariant_0 x y1 H2).
+Save.
diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli
new file mode 100644
index 00000000..1cc7164e
--- /dev/null
+++ b/contrib/correctness/past.mli
@@ -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        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: past.mli,v 1.7.6.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+(*s Abstract syntax of imperative programs. *)
+
+open Names
+open Ptype
+open Topconstr
+
+type termination = 
+  | RecArg of int 
+  | Wf of constr_expr * constr_expr
+
+type variable = identifier
+
+type pattern =
+  | PatVar of identifier
+  | PatConstruct of identifier * ((kernel_name * int) * int)
+  | PatAlias of pattern * identifier
+  | PatPair of pattern * pattern
+  | PatApp of pattern list
+
+type epattern =
+  | ExnConstant of identifier
+  | ExnBind of identifier * identifier
+
+type ('a, 'b) block_st =
+  | Label of string
+  | Assert of 'b Ptype.assertion
+  | Statement of 'a
+
+type ('a, 'b) block = ('a, 'b) block_st list
+
+type ('a, 'b) t = { 
+  desc : ('a, 'b) t_desc;
+  pre  : 'b Ptype.precondition list;
+  post : 'b Ptype.postcondition option;
+  loc  : Util.loc;
+  info : 'a 
+}
+
+and ('a, 'b) t_desc =
+  | Variable of variable
+  | Acc of variable
+  | Aff of variable * ('a, 'b) t
+  | TabAcc of bool * variable * ('a, 'b) t
+  | TabAff of bool * variable * ('a, 'b) t * ('a, 'b) t
+  | Seq of (('a, 'b) t, 'b) block
+  | While of ('a, 'b) t * 'b Ptype.assertion option * ('b * 'b) *
+               (('a, 'b) t, 'b) block
+  | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t
+  | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t
+  | Apply of ('a, 'b) t * ('a, 'b) arg list
+  | SApp of ('a, 'b) t_desc list * ('a, 'b) t list
+  | LetRef of variable * ('a, 'b) t * ('a, 'b) t
+  | Let of variable * ('a, 'b) t * ('a, 'b) t
+  | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list *
+                'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t
+  | PPoint of string * ('a, 'b) t_desc
+  | Expression of Term.constr
+  | Debug of string * ('a, 'b) t
+
+and ('a, 'b) arg =
+  | Term of ('a, 'b) t
+  | Refarg of variable
+  | Type of 'b Ptype.ml_type_v
+
+type program = (unit, Topconstr.constr_expr) t
+
+(*s Intermediate type for CC terms. *)
+
+type cc_type = Term.constr
+
+type cc_bind_type = 
+  | CC_typed_binder of cc_type 
+  | CC_untyped_binder
+
+type cc_binder = variable * cc_bind_type
+
+type cc_term =
+  | CC_var of variable
+  | CC_letin of bool * cc_type * cc_binder list * cc_term * cc_term
+  | CC_lam of cc_binder list * cc_term
+  | CC_app of cc_term * cc_term list
+  | CC_tuple of bool * cc_type list * cc_term list
+  | CC_case of cc_type * cc_term * cc_term list
+  | CC_expr of Term.constr
+  | CC_hole of cc_type
diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml
new file mode 100644
index 00000000..e87ba70c
--- /dev/null
+++ b/contrib/correctness/pcic.ml
@@ -0,0 +1,231 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pcic.ml,v 1.23.2.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Libnames
+open Term
+open Termops
+open Nametab
+open Declarations
+open Indtypes
+open Sign
+open Rawterm
+open Typeops
+open Entries
+open Topconstr
+
+open Pmisc
+open Past
+
+
+(* Here we translate intermediates terms (cc_term) into CCI terms (constr) *)
+
+let make_hole c = mkCast (isevar, c)
+
+(* Tuples are defined in file Tuples.v 
+ * and their constructors are called Build_tuple_n or exists_n,
+ * wether they are dependant (last element only) or not. 
+ * If necessary, tuples are generated ``on the fly''. *)
+
+let tuple_exists id = 
+  try let _ = Nametab.locate (make_short_qualid id) in true
+  with Not_found -> false
+
+let ast_set = CSort (dummy_loc,RProp Pos)
+
+let tuple_n n =
+  let id = make_ident "tuple_" (Some n) in
+  let l1n = Util.interval 1 n in
+  let params =
+    List.map (fun i ->
+      (LocalRawAssum ([dummy_loc,Name (make_ident "T" (Some i))], ast_set)))
+      l1n in
+  let fields = 
+    List.map
+      (fun i -> 
+	 let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in
+	 let id' = make_ident "T" (Some i) in
+	 (false, Vernacexpr.AssumExpr ((dummy_loc,Name id), mkIdentC id')))
+      l1n 
+  in
+  let cons = make_ident "Build_tuple_" (Some n) in
+  Record.definition_structure
+    ((false, (dummy_loc,id)), params, fields, cons, mk_Set)
+
+(*s [(sig_n n)] generates the inductive
+    \begin{verbatim}
+    Inductive sig_n [T1,...,Tn:Set; P:T1->...->Tn->Prop] : Set :=
+      exist_n : (x1:T1)...(xn:Tn)(P x1 ... xn) -> (sig_n T1 ... Tn P).
+    \end{verbatim} *)
+
+let sig_n n =
+  let id = make_ident "sig_" (Some n) in
+  let l1n = Util.interval 1 n in
+  let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in
+  let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in
+  let idp = make_ident "P" None in
+  let params =
+    let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in
+    (idp, LocalAssum typ) :: 
+    (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT)
+  in
+  let lc = 
+    let app_sig = mkApp(mkRel (2*n+3),
+                        Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in
+    let app_p = mkApp(mkRel (n+1),
+                      Array.init n (fun i -> mkRel (n-i))) in
+    let c = mkArrow app_p app_sig in
+    List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c
+  in
+  let cname = make_ident "exist_" (Some n) in
+  Declare.declare_mind 
+    { mind_entry_finite = true;
+      mind_entry_inds = 
+	[ { mind_entry_params = params;
+	    mind_entry_typename = id;
+	    mind_entry_arity = mkSet;
+	    mind_entry_consnames = [ cname ];
+	    mind_entry_lc = [ lc ] } ] }
+
+(*s On the fly generation of needed (possibly dependent) tuples. *)
+
+let check_product_n n =
+  if n > 2 then
+    let s = Printf.sprintf "tuple_%d" n in
+    if not (tuple_exists (id_of_string s)) then tuple_n n
+
+let check_dep_product_n n =
+  if n > 1 then
+    let s = Printf.sprintf "sig_%d" n in
+    if not (tuple_exists (id_of_string s)) then ignore (sig_n n)
+
+(*s Constructors for the tuples. *)
+	
+let pair = ConstructRef ((coq_constant ["Init"; "Datatypes"] "prod",0),1)
+let exist = ConstructRef ((coq_constant ["Init"; "Specif"] "sig",0),1)
+
+let tuple_ref dep n =
+  if n = 2 & not dep then
+    pair
+  else
+    let n = n - (if dep then 1 else 0) in
+    if dep then
+      if n = 1 then 
+	exist
+      else begin
+	let id = make_ident "exist_" (Some n) in
+	if not (tuple_exists id) then ignore (sig_n n);
+	Nametab.locate (make_short_qualid id)
+      end
+    else begin
+      let id = make_ident "Build_tuple_" (Some n) in
+      if not (tuple_exists id) then tuple_n n;
+      Nametab.locate (make_short_qualid id)
+    end
+
+(* Binders. *)
+
+let trad_binder avoid nenv id = function
+  | CC_untyped_binder -> RHole (dummy_loc,BinderType (Name id))
+  | CC_typed_binder ty -> Detyping.detype (false,Global.env()) avoid nenv ty
+
+let rec push_vars avoid nenv = function
+  | [] -> ([],avoid,nenv)
+  | (id,b) :: bl -> 
+      let b' = trad_binder avoid nenv id b in
+      let bl',avoid',nenv' = 
+	push_vars (id :: avoid) (add_name (Name id) nenv) bl 
+      in
+      ((id,b') :: bl', avoid', nenv')
+
+let rec raw_lambda bl v = match bl with
+  | [] -> 
+      v
+  | (id,ty) :: bl' -> 
+      RLambda (dummy_loc, Name id, ty, raw_lambda bl' v)
+
+(* The translation itself is quite easy.
+   letin are translated into Cases constructions *)
+
+let rawconstr_of_prog p =
+  let rec trad avoid nenv = function
+    | CC_var id -> 
+	RVar (dummy_loc, id)
+
+    (*i optimisation : let x = <constr> in e2  =>  e2[x<-constr] 
+    | CC_letin (_,_,[id,_],CC_expr c,e2) ->
+	real_subst_in_constr [id,c] (trad e2)
+    | CC_letin (_,_,([_] as b),CC_expr e1,e2) ->
+	let (b',avoid',nenv') = push_vars avoid nenv b in
+      	let c1 = Detyping.detype avoid nenv e1 
+	and c2 = trad avoid' nenv' e2 in
+	let id = Name (fst (List.hd b')) in
+	RLetIn (dummy_loc, id, c1, c2)
+    i*)
+
+    | CC_letin (_,_,([_] as b),e1,e2) ->
+	let (b',avoid',nenv') = push_vars avoid nenv b in
+      	let c1 = trad avoid nenv e1 
+	and c2 = trad avoid' nenv' e2 in
+	RApp (dummy_loc, raw_lambda b' c2, [c1])
+
+    | CC_letin (dep,ty,bl,e1,e2) ->
+	let (bl',avoid',nenv') = push_vars avoid nenv bl in
+	let c1 = trad avoid nenv e1
+	and c2 = trad avoid' nenv' e2 in
+	ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |], ref None)
+
+    | CC_lam (bl,e) ->
+	let bl',avoid',nenv' = push_vars avoid nenv bl in
+	let c = trad avoid' nenv' e in 
+	raw_lambda bl' c
+
+    | CC_app (f,args) ->
+	let c = trad avoid nenv f
+	and cargs = List.map (trad avoid nenv) args in
+	RApp (dummy_loc, c, cargs)
+
+    | CC_tuple (_,_,[e]) -> 
+	trad avoid nenv e
+	
+    | CC_tuple (false,_,[e1;e2]) ->
+	let c1 = trad avoid nenv e1 
+	and c2 = trad avoid nenv e2 in
+	RApp (dummy_loc, RRef (dummy_loc,pair),
+	      [RHole (dummy_loc,ImplicitArg (pair,1));
+	       RHole (dummy_loc,ImplicitArg (pair,2));c1;c2])
+
+    | CC_tuple (dep,tyl,l) ->
+      	let n = List.length l in
+      	let cl = List.map (trad avoid nenv) l in
+      	let tuple = tuple_ref dep n in
+	let tyl = List.map (Detyping.detype (false,Global.env()) avoid nenv) tyl in
+      	let args = tyl @ cl in
+	RApp (dummy_loc, RRef (dummy_loc, tuple), args)
+
+    | CC_case (ty,b,el) ->
+	let c = trad avoid nenv b in
+	let cl = List.map (trad avoid nenv) el in
+	let ty = Detyping.detype (false,Global.env()) avoid nenv ty in
+	ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl, ref None)
+
+    | CC_expr c -> 
+	Detyping.detype (false,Global.env()) avoid nenv c
+
+    | CC_hole c -> 
+	RCast (dummy_loc, RHole (dummy_loc, QuestionMark),
+               Detyping.detype (false,Global.env()) avoid nenv c)
+
+  in
+  trad [] empty_names_context p
diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli
new file mode 100644
index 00000000..89731472
--- /dev/null
+++ b/contrib/correctness/pcic.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 *)
+
+(*i $Id: pcic.mli,v 1.3.16.1 2004/07/16 19:30:00 herbelin Exp $ i*)
+
+open Past
+open Rawterm
+
+(* On-the-fly generation of needed (possibly dependent) tuples. *)
+
+val check_product_n : int -> unit
+val check_dep_product_n : int -> unit
+
+(* transforms intermediate functional programs into (raw) CIC terms *)
+
+val rawconstr_of_prog : cc_term -> rawconstr
+
diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml
new file mode 100644
index 00000000..cc15c8f3
--- /dev/null
+++ b/contrib/correctness/pcicenv.ml
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pcicenv.ml,v 1.5.14.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+open Names
+open Term
+open Sign
+
+open Pmisc
+open Putil
+open Ptype
+open Past
+
+(* on redéfinit add_sign pour éviter de construire des environnements
+ * avec des doublons (qui font planter la résolution des implicites !) *)
+
+(* VERY UGLY!! find some work around *)
+let modify_sign id t s =
+  fold_named_context
+    (fun ((x,b,ty) as d) sign ->
+      if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign)
+    s ~init:empty_named_context
+
+let add_sign (id,t) s =
+  try 
+    let _ = lookup_named id s in
+    modify_sign id t s
+  with Not_found ->
+    add_named_decl (id,None,t) s
+
+let cast_set c = mkCast (c, mkSet)
+
+let set = mkCast (mkSet, mkType Univ.prop_univ)
+
+(* [cci_sign_of env] construit un environnement pour CIC ne comprenant que
+ * les objets fonctionnels de l'environnement de programes [env]
+ *)
+
+let cci_sign_of ren env =
+  Penv.fold_all 
+    (fun (id,v) sign ->
+       match v with
+	 | Penv.TypeV (Ref _ | Array _) -> sign
+	 | Penv.TypeV v -> 
+	     let ty = Pmonad.trad_ml_type_v ren env v in
+	     add_sign (id,cast_set ty) sign
+	 | Penv.Set -> add_sign (id,set) sign)
+    env (Global.named_context ())
+
+(* [sign_meta ren env fadd ini]
+ * construit un environnement pour CIC qui prend en compte les variables
+ * de programme. 
+ * pour cela, cette fonction parcours tout l'envrionnement (global puis
+ * local [env]) et pour chaque déclaration, ajoute ce qu'il faut avec la
+ * fonction [fadd] s'il s'agit d'un mutable et directement sinon,
+ * en partant de [ini].
+ *)
+
+let sign_meta ren env fast ini =
+   Penv.fold_all 
+    (fun (id,v) sign ->
+       match v with
+	 | Penv.TypeV (Ref _ | Array _ as v) -> 
+	     let ty = Pmonad.trad_imp_type ren env v in
+	     fast sign id ty
+	 | Penv.TypeV v -> 
+	     let ty = Pmonad.trad_ml_type_v ren env v in
+	     add_sign (id,cast_set ty) sign
+	 | Penv.Set -> add_sign (id,set) sign)
+    env ini
+
+let add_sign_d dates (id,c) sign =
+  let sign =
+    List.fold_left (fun sign d -> add_sign (at_id id d,c) sign) sign dates
+  in
+    add_sign (id,c) sign
+ 
+let sign_of add ren env =
+  sign_meta ren env
+    (fun sign id c -> let c = cast_set c in add (id,c) sign)
+    (Global.named_context ())
+
+let result_of sign = function
+    None   -> sign
+  | Some (id,c) -> add_sign (id, cast_set c) sign
+	
+let before_after_result_sign_of res ren env =
+  let dates = "" :: Prename.all_dates ren in
+  result_of (sign_of (add_sign_d dates) ren env) res
+
+let before_after_sign_of ren =
+  let dates = "" :: Prename.all_dates ren in
+  sign_of (add_sign_d dates) ren
+
+let before_sign_of ren =
+  let dates = Prename.all_dates ren in
+  sign_of (add_sign_d dates) ren
+
+let now_sign_of =
+  sign_of (add_sign_d [])
+
+
+(* environnement après traduction *)
+
+let trad_sign_of ren =
+  sign_of
+    (fun (id,c) sign -> add_sign (Prename.current_var ren id,c) sign)
+    ren
+
+
diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli
new file mode 100644
index 00000000..fc4fa0b9
--- /dev/null
+++ b/contrib/correctness/pcicenv.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: pcicenv.mli,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *)
+
+open Penv
+open Names
+open Term
+open Sign
+
+(* Translation of local programs environments into Coq signatures.
+ * It is mainly used to type the pre/post conditions in the good
+ * environment *)
+
+(* cci_sign_of: uniquement les objets purement fonctionnels de l'env. *)
+val cci_sign_of : Prename.t -> local_env -> named_context
+
+(* env. Coq avec seulement les variables X de l'env. *)
+val now_sign_of : Prename.t -> local_env -> named_context
+
+(* + les variables X@d pour toutes les dates de l'env. *)
+val before_sign_of : Prename.t -> local_env -> named_context
+
+(* + les variables `avant' X@ *)
+val before_after_sign_of : Prename.t -> local_env -> named_context
+val before_after_result_sign_of : ((identifier * constr) option)
+                        -> Prename.t -> local_env -> named_context
+
+(* env. des programmes traduits, avec les variables rennomées *)
+val trad_sign_of : Prename.t -> local_env -> named_context
+
diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml
new file mode 100644
index 00000000..302db871
--- /dev/null
+++ b/contrib/correctness/pdb.ml
@@ -0,0 +1,165 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pdb.ml,v 1.8.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+open Term
+open Termops
+open Nametab
+open Constrintern
+
+open Ptype
+open Past
+open Penv
+
+let cci_global id =
+  try
+    global_reference id
+  with
+    _ -> raise Not_found
+
+let lookup_var ids locop id =
+  if List.mem id ids then
+    None
+  else begin
+    try Some (cci_global id)
+    with Not_found -> Perror.unbound_variable id locop
+  end
+
+let check_ref idl loc id =
+  if (not (List.mem id idl)) & (not (Penv.is_global id)) then
+    Perror.unbound_reference id loc
+
+(* db types : only check the references for the moment *)
+
+let rec check_type_v refs = function
+  | Ref v -> 
+      check_type_v refs v
+  | Array (c,v) -> 
+      check_type_v refs v
+  | Arrow (bl,c) -> 
+      check_binder refs c bl
+  | TypePure _ -> 
+      ()
+
+and check_type_c refs ((_,v),e,_,_) =
+  check_type_v refs v;
+  List.iter (check_ref refs None) (Peffect.get_reads e);
+  List.iter (check_ref refs None) (Peffect.get_writes e)
+  (* TODO: check_condition on p and q *)
+
+and check_binder refs c = function
+  | [] -> 
+      check_type_c refs c
+  | (id, BindType (Ref _ | Array _ as v)) :: bl -> 
+      check_type_v refs v;
+      check_binder (id :: refs) c bl
+  | (_, BindType v) :: bl ->
+      check_type_v refs v;
+      check_binder refs c bl
+  | _ :: bl -> 
+      check_binder refs c bl
+
+(* db binders *)
+
+let rec db_binders ((tids,pids,refs) as idl) = function
+  | [] -> 
+      idl, []
+  | (id, BindType (Ref _ | Array _ as v)) as b :: rem ->
+      check_type_v refs v;
+      let idl',rem' = db_binders (tids,pids,id::refs) rem in
+      idl', b :: rem'
+  | (id, BindType v) as b :: rem ->
+      check_type_v refs v;
+      let idl',rem' = db_binders (tids,id::pids,refs) rem in
+      idl', b :: rem'
+  | ((id, BindSet) as t) :: rem ->
+      let idl',rem' = db_binders (id::tids,pids,refs) rem in
+      idl', t :: rem'
+  | a :: rem ->
+      let idl',rem' = db_binders idl rem in idl', a :: rem'
+
+
+(* db programs *)
+  
+let db_prog e =
+  (* tids = type identifiers, ids = variables, refs = references and arrays *)
+  let rec db_desc ((tids,ids,refs) as idl) = function
+    | (Variable x) as t ->
+	(match lookup_var ids (Some e.loc) x with
+	     None -> t
+	   | Some c -> Expression c)
+    | (Acc x) as t ->
+	check_ref refs (Some e.loc) x;
+	t
+    | Aff (x,e1) ->
+	check_ref refs (Some e.loc) x;
+	Aff (x, db idl e1)
+    | TabAcc (b,x,e1) ->
+	check_ref refs (Some e.loc) x;
+	TabAcc(b,x,db idl e1)
+    | TabAff (b,x,e1,e2) ->
+	check_ref refs (Some e.loc) x;
+	TabAff (b,x, db idl e1, db idl e2)
+    | Seq bl ->
+	Seq (List.map (function
+			   Statement p -> Statement (db idl p)
+			 | x -> x) bl)
+    | If (e1,e2,e3) ->
+	If (db idl e1, db idl e2, db idl e3)
+    | While (b,inv,var,bl) ->
+	let bl' = List.map (function
+				Statement p -> Statement (db idl p)
+			      | x -> x) bl in
+	While (db idl b, inv, var, bl')
+	  
+    | Lam (bl,e) ->
+	let idl',bl' = db_binders idl bl in Lam(bl', db idl' e)
+    | Apply (e1,l) ->
+	Apply (db idl e1, List.map (db_arg idl) l)
+    | SApp (dl,l) ->
+	SApp (dl, List.map (db idl) l)
+    | LetRef (x,e1,e2) ->
+	LetRef (x, db idl e1, db (tids,ids,x::refs) e2)
+    | Let (x,e1,e2) ->
+	Let (x, db idl e1, db (tids,x::ids,refs) e2)
+	  
+    | LetRec (f,bl,v,var,e) ->
+	let (tids',ids',refs'),bl' = db_binders idl bl in
+	check_type_v refs' v;
+	LetRec (f, bl, v, var, db (tids',f::ids',refs') e)
+	  
+    | Debug (s,e1) ->
+	Debug (s, db idl e1)
+	  
+    | Expression _ as x -> x
+    | PPoint (s,d) -> PPoint (s, db_desc idl d)
+	  
+  and db_arg ((tids,_,refs) as idl) = function
+    | Term ({ desc = Variable id } as t) -> 
+	if List.mem id refs then Refarg id else Term (db idl t)
+    | Term t -> Term (db idl t)
+    | Type v as ty -> check_type_v refs v; ty
+    | Refarg _ -> assert false
+
+  and db idl e =
+    { desc = db_desc idl e.desc ;
+      pre = e.pre; post = e.post;
+      loc = e.loc; info = e.info }
+
+  in
+  let ids = Termops.ids_of_named_context (Global.named_context ()) in
+            (* TODO: separer X:Set et x:V:Set
+                     virer le reste (axiomes, etc.) *)
+  let vars,refs = all_vars (), all_refs () in
+  db ([],vars@ids,refs) e
+;;
+
diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli
new file mode 100644
index 00000000..a0df29bd
--- /dev/null
+++ b/contrib/correctness/pdb.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: pdb.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Ptype
+open Past
+
+
+(* Here we separate local and global variables, we check the use of
+ * references and arrays w.r.t the local and global environments, etc.
+ * These functions directly raise UserError exceptions on bad programs.
+ *)
+
+val check_type_v : Names.identifier list -> 'a ml_type_v -> unit
+
+val db_prog : program -> program
+
diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml
new file mode 100644
index 00000000..08d6b002
--- /dev/null
+++ b/contrib/correctness/peffect.ml
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: peffect.ml,v 1.3.14.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+open Nameops
+open Pmisc
+
+(* The type of effects.
+ *
+ * An effect is composed of two lists (r,w) of variables.
+ * The first one is the list of read-only variables
+ * and the second one is the list of read-write variables.
+ *
+ * INVARIANT: 1. each list is sorted in decreasing order for Pervasives.compare
+ *            2. there are no duplicate elements in each list
+ *            3. the two lists are disjoint
+ *)
+
+type t = identifier list * identifier list
+
+
+(* the empty effect *)
+
+let bottom = ([], [])
+
+(* basic operations *)
+
+let push x l =
+  let rec push_rec = function
+      [] -> [x]
+    | (y::rem) as l ->
+	if x = y then l else if x > y then x::l else y :: push_rec rem
+  in
+    push_rec l
+
+let basic_remove x l =
+  let rec rem_rec = function
+      [] -> []
+    | y::l -> if x = y then l else y :: rem_rec l
+  in
+    rem_rec l
+
+let mem x (r,w) = (List.mem x r) or (List.mem x w)
+
+let rec basic_union = function
+    [], s2 -> s2
+  | s1, [] -> s1
+  | ((v1::l1) as s1), ((v2::l2) as s2) ->
+      if v1 > v2 then
+	v1 :: basic_union (l1,s2)
+      else if v1 < v2 then
+	v2 :: basic_union (s1,l2)
+      else
+	v1 :: basic_union (l1,l2)
+
+(* adds reads and writes variables *)
+
+let add_read id ((r,w) as e) =
+  (* if the variable is already a RW it is ok, otherwise adds it as a RO. *)
+  if List.mem id w then
+    e
+  else
+    push id r, w
+
+let add_write id (r,w) =
+  (* if the variable is a RO then removes it from RO. Adds it to RW. *)
+  if List.mem id r then
+    basic_remove id r, push id w
+  else
+    r, push id w
+
+(* access *)
+
+let get_reads = basic_union
+let get_writes = snd
+let get_repr e = (get_reads e, get_writes e)
+
+(* tests *)
+
+let is_read  (r,_) id = List.mem id r
+let is_write (_,w) id = List.mem id w
+
+(* union and disjunction *)
+
+let union (r1,w1) (r2,w2) = basic_union (r1,r2), basic_union (w1,w2)
+
+let rec diff = function
+    [], s2 -> []
+  | s1, [] -> s1
+  | ((v1::l1) as s1), ((v2::l2) as s2) ->
+      if v1 > v2 then
+	v1 :: diff (l1,s2)
+      else if v1 < v2 then
+	diff (s1,l2)
+      else
+	diff (l1,l2)
+
+let disj (r1,w1) (r2,w2) =
+  let w1_w2 = diff (w1,w2) and w2_w1 = diff (w2,w1) in
+  let r = basic_union (basic_union (r1,r2), basic_union (w1_w2,w2_w1))
+  and w = basic_union (w1,w2) in
+  r,w
+
+(* comparison relation *)
+
+let le e1 e2 = failwith "effects: le: not yet implemented"
+
+let inf e1 e2 = failwith "effects: inf: not yet implemented"
+
+(* composition *)
+
+let compose (r1,w1) (r2,w2) =
+  let r = basic_union (r1, diff (r2,w1)) in
+  let w = basic_union (w1,w2) in
+    r,w
+
+(* remove *)
+
+let remove (r,w) name = basic_remove name r, basic_remove name w
+
+(* substitution *)
+
+let subst_list (x,x') l =
+  if List.mem x l then push x' (basic_remove x l) else l
+
+let subst_one (r,w) s = subst_list s r, subst_list s w
+
+let subst s e = List.fold_left subst_one e s
+
+(* pretty-print *)
+
+open Pp
+open Util
+open Himsg
+
+let pp (r,w) =
+  hov 0 (if r<>[] then
+	     (str"reads " ++
+		prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r)
+	   else (mt ()) ++
+	   spc () ++
+	   if w<>[] then
+	     (str"writes " ++
+		prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w)
+	   else (mt ())
+)
+
+let ppr e =
+  Pp.pp (pp e)
+
diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli
new file mode 100644
index 00000000..d6d0ce22
--- /dev/null
+++ b/contrib/correctness/peffect.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: peffect.mli,v 1.1.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+
+(* The abstract type of effects *)
+
+type t
+
+val bottom : t
+val add_read  : identifier -> t -> t
+val add_write : identifier -> t -> t
+
+val get_reads : t -> identifier list
+val get_writes : t -> identifier list
+val get_repr : t -> (identifier list) * (identifier list)
+
+val is_read  : t -> identifier -> bool    (* read-only *)
+val is_write : t -> identifier -> bool    (* read-write *)
+
+val compose : t -> t -> t
+
+val union : t -> t -> t
+val disj : t -> t -> t
+
+val remove : t -> identifier -> t
+
+val subst : (identifier * identifier) list -> t -> t
+
+
+val pp : t -> Pp.std_ppcmds
+val ppr : t -> unit
+
diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml
new file mode 100644
index 00000000..820d1cf0
--- /dev/null
+++ b/contrib/correctness/penv.ml
@@ -0,0 +1,240 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: penv.ml,v 1.10.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Pmisc
+open Past
+open Ptype
+open Names
+open Nameops
+open Libobject
+open Library
+open Term
+
+(* Environments for imperative programs.
+ *
+ * An environment of programs is an association tables
+ * from identifiers (Names.identifier) to types of values with effects
+ * (ProgAst.ml_type_v), together with a list of these associations, since
+ * the order is relevant (we have dependent types e.g. [x:nat; t:(array x T)])
+ *)
+
+module Env = struct
+  type 'a t = ('a Idmap.t)
+	    * ((identifier * 'a) list)
+	    * ((identifier * (identifier * variant)) list)
+  let empty = Idmap.empty, [], []
+  let add id v (m,l,r) = (Idmap.add id v m, (id,v)::l, r)
+  let find id (m,_,_) = Idmap.find id m
+  let fold f (_,l,_) x0 = List.fold_right f l x0
+  let add_rec (id,var) (m,l,r) = (m,l,(id,var)::r)
+  let find_rec id (_,_,r) = List.assoc id r
+end
+
+(* Local environments *)
+
+type type_info = Set | TypeV of type_v
+
+type local_env = type_info Env.t
+
+let empty = (Env.empty : local_env)
+
+let add (id,v) = Env.add id (TypeV v)
+
+let add_set id = Env.add id Set
+
+let find id env =
+  match Env.find id env with TypeV v -> v | Set -> raise Not_found
+
+let is_local env id =
+  try
+    match Env.find id env with TypeV _ -> true | Set -> false
+  with
+      Not_found -> false
+
+let is_local_set env id =
+  try
+    match Env.find id env with TypeV _ -> false | Set -> true
+  with
+      Not_found -> false
+
+
+(* typed programs *)
+
+type typing_info = {
+  env : local_env;
+  kappa : constr ml_type_c
+}
+  
+type typed_program = (typing_info, constr) t
+
+
+(* The global environment.
+ *
+ * We have a global typing environment env
+ * We also keep a table of programs for extraction purposes
+ * and a table of initializations (still for extraction)
+ *)
+
+let (env : type_info Env.t ref) = ref Env.empty
+
+let (pgm_table : (typed_program option) Idmap.t ref) = ref Idmap.empty
+
+let (init_table : constr Idmap.t ref) = ref Idmap.empty
+
+let freeze () = (!env, !pgm_table, !init_table)
+let unfreeze (e,p,i) = env := e; pgm_table := p; init_table := i
+let init () = 
+  env := Env.empty; pgm_table := Idmap.empty; init_table := Idmap.empty
+;;
+
+Summary.declare_summary "programs-environment"
+  { Summary.freeze_function = freeze;
+    Summary.unfreeze_function = unfreeze;
+    Summary.init_function = init;
+    Summary.survive_module = false;
+    Summary.survive_section = false }
+;;
+
+(* Operations on the global environment. *)
+
+let add_pgm id p = pgm_table := Idmap.add id p !pgm_table
+
+let cache_global (_,(id,v,p)) =
+  env := Env.add id v !env; add_pgm id p
+
+let type_info_app f = function Set -> Set | TypeV v -> TypeV (f v)
+
+let subst_global (_,s,(id,v,p)) = (id, type_info_app (type_v_knsubst s) v, p)
+
+let (inProg,outProg) =
+  declare_object { object_name = "programs-objects";
+                   cache_function = cache_global;
+                   load_function = (fun _ -> cache_global);
+                   open_function = (fun _ _ -> ());
+		   classify_function = (fun (_,x) -> Substitute x);
+		   subst_function = subst_global;
+		   export_function = (fun x -> Some x) }
+
+let is_mutable = function Ref _ | Array _ -> true | _ -> false
+
+let add_global id v p =
+  try
+    let _ = Env.find id !env in
+    Perror.clash id None
+  with
+    Not_found -> begin
+      let id' =
+	if is_mutable v then id 
+        else id_of_string ("prog_" ^ (string_of_id id)) 
+      in
+      Lib.add_leaf id' (inProg (id,TypeV v,p))
+    end
+
+let add_global_set id =
+  try
+    let _ = Env.find id !env in
+    Perror.clash id None
+  with
+    Not_found -> Lib.add_leaf id (inProg (id,Set,None))
+
+let is_global id =
+  try
+    match Env.find id !env with TypeV _ -> true | Set -> false
+  with
+    Not_found -> false
+
+let is_global_set id =
+  try
+    match Env.find id !env with TypeV _ -> false | Set -> true
+  with
+    Not_found -> false
+
+
+let lookup_global id =
+  match Env.find id !env with TypeV v -> v | Set -> raise Not_found
+
+let find_pgm id = Idmap.find id !pgm_table
+
+let all_vars () =
+  Env.fold
+    (fun (id,v) l -> match v with TypeV (Arrow _|TypePure _) -> id::l | _ -> l)
+    !env []
+
+let all_refs () =
+  Env.fold
+    (fun (id,v) l -> match v with TypeV (Ref _ | Array _) -> id::l | _ -> l)
+    !env []
+
+(* initializations *)
+
+let cache_init (_,(id,c)) =
+  init_table := Idmap.add id c !init_table
+
+let subst_init (_,s,(id,c)) = (id, subst_mps s c)
+
+let (inInit,outInit) =
+  declare_object { object_name = "programs-objects-init";
+                   cache_function = cache_init;
+                   load_function = (fun _ -> cache_init);
+		   open_function = (fun _ _-> ());
+		   classify_function = (fun (_,x) -> Substitute x);
+		   subst_function = subst_init;
+                   export_function = (fun x -> Some x) }
+
+let initialize id c = Lib.add_anonymous_leaf (inInit (id,c))
+
+let find_init id = Idmap.find id !init_table
+
+
+(* access in env, local then global *)
+
+let type_in_env env id =
+  try find id env with Not_found -> lookup_global id
+
+let is_in_env env id =
+  (is_global id) or (is_local env id)
+
+let fold_all f lenv x0 =
+  let x1 = Env.fold f !env x0 in
+  Env.fold f lenv x1
+
+
+(* recursions *)
+
+let add_recursion = Env.add_rec
+
+let find_recursion = Env.find_rec
+
+
+(* We also maintain a table of the currently edited proofs of programs
+ * in order to add them in the environnement when the user does Save *)
+
+open Pp
+open Himsg
+
+let (edited : (type_v * typed_program) Idmap.t ref) = ref Idmap.empty
+
+let new_edited id v =
+  edited := Idmap.add id v !edited
+
+let is_edited id =
+  try let _ = Idmap.find id !edited in true with Not_found -> false
+
+let register id id' =
+  try
+    let (v,p) = Idmap.find id !edited in
+    let _ = add_global id' v (Some p) in
+    Options.if_verbose 
+      msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined"));
+    edited := Idmap.remove id !edited
+  with Not_found -> ()
+
diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli
new file mode 100644
index 00000000..ef2e4c6e
--- /dev/null
+++ b/contrib/correctness/penv.mli
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: penv.mli,v 1.3.8.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Ptype
+open Past
+open Names
+open Libnames
+open Term
+
+(* Environment for imperative programs.
+ * 
+ * Here we manage the global environment, which is imperative,
+ * and we provide a functional local environment. 
+ *
+ * The most important functions, is_in_env, type_in_env and fold_all
+ * first look in the local environment then in the global one.
+ *)
+
+(* local environments *)
+
+type local_env
+
+val empty : local_env
+val add : (identifier * type_v) -> local_env -> local_env
+val add_set : identifier -> local_env -> local_env
+val is_local : local_env -> identifier -> bool
+val is_local_set : local_env -> identifier -> bool
+
+(* typed programs *)
+
+type typing_info = {
+  env : local_env;
+  kappa : constr ml_type_c
+}
+  
+type typed_program = (typing_info, constr) t
+
+(* global environment *)
+
+val add_global : identifier -> type_v -> typed_program option -> object_name
+val add_global_set : identifier -> object_name
+val is_global : identifier -> bool
+val is_global_set : identifier -> bool
+val lookup_global : identifier -> type_v
+
+val all_vars : unit -> identifier list
+val all_refs : unit -> identifier list
+
+(* a table keeps the program (for extraction) *)
+
+val find_pgm : identifier -> typed_program option
+
+(* a table keeps the initializations of mutable objects *)
+
+val initialize : identifier -> constr -> unit
+val find_init : identifier -> constr
+
+(* access in env (local then global) *)
+
+val type_in_env : local_env -> identifier -> type_v
+val is_in_env : local_env -> identifier -> bool
+
+type type_info = Set | TypeV of type_v
+val fold_all : (identifier * type_info -> 'a -> 'a) -> local_env -> 'a -> 'a
+
+(* local environnements also contains a list of recursive functions
+ * with the associated variant *)
+
+val add_recursion : identifier * (identifier*variant) -> local_env -> local_env
+val find_recursion : identifier -> local_env -> identifier * variant
+
+(* We also maintain a table of the currently edited proofs of programs
+ * in order to add them in the environnement when the user does Save *)
+
+val new_edited : identifier -> type_v * typed_program -> unit
+val is_edited : identifier -> bool
+val register : identifier -> identifier -> unit
+
diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml
new file mode 100644
index 00000000..40fe4c98
--- /dev/null
+++ b/contrib/correctness/perror.ml
@@ -0,0 +1,172 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: perror.ml,v 1.9.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Himsg
+
+open Ptype
+open Past
+
+let is_mutable = function Ref _ | Array _ -> true | _ -> false
+let is_pure = function TypePure _ -> true | _ -> false
+
+let raise_with_loc = function
+  | None -> raise
+  | Some loc -> Stdpp.raise_with_loc loc 
+
+let unbound_variable id loc =
+  raise_with_loc loc
+    (UserError ("Perror.unbound_variable",
+    (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ()))))
+
+let unbound_reference id loc =
+  raise_with_loc loc
+    (UserError ("Perror.unbound_reference",
+    (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ()))))
+
+let clash id loc =
+  raise_with_loc loc
+    (UserError ("Perror.clash",
+    (hov 0 (str"Clash with previous constant" ++ spc () ++
+    str(string_of_id id) ++ fnl ()))))
+
+let not_defined id =
+  raise
+    (UserError ("Perror.not_defined",
+	       	(hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++
+			  str"is not defined" ++ fnl ()))))
+
+let check_for_reference loc id = function
+    Ref _ -> ()
+  | _ -> Stdpp.raise_with_loc loc 
+	(UserError ("Perror.check_for_reference",
+		    hov 0 (pr_id id ++ spc () ++ 
+			     str"is not a reference")))
+
+let check_for_array loc id = function
+    Array _ -> ()
+  | _ -> Stdpp.raise_with_loc loc 
+	(UserError ("Perror.check_for_array",
+		    hov 0 (pr_id id ++ spc () ++ 
+			     str"is not an array")))
+
+let is_constant_type s = function
+    TypePure c ->
+      let id = id_of_string s in
+      let c' = Constrintern.global_reference id in
+      Reductionops.is_conv (Global.env()) Evd.empty c c'
+  | _ -> false 
+
+let check_for_index_type loc v =
+  let is_index = is_constant_type "Z" v in
+  if not is_index then
+    Stdpp.raise_with_loc loc 
+      (UserError ("Perror.check_for_index",
+		  hov 0 (str"This expression is an index" ++ spc () ++ 
+			   str"and should have type int (Z)")))
+
+let check_no_effect loc ef =
+  if not (Peffect.get_writes ef = []) then
+    Stdpp.raise_with_loc loc 
+      (UserError ("Perror.check_no_effect",
+		  hov 0 (str"A boolean should not have side effects"
+)))
+
+let should_be_boolean loc =
+  Stdpp.raise_with_loc loc 
+    (UserError ("Perror.should_be_boolean",
+		hov 0 (str"This expression is a test:" ++ spc () ++
+			 str"it should have type bool")))
+
+let test_should_be_annotated loc =
+  Stdpp.raise_with_loc loc 
+    (UserError ("Perror.test_should_be_annotated",
+		hov 0 (str"This test should be annotated")))
+
+let if_branches loc =
+  Stdpp.raise_with_loc loc 
+    (UserError ("Perror.if_branches",
+		hov 0 (str"The two branches of an `if' expression" ++ spc () ++
+			 str"should have the same type")))
+
+let check_for_not_mutable loc v =
+  if is_mutable v then
+    Stdpp.raise_with_loc loc 
+      (UserError ("Perror.check_for_not_mutable",
+		  hov 0 (str"This expression cannot be a mutable")))
+
+let check_for_pure_type loc v =
+  if not (is_pure v) then
+    Stdpp.raise_with_loc loc 
+      (UserError ("Perror.check_for_pure_type",
+		  hov 0 (str"This expression must be pure" ++ spc () ++
+			   str"(neither a mutable nor a function)")))
+
+let check_for_let_ref loc v =
+  if not (is_pure v) then
+    Stdpp.raise_with_loc loc 
+      (UserError ("Perror.check_for_let_ref",
+		  hov 0 (str"References can only be bound in pure terms")))
+
+let informative loc s =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.variant_informative",
+	      hov 0 (str s ++ spc () ++ str"must be informative")))
+
+let variant_informative loc = informative loc "Variant"
+let should_be_informative loc = informative loc "This term"
+
+let app_of_non_function loc =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.app_of_non_function",
+	      hov 0 (str"This term cannot be applied" ++ spc () ++
+		       str"(either it is not a function" ++ spc () ++
+		       str"or it is applied to non pure arguments)")))
+  
+let partial_app loc =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.partial_app",
+	      hov 0 (str"This function does not have" ++
+		       spc () ++ str"the right number of arguments")))
+  
+let expected_type loc s =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.expected_type",
+	      hov 0 (str"Argument is expected to have type" ++ spc () ++ s)))
+
+let expects_a_type id loc =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.expects_a_type",
+	      hov 0 (str"The argument " ++ pr_id id ++ spc () ++
+		       str"in this application is supposed to be a type")))
+
+let expects_a_term id =
+  raise
+  (UserError ("Perror.expects_a_type",
+	      hov 0 (str"The argument " ++ pr_id id ++ spc () ++
+		       str"in this application is supposed to be a term")))
+
+let should_be_a_variable loc =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.should_be_a_variable",
+	      hov 0 (str"Argument should be a variable")))
+   
+let should_be_a_reference loc =
+  Stdpp.raise_with_loc loc 
+  (UserError ("Perror.should_be_a_reference",
+	      hov 0 (str"Argument of function should be a reference")))
+
+   
diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli
new file mode 100644
index 00000000..40b2d25c
--- /dev/null
+++ b/contrib/correctness/perror.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: perror.mli,v 1.2.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Ptype
+open Past
+
+val unbound_variable : identifier -> loc option -> 'a
+val unbound_reference : identifier -> loc option -> 'a
+
+val clash : identifier -> loc option -> 'a
+val not_defined : identifier -> 'a
+
+val check_for_reference : loc -> identifier -> type_v -> unit
+val check_for_array     : loc -> identifier -> type_v -> unit
+
+val check_for_index_type : loc -> type_v -> unit
+val check_no_effect : loc -> Peffect.t -> unit
+val should_be_boolean : loc -> 'a
+val test_should_be_annotated : loc -> 'a
+val if_branches : loc -> 'a
+
+val check_for_not_mutable : loc -> type_v -> unit
+val check_for_pure_type : loc -> type_v -> unit
+val check_for_let_ref : loc -> type_v -> unit
+
+val variant_informative : loc -> 'a
+val should_be_informative : loc -> 'a
+
+val app_of_non_function : loc -> 'a
+val partial_app : loc -> 'a
+val expected_type : loc -> std_ppcmds -> 'a
+val expects_a_type : identifier -> loc -> 'a
+val expects_a_term : identifier -> 'a
+val should_be_a_variable : loc -> 'a
+val should_be_a_reference : loc -> 'a
diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml
new file mode 100644
index 00000000..2a35d471
--- /dev/null
+++ b/contrib/correctness/pextract.ml
@@ -0,0 +1,473 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pextract.ml,v 1.5.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Pp_control
+open Pp
+open Util
+open System
+open Names
+open Term
+open Himsg
+open Reduction
+
+open Putil
+open Ptype
+open Past
+open Penv
+open Putil
+
+let extraction env c =
+  let ren = initial_renaming env in
+  let sign = Pcicenv.now_sign_of ren env in
+  let fsign = Mach.fsign_of_sign (Evd.mt_evd()) sign in
+  match Mach.infexecute (Evd.mt_evd()) (sign,fsign) c with
+    | (_,Inf j) -> j._VAL
+    | (_,Logic) -> failwith "Prog_extract.pp: should be informative"
+
+(* les tableaux jouent un role particulier, puisqu'ils seront extraits
+ * vers des tableaux ML *)
+
+let sp_access = coq_constant ["correctness"; "Arrays"] "access"
+let access = ConstRef sp_access
+
+let has_array = ref false
+
+let pp_conversions () =
+  (str"\
+let rec int_of_pos = function
+    XH -> 1
+  | XI p -> 2 * (int_of_pos p) + 1
+  | XO p -> 2 * (int_of_pos p)
+ ++ ++
+
+let int_of_z = function
+    ZERO -> 0
+  | POS p -> int_of_pos p
+  | NEG p -> -(int_of_pos p)
+ ++ ++
+") (* '"' *)
+
+(* collect all section-path in a CIC constant *)
+
+let spset_of_cci env c =
+  let spl = Fw_env.collect (extraction env c) in
+  let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in
+  has_array := !has_array or (SpSet.mem sp_access sps) ++
+  SpSet.remove sp_access sps
+
+
+(* collect all Coq constants and all pgms appearing in a given program *)
+
+let add_id env ((sp,ids) as s) id =
+  if is_local env id then
+    s
+  else if is_global id then
+    (sp,IdSet.add id ids)
+  else
+    try (SpSet.add (Nametab.sp_of_id FW id) sp,ids) with Not_found -> s
+
+let collect env =
+  let rec collect_desc env s = function
+    | Var x -> add_id env s x
+    | Acc x -> add_id env s x
+    | Aff (x,e1) -> add_id env (collect_rec env s e1) x
+    | TabAcc (_,x,e1) ->
+	has_array := true ++
+	add_id env (collect_rec env s e1) x
+    | TabAff (_,x,e1,e2) ->
+	has_array := true ++
+	add_id env (collect_rec env (collect_rec env s e1) e2) x
+    | Seq bl ->
+	List.fold_left (fun s st -> match st with
+			    Statement p -> collect_rec env s p
+			  | _ -> s) s bl
+    | If (e1,e2,e3) ->
+    	collect_rec env (collect_rec env (collect_rec env s e1) e2) e3
+    | While (b,_,_,bl) ->
+	let s = List.fold_left (fun s st -> match st with
+				    Statement p -> collect_rec env s p
+				  | _ -> s) s bl in
+	  collect_rec env s b
+    | Lam (bl,e) ->
+	collect_rec (traverse_binders env bl) s e
+    | App (e1,l) ->
+	let s = List.fold_left (fun s a -> match a with
+				    Term t -> collect_rec env s t
+				  | Type _ | Refarg _ -> s) s l in
+	  collect_rec env s e1
+    | SApp (_,l) ->
+	List.fold_left (fun s a -> collect_rec env s a) s l
+    | LetRef (x,e1,e2) ->
+	let (_,v),_,_,_ = e1.info.kappa in
+	  collect_rec (add (x,Ref v) env) (collect_rec env s e1) e2
+    | LetIn (x,e1,e2) ->
+	let (_,v),_,_,_ = e1.info.kappa in
+	  collect_rec (add (x,v) env) (collect_rec env s e1) e2
+    | LetRec (f,bl,_,_,e) ->
+	let env' = traverse_binders env bl in
+	let env'' = add (f,make_arrow bl e.info.kappa) env' in
+	  collect_rec env'' s e
+    | Debug (_,e1) -> collect_rec env s e1
+    | PPoint (_,d) -> collect_desc env s d
+    | Expression c ->
+	let (sp,ids) = s in
+	let sp' = spset_of_cci env c in
+	SpSet.fold 
+	  (fun s (es,ei) ->
+	     let id = basename s in
+	     if is_global id then (*SpSet.add s*)es,IdSet.add id ei
+	     else SpSet.add s es,ei)
+	  sp' (sp,ids)
+
+  and collect_rec env s p = collect_desc env s p.desc
+
+  in
+  collect_rec env (SpSet.empty,IdSet.empty)
+
+
+(* On a besoin de faire du renommage, tout comme pour l'extraction des
+ * termes Coq. En ce qui concerne les globaux, on utilise la table de
+ * Fwtoml. Pour les objects locaux, on introduit la structure de
+ * renommage rename_struct
+ *)
+
+module Ocaml_ren = Ocaml.OCaml_renaming
+
+let rename_global id =
+  let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in
+  Fwtoml.add_global_renaming (id,id') ++
+  id'
+
+type rename_struct = { rn_map : identifier IdMap.t;
+		       rn_avoid : identifier list }
+
+let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] }
+
+let rename_local rn id =
+  let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in
+  { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid },
+  id'
+
+let get_local_name rn id = IdMap.find id rn.rn_map
+
+let get_name env rn id =
+  if is_local env id then
+    get_local_name rn id
+  else
+    Fwtoml.get_global_name id
+
+let rec rename_binders rn = function
+  | [] -> rn
+  | (id,_) :: bl -> let rn',_ = rename_local rn id in rename_binders rn' bl
+
+(* on a bespoin d'un pretty-printer de constr particulier, qui reconnaisse
+ * les acces a des references et dans des tableaux, et qui de plus n'imprime
+ * pas de GENTERM lorsque des identificateurs ne sont pas visibles.
+ * Il est simplifie dans la mesure ou l'on a ici que des constantes et
+ * des applications.
+ *)
+
+let putpar par s =
+  if par then (str"(" ++ s ++ str")") else s
+
+let is_ref env id =
+  try
+    (match type_in_env env id with Ref _ -> true | _ -> false)
+  with
+    Not_found -> false
+
+let rec pp_constr env rn = function
+  | VAR id ->
+      if is_ref env id then 
+	(str"!" ++ pID (get_name env rn id)) 
+      else
+	pID (get_name env rn id)
+  | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) ->
+      pID (Fwtoml.name_of_oper oper)
+  | DOPN(AppL,v) ->
+      if Array.length v = 0 then
+	  (mt ())
+      else begin
+	match v.(0) with
+	    DOPN(Const sp,_) when sp = sp_access ->
+	      (pp_constr env rn v.(3) ++ 
+		 str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")")
+	  | _ ->
+	      hov 2 (putpar true (prvect_with_sep (fun () -> (spc ()))
+				    (pp_constr env rn) v))
+      end
+  | DOP2(Cast,c,_) -> pp_constr env rn c
+  | _ -> failwith "Prog_extract.pp_constr: unexpected constr"
+
+
+(* pretty-print of imperative programs *)
+
+let collect_lambda = 
+  let rec collect acc p = match p.desc with
+    | Lam(bl,t) -> collect (bl@acc) t
+    | x         -> acc,p
+  in 
+  collect []
+
+let pr_binding rn = 
+  prlist_with_sep (fun () -> (mt ()))
+    (function 
+       | (id,(Untyped | BindType _)) -> 
+	   (str" " ++ pID (get_local_name rn id))
+       | (id,BindSet) -> (mt ()))
+
+let pp_prog id =
+  let rec pp_d env rn par = function
+    | Var x -> pID (get_name env rn x)
+    | Acc x -> (str"!" ++ pID (get_name env rn x))
+    | Aff (x,e1) -> (pID (get_name env rn x) ++ 
+		       str" := " ++ hov 0 (pp env rn false e1))
+    | TabAcc (_,x,e1) ->
+	(pID (get_name env rn x) ++ 
+	   str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")")
+    | TabAff (_,x,e1,e2) ->
+	(pID (get_name env rn x) ++
+	   str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++
+	   str" <-" ++ spc () ++ hov 2 (pp env rn false e2))
+    | Seq bl ->
+	(str"begin" ++ fnl () ++
+	   str"  " ++ hov 0 (pp_block env rn bl) ++ fnl () ++
+	   str"end")
+    | If (e1,e2,e3) ->
+	putpar par (str"if " ++ (pp env rn false e1) ++
+		      str" then" ++ fnl () ++
+		      str"  " ++ hov 0 (pp env rn false e2) ++ fnl () ++
+		      str"else" ++ fnl () ++
+		      str"  " ++ hov 0 (pp env rn false e3))
+	(* optimisations : then begin .... end else begin ... end *)
+    | While (b,inv,_,bl) ->
+	(str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++		    
+	   str"  " ++
+	   hov 0 ((match inv with
+			 None -> (mt ()) 
+		       | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++ 
+				      str" *)" ++ fnl ())) ++
+		    pp_block env rn bl) ++ fnl () ++
+	   str"done")
+    | Lam (bl,e) ->
+	let env' = traverse_binders env bl in
+	let rn' = rename_binders rn bl in
+	  putpar par 
+	    (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++
+		      spc () ++ pp env' rn' false e))
+    | SApp ((Var id)::_,  [e1; e2])
+	when id = connective_and or id = connective_or ->
+	  let conn = if id = connective_and then "&" else "or" in
+	  putpar par 
+	    (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++
+		      pp env rn true e2))
+    | SApp ((Var id)::_, [e]) when id = connective_not ->
+	putpar par 
+	  (hov 0 (str"not" ++ spc () ++ pp env rn true e))
+    | SApp _ ->
+	invalid_arg "Prog_extract.pp_prog (SApp)"
+    | App(e1,[]) ->
+	hov 0 (pp env rn false e1)
+    | App (e1,l) ->
+	putpar true
+	  (hov 2 (pp env rn true e1 ++
+		    prlist (function 
+				Term p -> (spc () ++ pp env rn true p)
+			      | Refarg x -> (spc () ++ pID (get_name env rn x))
+			      | Type _ -> (mt ())) 
+		      l))
+    | LetRef (x,e1,e2) ->
+	let (_,v),_,_,_ = e1.info.kappa in
+	let env' = add (x,Ref v) env in
+	let rn',x' = rename_local rn x in
+	putpar par 
+	  (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++
+		    str" in" ++ fnl () ++ pp env' rn' false e2))
+    | LetIn (x,e1,e2) ->
+	let (_,v),_,_,_ = e1.info.kappa in
+	let env' = add (x,v) env in
+	let rn',x' = rename_local rn x in
+	putpar par 
+	  (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++
+		    str" in" ++ fnl () ++ pp env' rn' false e2))
+    | LetRec (f,bl,_,_,e) ->
+	let env' = traverse_binders env bl in
+	let rn' = rename_binders rn bl in
+	let env'' = add (f,make_arrow bl e.info.kappa) env' in
+	let rn'',f' = rename_local rn' f in
+	putpar par 
+	  (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++
+		    str"  " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++
+		    str"in " ++ pID f'))
+    | Debug (_,e1) -> pp env rn par e1
+    | PPoint (_,d) -> pp_d env rn par d
+    | Expression c -> 
+	pp_constr env rn (extraction env c)
+
+  and pp_block env rn bl =
+    let bl =
+      map_succeed (function Statement p -> p | _ -> failwith "caught") bl
+    in
+      prlist_with_sep (fun () -> (str";" ++ fnl ()))
+      	(fun p -> hov 0 (pp env rn false p)) bl
+
+  and pp env rn par p = 
+    (pp_d env rn par p.desc)
+
+  and pp_mut v c = match v with
+    | Ref _ ->
+	(str"ref " ++ pp_constr empty rn_empty (extraction empty c))
+    | Array (n,_) ->
+	(str"Array.create " ++ cut () ++
+	   putpar true 
+	     (str"int_of_z " ++
+		pp_constr empty rn_empty (extraction empty n)) ++
+	   str" " ++ pp_constr empty rn_empty (extraction empty c))
+    | _ -> invalid_arg "pp_mut"
+  in
+  let v = lookup_global id in
+  let id' = rename_global id in
+    if is_mutable v then
+      try
+	let c = find_init id in
+	hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c)
+      with Not_found -> 
+	errorlabstrm "Prog_extract.pp_prog"
+	  (str"The variable " ++ pID id ++
+	     str" must be initialized first !")
+    else
+      match find_pgm id with
+	| None -> 
+	    errorlabstrm "Prog_extract.pp_prog"
+	      (str"The program " ++ pID id ++
+		 str" must be realized first !")
+      	| Some p ->
+	    let bl,p = collect_lambda p in
+	    let rn = rename_binders rn_empty bl in
+	    let env = traverse_binders empty bl in
+	    hov 0  (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++ 
+		      str"  " ++ hov 2 (pp env rn false p))
+
+(* extraction des programmes impératifs/fonctionnels vers ocaml *)
+
+(* Il faut parfois importer des modules non ouverts, sinon
+ * Ocaml.OCaml_pp_file.pp echoue en disant "machin is not a defined
+ * informative object". Cela dit, ce n'est pas tres satisfaisant, vu que
+ * la constante existe quand meme: il vaudrait mieux contourner l'echec
+ * de ml_import.fwsp_of_id
+ *)
+
+let import sp = match repr_path sp with
+  | [m],_,_ ->
+      begin
+	try Library.import_export_module m true
+        with _ -> ()
+      end
+  | _ -> ()
+
+let pp_ocaml file prm =
+  has_array := false ++
+  (* on separe objects Coq et programmes *)
+  let cic,pgms =
+    List.fold_left
+      (fun (sp,ids) id ->
+	 if is_global id then (sp,IdSet.add id ids) else (IdSet.add id sp,ids))
+      (IdSet.empty,IdSet.empty) prm.needed
+  in
+  (* on met les programmes dans l'ordre et pour chacun on recherche les
+   * objects Coq necessaires, que l'on rajoute a l'ensemble cic *)
+  let cic,_,pgms =
+    let o_pgms = fold_all (fun (id,_) l -> id::l) empty [] in
+    List.fold_left
+      (fun (cic,pgms,pl) id -> 
+	 if IdSet.mem id pgms then
+	   let spl,pgms' =
+	     try
+	       (match find_pgm id with
+		  | Some p -> collect empty p
+		  | None ->
+		      (try 
+			 let c = find_init id in
+			 spset_of_cci empty c,IdSet.empty
+		       with Not_found -> 
+			 SpSet.empty,IdSet.empty))
+	     with Not_found -> SpSet.empty,IdSet.empty
+	   in
+	   let cic' = 
+	     SpSet.fold 
+	       (fun sp cic -> import sp ++ IdSet.add (basename sp) cic)
+	       spl cic
+	   in
+	   (cic',IdSet.union pgms pgms',id::pl)
+	 else
+	   (cic,pgms,pl)) 
+      (cic,pgms,[]) o_pgms
+  in
+  let cic = IdSet.elements cic in
+  (* on pretty-print *)
+  let prm' = { needed = cic ++ expand = prm.expand ++ 
+	       expansion = prm.expansion ++ exact = prm.exact } 
+  in
+  let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++
+		fnl () ++ fnl () ++
+		if !has_array then pp_conversions() else (mt ()) ++
+		prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ()))
+		  pgms
+)
+  in
+  (* puis on ecrit dans le fichier *)
+  let chan = open_trapping_failure open_out file ".ml" in
+  let ft = with_output_to chan in
+  begin
+    try  pP_with ft strm ++ pp_flush_with ft ()
+    with e -> pp_flush_with ft () ++ close_out chan ++ raise e
+  end ++
+  close_out chan
+    
+
+(* Initializations of mutable objects *)
+
+let initialize id com =
+  let loc = Ast.loc com in
+  let c = constr_of_com (Evd.mt_evd()) (initial_sign()) com in
+  let ty = 
+    Reductionops.nf_betaiota (type_of (Evd.mt_evd()) (initial_sign()) c) in
+  try
+    let v = lookup_global id in
+    let ety = match v with 
+      | Ref (TypePure c) -> c | Array (_,TypePure c) -> c
+      | _ -> raise Not_found 
+    in
+    if conv (Evd.mt_evd()) ty ety then
+      initialize id c
+    else
+      errorlabstrm "Prog_extract.initialize"
+	(str"Not the expected type for the mutable " ++ pID id)
+  with Not_found -> 
+    errorlabstrm "Prog_extract.initialize"
+      (pr_id id ++ str" is not a mutable")
+
+(* grammaire *)
+
+open Vernacinterp
+
+let _ = vinterp_add "IMPERATIVEEXTRACTION"
+	  (function 
+	     | VARG_STRING file :: rem ->
+		 let prm = parse_param rem in (fun () -> pp_ocaml file prm)
+	     | _ -> assert false)
+	  
+let _ = vinterp_add "INITIALIZE"
+	  (function 
+	     | [VARG_IDENTIFIER id; VARG_COMMAND com] ->
+		 (fun () -> initialize id com)
+	     | _ -> assert false)
diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli
new file mode 100644
index 00000000..dc5b4124
--- /dev/null
+++ b/contrib/correctness/pextract.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pextract.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+
+val pp_ocaml : string -> unit
+
+
diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml
new file mode 100644
index 00000000..aed8c5cb
--- /dev/null
+++ b/contrib/correctness/pmisc.ml
@@ -0,0 +1,222 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pmisc.ml,v 1.18.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Libnames
+open Topconstr
+
+(* debug *)
+
+let deb_mess s =
+  if !Options.debug then begin
+    msgnl s; pp_flush()
+  end
+
+let deb_print f x =
+  if !Options.debug then begin
+    msgnl (f x); pp_flush()
+  end
+
+let list_of_some = function
+    None -> []
+  | Some x -> [x]
+
+let difference l1 l2 =
+  let rec diff = function
+      [] -> []
+    | a::rem -> if List.mem a l2 then diff rem else a::(diff rem)
+  in
+    diff l1
+
+(* TODO: these functions should be moved in the code of Coq *)
+
+let reraise_with_loc loc f x =
+  try f x with Util.UserError (_,_) as e -> Stdpp.raise_with_loc loc e
+
+
+(* functions on names *)
+
+let at = if !Options.v7 then "@" else "'at'"
+
+let at_id id d = id_of_string ((string_of_id id) ^ at ^ d)
+
+let is_at id =
+  try
+    let _ = string_index_from (string_of_id id) 0 at in true
+  with Not_found ->
+    false
+
+let un_at id =
+  let s = string_of_id id in
+    try
+      let n = string_index_from s 0 at in
+    	id_of_string (String.sub s 0 n),
+	String.sub s (n + String.length at)
+          (String.length s - n - String.length at)
+    with Not_found ->
+      invalid_arg "un_at"
+
+let renaming_of_ids avoid ids =
+  let rec rename avoid = function
+      [] -> [], avoid
+    | x::rem ->
+	let al,avoid = rename avoid rem in
+	let x' = next_ident_away x avoid in
+	  (x,x')::al, x'::avoid
+  in
+    rename avoid ids
+
+let result_id = id_of_string "result"
+
+let adr_id id = id_of_string ("adr_" ^ (string_of_id id))
+
+(* hypotheses names *)
+
+let next s r = function
+    Anonymous -> incr r; id_of_string (s ^ string_of_int !r)
+  | Name id -> id
+
+let reset_names,pre_name,post_name,inv_name,
+    test_name,bool_name,var_name,phi_name,for_name,label_name =
+  let pre = ref 0 in
+  let post = ref 0 in
+  let inv = ref 0 in
+  let test = ref 0 in
+  let bool = ref 0 in
+  let var = ref 0 in
+  let phi = ref 0 in
+  let forr = ref 0 in
+  let label = ref 0 in
+    (fun () -> 
+       pre := 0; post := 0; inv := 0; test := 0; 
+       bool := 0; var := 0; phi := 0; label := 0),
+    (next "Pre" pre),
+    (next "Post" post),
+    (next "Inv" inv),
+    (next "Test" test),
+    (fun () -> next "Bool" bool Anonymous),
+    (next "Variant" var),
+    (fun () -> next "rphi" phi Anonymous),
+    (fun () -> next "for" forr Anonymous),
+    (fun () -> string_of_id (next "Label" label Anonymous))
+
+let default = id_of_string "x_"
+let id_of_name = function Name id -> id | Anonymous -> default
+
+
+(* functions on CIC terms *)
+
+let isevar = Evarutil.new_evar_in_sign (Global.env ())
+
+(* Substitutions of variables by others. *)
+let subst_in_constr alist =
+  let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in
+  replace_vars alist'
+
+(*
+let subst_in_ast alist ast =
+  let rec subst = function
+      Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s)
+    | Node(l,s,args) -> Node(l,s,List.map subst args)
+    | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
+    | x -> x
+  in
+    subst ast
+*)
+(*
+let subst_ast_in_ast alist ast =
+  let rec subst = function
+      Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x)
+    | Node(l,s,args) -> Node(l,s,List.map subst args)
+    | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
+    | x -> x
+  in
+    subst ast
+*)
+
+let rec subst_in_ast alist = function
+  | CRef (Ident (loc,id)) ->
+      CRef (Ident (loc,(try List.assoc id alist with Not_found -> id)))
+  | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x
+
+let rec subst_ast_in_ast alist = function
+  | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x)
+  | x ->
+      map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x
+
+(* subst. of variables by constr *)
+let real_subst_in_constr = replace_vars
+
+(* Coq constants *)
+
+let coq_constant d s =
+  Libnames.encode_kn
+    (make_dirpath (List.rev (List.map id_of_string ("Coq"::d))))
+    (id_of_string s)
+
+let bool_sp = coq_constant ["Init"; "Datatypes"] "bool"
+let coq_true = mkConstruct ((bool_sp,0),1)
+let coq_false = mkConstruct ((bool_sp,0),2)
+
+let constant s =
+  let id = Constrextern.id_of_v7_string s in
+  Constrintern.global_reference id
+
+let connective_and = id_of_string "prog_bool_and"
+let connective_or  = id_of_string "prog_bool_or"
+let connective_not = id_of_string "prog_bool_not"
+
+let is_connective id =
+  id = connective_and or id = connective_or or id = connective_not
+
+(* [conj i s] constructs the conjunction of two constr *)
+
+let conj i s = Term.applist (constant "and", [i; s])
+
+(* [n_mkNamedProd v [xn,tn;...;x1,t1]] constructs the type 
+   [(x1:t1)...(xn:tn)v] *)
+
+let rec n_mkNamedProd v = function
+  | [] -> v
+  | (id,ty) :: rem -> n_mkNamedProd (Term.mkNamedProd id ty v) rem
+
+(* [n_lambda v [xn,tn;...;x1,t1]] constructs the type [x1:t1]...[xn:tn]v *)
+
+let rec n_lambda v = function
+  | [] -> v
+  | (id,ty) :: rem -> n_lambda (Term.mkNamedLambda id ty v) rem
+
+(* [abstract env idl c] constructs [x1]...[xn]c where idl = [x1;...;xn] *)
+
+let abstract ids c = n_lambda c (List.rev ids)
+
+(* substitutivity (of kernel names, for modules management) *)
+
+open Ptype
+
+let rec type_v_knsubst s = function
+  | Ref v -> Ref (type_v_knsubst s v)
+  | Array (c, v) -> Array (subst_mps s c, type_v_knsubst s v)
+  | Arrow (bl, c) -> Arrow (List.map (binder_knsubst s) bl, type_c_knsubst s c)
+  | TypePure c -> TypePure (subst_mps s c)
+
+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)
+
+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
new file mode 100644
index 00000000..ec7521cc
--- /dev/null
+++ b/contrib/correctness/pmisc.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pmisc.mli,v 1.9.6.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+open Term
+open Ptype
+open Topconstr
+
+(* Some misc. functions *)
+
+val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b
+
+val list_of_some : 'a option -> 'a list
+val difference : 'a list -> 'a list -> 'a list
+
+val at_id : identifier -> string -> identifier
+val un_at : identifier -> identifier * string
+val is_at : identifier -> bool
+
+val result_id : identifier
+val adr_id : identifier -> identifier
+
+val renaming_of_ids : identifier list -> identifier list
+                     -> (identifier * identifier) list * identifier list
+
+val reset_names : unit -> unit
+val pre_name    : name -> identifier
+val post_name   : name -> identifier
+val inv_name    : name -> identifier
+val test_name   : name -> identifier
+val bool_name   : unit -> identifier
+val var_name    : name -> identifier
+val phi_name    : unit -> identifier
+val for_name    : unit -> identifier
+val label_name  : unit -> string
+
+val id_of_name : name -> identifier
+
+(* CIC terms *)
+
+val isevar : constr
+
+val subst_in_constr : (identifier * identifier) list -> constr -> constr
+val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr
+val subst_ast_in_ast :
+  (identifier * constr_expr) list -> constr_expr -> constr_expr
+val real_subst_in_constr : (identifier * constr) list -> constr -> constr
+
+val constant : string -> constr
+val coq_constant : string list -> string -> kernel_name
+val conj : constr -> constr -> constr
+
+val coq_true : constr
+val coq_false : constr
+
+val connective_and : identifier
+val connective_or  : identifier
+val connective_not : identifier
+val is_connective : identifier -> bool
+
+val n_mkNamedProd : constr -> (identifier * constr) list -> constr
+val n_lambda  : constr -> (identifier * constr) list -> constr
+val abstract : (identifier * constr) list -> constr -> constr
+
+val type_v_knsubst : substitution -> type_v -> type_v
+val type_c_knsubst : substitution -> type_c -> type_c
+
+(* for debugging purposes *)
+
+val deb_mess : Pp.std_ppcmds -> unit
+val deb_print : ('a -> Pp.std_ppcmds) -> 'a -> unit
+
diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml
new file mode 100644
index 00000000..f899366d
--- /dev/null
+++ b/contrib/correctness/pmlize.ml
@@ -0,0 +1,320 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pmlize.ml,v 1.7.2.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Names
+open Term
+open Termast
+open Pattern
+open Matching
+
+open Pmisc
+open Ptype
+open Past
+open Putil
+open Prename
+open Penv
+open Peffect
+open Ptyping
+open Pmonad
+
+
+let has_proof_part ren env c =
+  let sign = Pcicenv.trad_sign_of ren env in
+  let ty = Typing.type_of (Global.env_of_context sign) Evd.empty c in
+  Hipattern.is_matching_sigma (Reductionops.nf_betaiota ty)
+
+(* main part: translation of imperative programs into functional ones.
+ * 
+ * [env] is the environment
+ * [ren] is the current renamings of variables
+ * [t] is the imperative program to translate, annotated with type+effects
+ *
+ * we return the translated program in type cc_term
+ *)
+
+let rec trad ren t =
+  let env = t.info.env in
+  trad_desc ren env t.info.kappa t.desc
+
+and trad_desc ren env ct d =
+  let (_,tt),eft,pt,qt = ct in
+  match d with
+
+  | Expression c ->
+      let ids = get_reads eft in
+      let al = current_vars ren ids in
+      let c' = subst_in_constr al c in
+      if has_proof_part ren env c' then
+	CC_expr c'
+      else
+      	let ty = trad_ml_type_v ren env tt in
+      	make_tuple [ CC_expr c',ty ] qt ren env (current_date ren)
+      
+  | Variable id ->
+      if is_mutable_in_env env id then
+	invalid_arg "Mlise.trad_desc"
+      else if is_local env id then
+	CC_var id
+      else
+	CC_expr (constant (string_of_id id))
+
+  | Acc _ ->
+      failwith "Mlise.trad: pure terms are supposed to be expressions"
+
+  | TabAcc (check, x, e1) ->
+      let _,ty_elem,_ = array_info ren env x in
+      let te1 = trad ren e1 in
+      let (_,ef1,p1,q1) = e1.info.kappa in
+      let w = get_writes ef1 in
+      let ren' = next ren w in
+      let id = id_of_string "index" in
+      let access = 
+	make_raw_access ren' env (x,current_var ren' x) (mkVar id) 
+      in
+      let t,ty = result_tuple ren' (current_date ren) env
+		   (CC_expr access, ty_elem) (eft,qt) in
+      let t =
+	if check then 
+	  let h = make_pre_access ren env x (mkVar id) in 
+	  let_in_pre ty (anonymous_pre true h) t
+	else
+	  t 
+      in
+      make_let_in ren env te1 p1
+	(current_vars ren' w,q1) (id,constant "Z") (t,ty)
+
+  | Aff (x, e1) ->
+      let tx = trad_type_in_env ren env x in
+      let te1 = trad ren e1 in
+      let (_,ef1,p1,q1) = e1.info.kappa in
+      let w1 = get_writes ef1 in
+      let ren' = next ren (x::w1) in
+      let t_ty = result_tuple ren' (current_date ren) env
+		   (CC_expr (constant "tt"), constant "unit") (eft,qt) 
+      in
+      make_let_in ren env te1 p1
+	(current_vars ren' w1,q1) (current_var ren' x,tx) t_ty
+
+  | TabAff (check, x, e1, e2) ->
+      let _,ty_elem,ty_array = array_info ren env x in
+      let te1 = trad ren e1 in
+      let (_,ef1,p1,q1) = e1.info.kappa in
+      let w1 = get_writes ef1 in
+      let ren' = next ren w1 in
+      let te2 = trad ren' e2 in
+      let (_,ef2,p2,q2) = e2.info.kappa in
+      let w2 = get_writes ef2 in
+      let ren'' = next ren' w2 in
+      let id1 = id_of_string "index" in
+      let id2 = id_of_string "v" in
+      let ren''' = next ren'' [x] in
+      let t,ty = result_tuple ren''' (current_date ren) env
+		   (CC_expr (constant "tt"), constant "unit") (eft,qt) in
+      let store = make_raw_store ren'' env (x,current_var ren'' x) (mkVar id1)
+		   (mkVar id2) in
+      let t = make_let_in ren'' env (CC_expr store) [] ([],None) 
+		(current_var ren''' x,ty_array) (t,ty) in
+      let t = make_let_in ren' env te2 p2
+     	(current_vars ren'' w2,q2) (id2,ty_elem) (t,ty) in
+      let t = 
+	if check then
+	  let h = make_pre_access ren' env x (mkVar id1) in
+	  let_in_pre ty (anonymous_pre true h) t
+	else
+	  t 
+      in
+      make_let_in ren env te1 p1
+	(current_vars ren' w1,q1) (id1,constant "Z") (t,ty)
+
+  | Seq bl ->
+      let before = current_date ren in
+      let finish ren = function
+	  Some (id,ty) -> 
+	    result_tuple ren before env (CC_var id, ty) (eft,qt)
+	| None ->
+	    failwith "a block should contain at least one statement"
+      in
+      let bl = trad_block ren env bl in
+      make_block ren env finish bl
+
+  | If (b, e1, e2) ->
+      let tb = trad ren b in
+      let _,efb,_,_ = b.info.kappa in
+      let ren' = next ren (get_writes efb) in
+      let te1 = trad ren' e1 in
+      let te2 = trad ren' e2 in
+      make_if ren env (tb,b.info.kappa) ren' (te1,e1.info.kappa) 
+	(te2,e2.info.kappa) ct
+
+  (* Translation of the while. *)
+
+  | While (b, inv, var, bl) ->
+      let ren' = next ren (get_writes eft) in
+      let tb = trad ren' b in
+      let tbl = trad_block ren' env bl in
+      let var' = typed_var ren env var in
+      make_while ren env var' (tb,b.info.kappa) tbl (inv,ct)
+
+  | Lam (bl, e) ->
+      let bl' = trad_binders ren env bl in
+      let env' = traverse_binders env bl in
+      let ren' = initial_renaming env' in
+      let te = trans ren' e in
+      CC_lam (bl', te)
+
+  | SApp ([Variable id; Expression q1; Expression q2], [e1; e2])
+      when id = connective_and or id = connective_or ->
+      let c = constant (string_of_id id) in
+      let te1 = trad ren e1
+      and te2 = trad ren e2 in
+      let q1' = apply_post ren env (current_date ren) (anonymous q1)
+      and q2' = apply_post ren env (current_date ren) (anonymous q2) in
+      CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2])
+
+  | SApp ([Variable id; Expression q], [e]) when id = connective_not ->
+      let c = constant (string_of_id id) in
+      let te = trad ren e in
+      let q' = apply_post ren env (current_date ren) (anonymous q) in
+      CC_app (CC_expr c, [CC_expr q'.a_value; te])
+
+  | SApp _ ->
+      invalid_arg "mlise.trad (SApp)"
+
+  | Apply (f, args) ->
+      let trad_arg (ren,args) = function
+	| Term a ->
+	    let ((_,tya),efa,_,_) as ca = a.info.kappa in
+	    let ta = trad ren a in
+	    let w = get_writes efa in
+	    let ren' = next ren w in
+	    ren', ta::args
+	| Refarg _ ->
+	    ren, args
+	| Type v -> 
+	    let c = trad_ml_type_v ren env v in
+	    ren, (CC_expr c)::args
+      in
+      let ren',targs = List.fold_left trad_arg (ren,[]) args in
+      let tf = trad ren' f in
+      let cf = f.info.kappa in
+      let c,(s,_,_),capp = effect_app ren env f args in
+      let tc_args =
+	List.combine
+	  (List.rev targs)
+	  (Util.map_succeed
+	     (function
+		| Term x -> x.info.kappa
+		| Refarg _ -> failwith "caught"
+		| Type _ -> 
+		    (result_id,TypePure mkSet),Peffect.bottom,[],None)
+	     args)
+      in
+      make_app env ren tc_args ren' (tf,cf) (c,s,capp) ct
+	
+  | LetRef (x, e1, e2) ->
+      let (_,v1),ef1,p1,q1 = e1.info.kappa in
+      let te1 = trad ren e1 in
+      let tv1 = trad_ml_type_v ren env v1 in
+      let env' = add (x,Ref v1) env in
+      let ren' = next ren [x] in
+      let (_,v2),ef2,p2,q2 = e2.info.kappa in
+      let tv2 = trad_ml_type_v ren' env' v2 in
+      let te2 = trad ren' e2 in
+      let ren'' = next ren' (get_writes ef2) in
+      let t,ty = result_tuple ren'' (current_date ren) env
+		   (CC_var result_id, tv2) (eft,qt) in
+      let t = make_let_in ren' env' te2 p2
+		(current_vars ren'' (get_writes ef2),q2)
+		(result_id,tv2) (t,ty) in
+      let t = make_let_in ren env te1 p1
+     		(current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) 
+      in
+      t
+
+  | Let (x, e1, e2) ->
+      let (_,v1),ef1,p1,q1 = e1.info.kappa in
+      let te1 = trad ren e1 in
+      let tv1 = trad_ml_type_v ren env v1 in
+      let env' = add (x,v1) env in
+      let ren' = next ren (get_writes ef1) in
+      let (_,v2),ef2,p2,q2 = e2.info.kappa in
+      let tv2 = trad_ml_type_v ren' env' v2 in
+      let te2 = trad ren' e2 in
+      let ren'' = next ren' (get_writes ef2) in
+      let t,ty = result_tuple ren'' (current_date ren) env
+		   (CC_var result_id, tv2) (eft,qt) in
+      let t = make_let_in ren' env' te2 p2
+		(current_vars ren'' (get_writes ef2),q2)
+		(result_id,tv2) (t,ty) in
+      let t = make_let_in ren env te1 p1
+     		(current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) 
+      in
+      t
+
+  | LetRec (f,bl,v,var,e) ->
+      let (_,ef,_,_) as c = 
+	match tt with Arrow(_,c) -> c | _ -> assert false in
+      let bl' = trad_binders ren env bl in
+      let env' = traverse_binders env bl in
+      let ren' = initial_renaming env' in
+      let (phi0,var') = find_recursion f e.info.env in
+      let te = trad ren' e in
+      let t = make_letrec ren' env' (phi0,var') f bl' (te,e.info.kappa) c in
+      CC_lam (bl', t)
+
+  | PPoint (s,d) ->       
+      let ren' = push_date ren s in
+      trad_desc ren' env ct d
+
+  | Debug _ -> failwith "Mlise.trad: Debug: not implemented"
+
+
+and trad_binders ren env = function
+  | [] -> 
+      []
+  | (_,BindType (Ref _ | Array _))::bl ->
+      trad_binders ren env bl
+  | (id,BindType v)::bl ->
+      let tt = trad_ml_type_v ren env v in
+      (id, CC_typed_binder tt) :: (trad_binders ren env bl)
+  | (id,BindSet)::bl ->
+      (id, CC_typed_binder mkSet) :: (trad_binders ren env bl)
+  | (_,Untyped)::_ -> invalid_arg "trad_binders"
+
+	
+and trad_block ren env = function
+  | [] -> 
+      []
+  | (Assert c)::block ->
+      (Assert c)::(trad_block ren env block)
+  | (Label s)::block ->
+      let ren' = push_date ren s in
+      (Label s)::(trad_block ren' env block)
+  | (Statement e)::block ->
+      let te = trad ren e in
+      let _,efe,_,_ = e.info.kappa in
+      let w = get_writes efe in
+      let ren' = next ren w in
+      (Statement (te,e.info.kappa))::(trad_block ren' env block)
+
+
+and trans ren e =
+  let env = e.info.env in
+  let _,ef,p,_ = e.info.kappa in
+  let ty = trad_ml_type_c ren env e.info.kappa in
+  let ids = get_reads ef in
+  let al = current_vars ren ids in
+  let c = trad ren e in
+  let c = abs_pre ren env (c,ty) p in
+  let bl = binding_of_alist ren env al in
+  make_abs (List.rev bl) c
+
diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli
new file mode 100644
index 00000000..95f74ef9
--- /dev/null
+++ b/contrib/correctness/pmlize.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: pmlize.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *)
+
+open Past
+open Penv
+open Names
+
+(* translation of imperative programs into intermediate functional programs *)
+
+val trans : Prename.t -> typed_program -> cc_term
+
diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml
new file mode 100644
index 00000000..b8b39353
--- /dev/null
+++ b/contrib/correctness/pmonad.ml
@@ -0,0 +1,665 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pmonad.ml,v 1.6.16.1 2004/07/16 19:30:02 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Termast
+
+open Pmisc
+open Putil
+open Ptype
+open Past
+open Prename
+open Penv
+open Pcic
+open Peffect
+
+
+(* [product ren [y1,z1;...;yk,zk] q] constructs
+ * the (possibly dependent) tuple type
+ *
+ *      z1 x ... x zk                             if no post-condition
+ * or   \exists. y1:z1. ... yk:zk. (Q x1 ... xn)  otherwise
+ *
+ * where the xi are given by the renaming [ren].
+ *)
+
+let product_name = function
+  | 2 -> "prod"
+  | n -> check_product_n n; Printf.sprintf "tuple_%d" n
+
+let dep_product_name = function
+  | 1 -> "sig"
+  | n -> check_dep_product_n n; Printf.sprintf "sig_%d" n
+
+let product ren env before lo = function
+  | None -> (* non dependent case *)
+      begin match lo with
+	| [_,v] -> v
+	| _ ->
+	    let s = product_name (List.length lo) in
+      	    Term.applist (constant s, List.map snd lo)
+      end
+  | Some q -> (* dependent case *)
+      let s = dep_product_name (List.length lo) in
+      let a' = apply_post ren env before q in
+      Term.applist (constant s, (List.map snd lo) @ [a'.a_value])
+	
+(* [arrow ren v pl] abstracts the term v over the pre-condition if any
+ * i.e. computes
+ *
+ *     (P1 x1 ... xn) -> ... -> (Pk x1 ... xn) -> v
+ * 
+ * where the xi are given by the renaming [ren].
+ *)
+
+let arrow ren env v pl =
+  List.fold_left 
+    (fun t p -> 
+       if p.p_assert then t else Term.mkArrow (apply_pre ren env p).p_value t) 
+    v pl
+	
+(* [abstract_post ren env (e,q) (res,v)] abstract a post-condition q
+ * over the write-variables of e *)
+
+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 tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in
+  option_app (named_app (abstract tgo)) q
+
+(* Translation of effects types in cic types.
+ *
+ * [trad_ml_type_v] and [trad_ml_type_c] translate types with effects
+ * into cic types.
+ *)
+
+and prod ren env g = 
+  List.map
+    (fun id -> (current_var ren id, trad_type_in_env ren env id)) 
+    g
+
+and input ren env e  =
+  let i,_ = Peffect.get_repr e in
+  prod ren env i
+
+and output ren env ((id,v),e) =
+  let tv = trad_ml_type_v ren env v in
+  let _,o = Peffect.get_repr e in
+  (prod ren env o) @ [id,tv]
+
+and input_output ren env c =
+  let ((res,v),e,_,_) = c in
+  input ren env e, output ren env ((res,v),e)
+
+(* The function t -> \barre{t} on V and C. *)
+
+and trad_ml_type_c ren env c =
+  let ((res,v),e,p,q) = c in
+  let q = abstract_post ren env (e,q) in
+  let lo = output ren env ((res,v),e) in
+  let ty = product ren env (current_date ren) lo q in
+  let ty = arrow ren env ty p in
+  let li = input ren env e in
+  n_mkNamedProd ty li
+
+and trad_ml_type_v ren env = function
+    
+  | Ref _ | Array _ -> invalid_arg "Monad.trad_ml_type_v"
+	
+  | Arrow (bl, c) ->
+      let bl',ren',env' =
+	List.fold_left
+	  (fun (bl,ren,env) b -> match b with
+	     | (id,BindType ((Ref _ | Array _) as v)) ->
+		 let env' = add (id,v) env in
+		 let ren' = initial_renaming env' in
+		 (bl,ren',env')
+	     | (id,BindType v) -> 
+		 let tt = trad_ml_type_v ren env v in
+		 let env' = add (id,v) env in
+		 let ren' = initial_renaming env' in
+		 (id,tt)::bl,ren',env'
+	     | (id, BindSet) ->
+		 (id,mkSet) :: bl,ren,env
+	     | _ -> failwith "Monad: trad_ml_type_v: not yet implemented"
+ 	  )
+ 	  ([],ren,env) bl 
+      in
+      n_mkNamedProd (trad_ml_type_c ren' env' c) bl'
+	
+  | TypePure c ->
+      (apply_pre ren env (anonymous_pre false c)).p_value
+
+and trad_imp_type ren env = function
+  | Ref v        -> trad_ml_type_v ren env v
+  | Array (c,v)  -> Term.applist (constant "array", 
+				  [c; trad_ml_type_v ren env v])
+  | _            -> invalid_arg "Monad.trad_imp_type"
+
+and trad_type_in_env ren env id =
+  let v = type_in_env env id in trad_imp_type ren env v
+
+
+
+(* bindings *)
+
+let binding_of_alist ren env al =
+  List.map
+    (fun (id,id') -> (id', CC_typed_binder (trad_type_in_env ren env id)))
+    al
+
+
+(* [make_abs bl t p] abstracts t w.r.t binding list bl., that is
+ * [x1:t1]...[xn:tn]t. Returns t if the binding is empty. *)
+
+let make_abs bl t = match bl with
+  | [] -> t
+  | _  -> CC_lam (bl, t)
+
+
+(* [result_tuple ren before env (res,v) (ef,q)] constructs the tuple 
+ *
+ *    (y1,...,yn,res,?::(q/ren y1 ... yn res))
+ *
+ * where the yi are the values of the output of ef.
+ * if there is no yi and no post-condition, it is simplified in res itself.
+ *)
+
+let simple_constr_of_prog = function
+  | CC_expr c -> c
+  | CC_var id -> mkVar id
+  | _ -> assert false
+
+let make_tuple l q ren env before = match l with
+  | [e,_] when q = None -> 
+      e
+  | _ ->
+      let tl = List.map snd l in
+      let dep,h,th = match q with
+	| None -> false,[],[]
+	| Some c ->
+	    let args = List.map (fun (e,_) -> simple_constr_of_prog e) l in
+	    let c = apply_post ren env before c in
+	    true,
+	    [ CC_hole (Term.applist (c.a_value, args)) ], (* hole *)
+	    [ c.a_value ]                     (* type of the hole *)
+      in 
+      CC_tuple (dep, tl @ th, (List.map fst l) @ h)
+
+let result_tuple ren before env (res,v) (ef,q) =
+  let ids = get_writes ef in
+  let lo = 
+    (List.map (fun id -> 
+		 let id' = current_var ren id in
+		 CC_var id', trad_type_in_env ren env id) ids)
+    @ [res,v]
+  in
+  let q = abstract_post ren env (ef,q) in
+  make_tuple lo q ren env before,
+  product ren env before lo q
+
+
+(* [make_let_in ren env fe p (vo,q) (res,v) t] constructs the term
+   
+        [ let h1 = ?:P1 in ... let hn = ?:Pm in ]
+          let y1,y2,...,yn, res [,q] = fe in
+          t
+
+   vo=[_,y1;...;_,ym] are list of renamings.
+   v is the type of res
+   *)
+
+let let_in_pre ty p t =
+  let h = p.p_value in
+  CC_letin (false, ty, [pre_name p.p_name,CC_typed_binder h], CC_hole h, t)
+
+let multiple_let_in_pre ty hl t =
+  List.fold_left (fun t h -> let_in_pre ty h t) t hl
+
+let make_let_in ren env fe p (vo,q) (res,tyres) (t,ty) =
+  let b = [res, CC_typed_binder tyres] in
+  let b',dep = match q with
+    | None -> [],false
+    | Some q -> [post_name q.a_name, CC_untyped_binder],true 
+  in
+  let bl = (binding_of_alist ren env vo) @ b @ b' in
+  let tyapp =
+    let n = succ (List.length vo) in
+    let name = match q with None -> product_name n | _ -> dep_product_name n in
+    constant name 
+  in
+  let t = CC_letin (dep, ty, bl, fe, t) in
+  multiple_let_in_pre ty (List.map (apply_pre ren env) p) t
+
+
+(* [abs_pre ren env (t,ty) pl] abstracts a term t with respect to the 
+ * list of pre-conditions [pl]. Some of them are real pre-conditions
+ * and others are assertions, according to the boolean field p_assert,
+ * so we construct the term
+ *   [h1:P1]...[hn:Pn]let h'1 = ?:P'1 in ... let H'm = ?:P'm in t
+ *)
+
+let abs_pre ren env (t,ty) pl =
+  List.fold_left
+    (fun t p ->
+       if p.p_assert then
+	 let_in_pre ty (apply_pre ren env p) t
+       else
+	 let h = pre_name p.p_name in 
+	 CC_lam ([h,CC_typed_binder (apply_pre ren env p).p_value],t))
+    t pl
+    
+
+(* [make_block ren env finish bl] builds the translation of a block
+ * finish is the function that is applied to the result at the end of the
+ * block. *)
+
+let make_block ren env finish bl =
+  let rec rec_block ren result = function
+    | [] ->
+	finish ren result
+    | (Assert c) :: block ->
+	let t,ty = rec_block ren result block in
+	let c = apply_assert ren env c in
+	let p = { p_assert = true; p_name = c.a_name; p_value = c.a_value } in
+	let_in_pre ty p t, ty
+    | (Label s) :: block ->
+	let ren' = push_date ren s in
+	rec_block ren' result block
+    | (Statement (te,info)) :: block ->
+	let (_,tye),efe,pe,qe = info in
+	let w = get_writes efe in
+	let ren' = next ren w in
+	let id = result_id in
+	let tye = trad_ml_type_v ren env tye in
+	let t = rec_block ren' (Some (id,tye)) block in
+	make_let_in ren env te pe (current_vars ren' w,qe) (id,tye) t,
+	snd t
+  in
+  let t,_ = rec_block ren None bl in
+  t
+
+
+(* [make_app env ren args ren' (tf,cf) (cb,s,capp) c]
+ * constructs the application of [tf] to [args].
+ * capp is the effect of application, after substitution (s) and cb before
+ *)
+
+let eq ty e1 e2 =
+  Term.applist (constant "eq", [ty; e1; e2])
+
+let lt r e1 e2 =
+  Term.applist (r, [e1; e2])
+
+let is_recursive env = function
+  | CC_var x -> 
+      (try let _ = find_recursion x env in true with Not_found -> false)
+  | _ -> false
+
+let if_recursion env f = function
+  | CC_var x ->
+      (try let v = find_recursion x env in (f v x) with Not_found -> [])
+  | _ -> []
+
+let dec_phi ren env s svi =
+  if_recursion env
+    (fun (phi0,(cphi,r,_)) f -> 
+       let phi = subst_in_constr svi (subst_in_constr s cphi) in
+       let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
+       [CC_expr phi; CC_hole (lt r phi (mkVar phi0))])
+
+let eq_phi ren env s svi =
+  if_recursion env
+    (fun (phi0,(cphi,_,a)) f ->
+       let phi = subst_in_constr svi (subst_in_constr s cphi) in
+       let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
+       [CC_hole (eq a phi phi)])
+
+let is_ref_binder = function 
+  | (_,BindType (Ref _ | Array _)) -> true
+  | _ -> false
+
+let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c =
+  let ((_,tvf),ef,pf,qf) = cf in
+  let (_,eapp,papp,qapp) = capp in
+  let ((_,v),e,p,q) = c in
+  let bl = List.filter (fun b -> not (is_ref_binder b)) bl in
+  let recur = is_recursive env tf in
+  let before = current_date ren in
+  let ren'' = next ren' (get_writes ef) in
+  let ren''' = next ren'' (get_writes eapp) in
+  let res = result_id in
+  let vi,svi =
+    let ids = List.map fst bl in 
+    let s = fresh (avoid ren ids) ids in
+    List.map snd s, s
+  in
+  let tyres = subst_in_constr svi (trad_ml_type_v ren env v) in
+  let t,ty = result_tuple ren''' before env (CC_var res, tyres) (e,q) in
+  let res_f = id_of_string "vf" in
+  let inf,outf =
+    let i,o = let _,e,_,_ = cb in get_reads e, get_writes e in
+    let apply_s = List.map (fun id -> try List.assoc id s with _ -> id) in
+    apply_s i, apply_s o
+  in
+  let fe =
+    let xi = List.rev (List.map snd (current_vars ren'' inf)) in
+    let holes = List.map (fun x -> (apply_pre ren'' env x).p_value)
+		  (List.map (pre_app (subst_in_constr svi)) papp) in
+    CC_app ((if recur then tf else CC_var res_f),
+	    (dec_phi ren'' env s svi tf) 
+	    @(List.map (fun id -> CC_var id) (vi @ xi))
+	    @(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 t = 
+    make_let_in ren'' env fe [] (current_vars ren''' outf,qapp')
+      (res,tyres) (t,ty)
+  in
+  let t =
+    if recur then 
+      t
+    else
+      make_let_in ren' env tf pf
+	(current_vars ren'' (get_writes ef),qf)
+	(res_f,trad_ml_type_v ren env tvf) (t,ty)
+  in
+  let rec eval_args ren = function
+    | [] -> t
+    | (vx,(ta,((_,tva),ea,pa,qa)))::args ->
+	let w = get_writes ea in
+	let ren' = next ren w in
+	let t' = eval_args ren' args in
+	make_let_in ren env ta pa (current_vars ren' (get_writes ea),qa)
+	  (vx,trad_ml_type_v ren env tva) (t',ty)
+  in
+  eval_args ren (List.combine vi args)
+
+
+(* [make_if ren env (tb,cb) ren' (t1,c1) (t2,c2)]
+ * constructs the term corresponding to a if expression, i.e
+ *
+ *       [p] let o1, b [,q1] = m1 [?::p1] in
+ *           Cases b of
+ *              R => let o2, v2 [,q2] = t1  [?::p2] in 
+ *                   (proj (o1,o2)), v2 [,?::q] 
+ *            | S => let o2, v2 [,q2] = t2  [?::p2] in 
+ *                   (proj (o1,o2)), v2 [,?::q] 
+ *)
+
+let make_if_case ren env ty (b,qb) (br1,br2) =
+  let id_b,ty',ty1,ty2 = match qb with
+    | Some q ->  
+  	let q = apply_post ren env (current_date ren) q in
+    	let (name,t1,t2) = Term.destLambda q.a_value in
+	q.a_name,
+    	Term.mkLambda (name, t1, mkArrow t2 ty),
+	Term.mkApp (q.a_value, [| coq_true |]),
+	Term.mkApp (q.a_value, [| coq_false |])
+    | None -> assert false
+  in
+  let n = test_name Anonymous in
+  CC_app (CC_case (ty', b, [CC_lam ([n,CC_typed_binder ty1], br1);
+			    CC_lam ([n,CC_typed_binder ty2], br2)]),
+	  [CC_var (post_name id_b)])
+
+let make_if ren env (tb,cb) ren' (t1,c1) (t2,c2) c =
+  let ((_,tvb),eb,pb,qb) = cb in
+  let ((_,tv1),e1,p1,q1) = c1 in
+  let ((_,tv2),e2,p2,q2) = c2 in
+  let ((_,t),e,p,q) = c in
+
+  let wb = get_writes eb in
+  let resb = id_of_string "resultb" in
+  let res = result_id in
+  let tyb = trad_ml_type_v ren' env tvb in
+  let tt = trad_ml_type_v ren env t in
+
+  (* une branche de if *)
+  let branch (tv_br,e_br,p_br,q_br) f_br  = 
+    let w_br = get_writes e_br in
+    let ren'' = next ren' w_br in
+    let t,ty = result_tuple ren'' (current_date ren') env
+		 (CC_var res,tt) (e,q) in
+    make_let_in ren' env f_br p_br (current_vars ren'' w_br,q_br)
+      (res,tt) (t,ty),
+    ty
+  in
+  let t1,ty1 = branch c1 t1 in
+  let t2,ty2 = branch c2 t2 in
+  let ty = ty1 in
+  let qb = force_bool_name qb in
+  let t = make_if_case ren env ty (CC_var resb,qb) (t1,t2) in
+  make_let_in ren env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty)
+
+
+(* [make_while ren env (cphi,r,a) (tb,cb) (te,ce) c]
+ * constructs the term corresponding to the while, i.e.
+ * 
+ *    [h:(I x)](well_founded_induction
+ *              A R ?::(well_founded A R)
+ *              [Phi:A] (x) Phi=phi(x)->(I x)-> \exists x'.res.(I x')/\(S x')
+ *              [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
+ *                [x][eq:Phi_0=phi(x)][h:(I x)]
+ *                   Cases (b x) of
+ *                     (left  HH) => (x,?::(IS x))
+ *                   | (right HH) => let x1,_,_ = (e x ?) in
+ *                                   (w phi(x1) ? x1 ? ?)
+ *              phi(x) x ? ?)
+ *)
+
+let id_phi = id_of_string "phi"
+let id_phi0 = id_of_string "phi0"
+
+let make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) =
+  let ((_,tvb),eb,pb,qb) = cb in
+  let (_,ef,_,is) = c in
+
+  let ren' = next ren (get_writes ef) in
+  let before = current_date ren in
+  
+  let ty = 
+    let is = abstract_post ren' env (ef,is) in
+    let _,lo = input_output ren env c in
+    product ren env before lo is 
+  in
+  let resb = id_of_string "resultb" in
+  let tyb = trad_ml_type_v ren' env tvb in
+  let wb = get_writes eb in
+
+  (* première branche: le test est vrai => e;w *)
+  let t1 = 
+    make_block ren' env 
+      (fun ren'' result -> match result with
+	 | Some (id,_) ->
+	     let v = List.rev (current_vars ren'' (get_writes ef)) in
+	       CC_app (CC_var id_w,
+		       [CC_expr (phi_of ren'');
+			CC_hole (lt r (phi_of ren'') (mkVar id_phi0))]
+		       @(List.map (fun (_,id) -> CC_var id) v)
+		       @(CC_hole (eq a (phi_of ren'') (phi_of ren'')))
+		       ::(match i with
+			    | None -> [] 
+			    | Some c -> 
+				[CC_hole (apply_assert ren'' env c).a_value])),
+	       ty
+      	 | None -> failwith "a block should contain at least one statement")
+      tbl
+  in
+        
+  (* deuxième branche: le test est faux => on sort de la boucle *)
+  let t2,_ = 
+    result_tuple ren' before env
+      (CC_expr (constant "tt"),constant "unit") (ef,is)
+  in
+
+  let b_al = current_vars ren' (get_reads eb) in
+  let qb = force_bool_name qb in
+  let t = make_if_case ren' env ty (CC_var resb,qb) (t1,t2) in
+  let t = 
+    make_let_in ren' env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) 
+  in
+  let t = 
+    let pl = List.map (pre_of_assert false) (list_of_some i) in
+    abs_pre ren' env (t,ty) pl 
+  in
+  let t = 
+    CC_lam ([var_name Anonymous,
+	     CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren'))],t) 
+  in
+  let bl = binding_of_alist ren env (current_vars ren' (get_writes ef)) in
+  make_abs (List.rev bl) t
+
+
+let make_while ren env (cphi,r,a) (tb,cb) tbl (i,c) =
+  let (_,ef,_,is) = c in
+  let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
+  let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
+
+  let before = current_date ren in
+  let ren' = next ren (get_writes ef) in
+  let al = current_vars ren' (get_writes ef) in
+  let v =   
+    let _,lo = input_output ren env c in
+    let is = abstract_post ren' env (ef,is) in
+    match i with
+      | None -> product ren' env before lo is
+      | Some ci -> 
+	  Term.mkArrow (apply_assert ren' env ci).a_value 
+	    (product ren' env before lo is) 
+  in
+  let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren')) v in
+  let v = 
+    n_mkNamedProd v 
+      (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) 
+  in
+  let tw = 
+    Term.mkNamedProd id_phi a
+      (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) 
+  in
+  let id_w = id_of_string "loop" in
+  let vars = List.rev (current_vars ren (get_writes ef)) in
+  let body =
+    make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) 
+  in
+  CC_app (CC_expr (constant "well_founded_induction"),
+	  [CC_expr a; CC_expr r;
+	   CC_hole wf_a_r;
+	   CC_expr (Term.mkNamedLambda id_phi a v);
+	   CC_lam ([id_phi0, CC_typed_binder a;
+		    id_w, CC_typed_binder tw],
+		   body);
+	   CC_expr (phi_of ren)]
+	  @(List.map (fun (_,id) -> CC_var id) vars)
+          @(CC_hole (eq a (phi_of ren) (phi_of ren)))
+	  ::(match i with
+	       | None -> [] 
+	       | Some c -> [CC_hole (apply_assert ren env c).a_value])) 
+
+
+(* [make_letrec ren env (phi0,(cphi,r,a)) bl (te,ce) c]
+ * constructs the term corresponding to the let rec i.e.
+ *
+ * [x][h:P(x)](well_founded_induction 
+ *              A R ?::(well_founded A R)
+ *              [Phi:A] (bl) (x) Phi=phi(x)->(P x)-> \exists x'.res.(Q x x')
+ *              [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
+ *                [bl][x][eq:Phi_0=phi(x)][h:(P x)]te
+ *              phi(x) bl x ? ?)
+ *)
+
+let make_letrec ren env (id_phi0,(cphi,r,a)) idf bl (te,ce) c =
+  let (_,ef,p,q) = c in
+  let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
+  let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
+
+  let before = current_date ren in
+  let al = current_vars ren (get_reads ef) in
+  let v = 
+    let _,lo = input_output ren env c in
+    let q = abstract_post ren env (ef,q) in
+    arrow ren env (product ren env (current_date ren) lo q) p 
+  in
+  let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren)) v in
+  let v = 
+    n_mkNamedProd v 
+      (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) 
+  in
+  let v = 
+    n_mkNamedProd v
+      (List.map (function (id,CC_typed_binder c) -> (id,c) 
+		   | _ -> assert false) (List.rev bl)) 
+  in
+  let tw = 
+    Term.mkNamedProd id_phi a
+      (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) 
+  in
+  let vars = List.rev (current_vars ren (get_reads ef)) in
+  let body =
+    let al = current_vars ren (get_reads ef) in
+    let bod = abs_pre ren env (te,v) p in
+    let bod = CC_lam ([var_name Anonymous,
+		       CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren))],
+		      bod) 
+    in
+    let bl' = binding_of_alist ren env al in
+    make_abs (bl@(List.rev bl')) bod
+  in
+  let t =
+    CC_app (CC_expr (constant "well_founded_induction"),
+	    [CC_expr a; CC_expr r;
+	     CC_hole wf_a_r;
+	     CC_expr (Term.mkNamedLambda id_phi a v);
+	     CC_lam ([id_phi0, CC_typed_binder a;
+		      idf, CC_typed_binder tw],
+		     body);
+	     CC_expr (phi_of ren)]
+	    @(List.map (fun (id,_) -> CC_var id) bl)
+	    @(List.map (fun (_,id) -> CC_var id) vars)
+            @[CC_hole (eq a (phi_of ren) (phi_of ren))]
+	   )
+  in
+  (* on abstrait juste par rapport aux variables de ef *)
+  let al = current_vars ren (get_reads ef) in
+  let bl = binding_of_alist ren env al in
+  make_abs (List.rev bl) t
+
+
+(* [make_access env id c] Access in array id.
+ *
+ * Constructs [t:(array s T)](access_g s T t c ?::(lt c s)).
+ *)
+
+let array_info ren env id =
+  let ty = type_in_env env id in
+  let size,v = dearray_type ty in
+  let ty_elem = trad_ml_type_v ren env v in
+  let ty_array = trad_imp_type ren env ty in
+  size,ty_elem,ty_array
+
+let make_raw_access ren env (id,id') c =
+  let size,ty_elem,_ = array_info ren env id in
+  Term.applist (constant "access", [size; ty_elem; mkVar id'; c])
+
+let make_pre_access ren env id c =
+  let size,_,_ = array_info ren env id in
+  conj (lt (constant "Zle") (constant "ZERO") c)
+       (lt (constant "Zlt") c size)
+      
+let make_raw_store ren env (id,id') c1 c2 =
+  let size,ty_elem,_ = array_info ren env id in
+  Term.applist (constant "store", [size; ty_elem; mkVar id'; c1; c2])
diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli
new file mode 100644
index 00000000..e1400fcb
--- /dev/null
+++ b/contrib/correctness/pmonad.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        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: pmonad.mli,v 1.1.16.1 2004/07/16 19:30:02 herbelin Exp $ *)
+
+open Names
+open Term
+
+open Ptype
+open Past
+open Penv
+
+(* Main part of the translation of imperative programs into functional ones
+ * (with mlise.ml) *)
+
+(* Here we translate the specification into a CIC specification *)
+
+val trad_ml_type_v : Prename.t -> local_env -> type_v -> constr
+val trad_ml_type_c : Prename.t -> local_env -> type_c -> constr
+val trad_imp_type  : Prename.t -> local_env -> type_v -> constr
+val trad_type_in_env : Prename.t -> local_env -> identifier -> constr
+
+val binding_of_alist : Prename.t -> local_env
+                    -> (identifier * identifier) list
+		    -> cc_binder list
+val make_abs : cc_binder list -> cc_term -> cc_term
+val abs_pre : Prename.t -> local_env -> cc_term * constr -> 
+  constr precondition list -> cc_term
+
+(* The following functions translate the main constructions *)
+
+val make_tuple : (cc_term * cc_type) list -> predicate option
+          -> Prename.t -> local_env -> string
+          -> cc_term
+
+val result_tuple : Prename.t -> string -> local_env
+          -> (cc_term * constr) -> (Peffect.t * predicate option)
+          -> cc_term * constr
+
+val let_in_pre : constr -> constr precondition -> cc_term -> cc_term
+
+val make_let_in : Prename.t -> local_env -> cc_term 
+          -> constr precondition list
+          -> ((identifier * identifier) list * predicate option) 
+	  -> identifier * constr
+	  -> cc_term * constr -> cc_term
+
+val make_block : Prename.t -> local_env
+          -> (Prename.t -> (identifier * constr) option -> cc_term * constr)
+	  -> (cc_term * type_c, constr) block
+	  -> cc_term
+
+val make_app : local_env
+          -> Prename.t -> (cc_term * type_c) list
+	  -> Prename.t -> cc_term * type_c
+	  -> ((type_v binder list) * type_c)
+	    * ((identifier*identifier) list)
+	    * type_c
+	  -> type_c
+          -> cc_term
+
+val make_if : Prename.t -> local_env 
+         -> cc_term * type_c
+	 -> Prename.t
+         -> cc_term * type_c
+         -> cc_term * type_c
+         -> type_c
+         -> cc_term
+
+val make_while : Prename.t -> local_env
+         -> (constr * constr * constr) (* typed variant *)
+         -> cc_term * type_c
+         -> (cc_term * type_c, constr) block
+         -> constr assertion option * type_c
+         -> cc_term
+
+val make_letrec : Prename.t -> local_env
+         -> (identifier * (constr * constr * constr)) (* typed variant *)
+	 -> identifier (* the name of the function *)
+         -> (cc_binder list)
+	 -> (cc_term * type_c)
+	 -> type_c
+         -> cc_term
+
+(* Functions to translate array operations *)
+
+val array_info :
+  Prename.t -> local_env -> identifier -> constr * constr * constr
+
+val make_raw_access :
+  Prename.t -> local_env -> identifier * identifier -> constr -> constr
+
+val make_raw_store :
+  Prename.t -> local_env -> identifier * identifier 
+    -> constr -> constr -> constr
+
+val make_pre_access :
+  Prename.t -> local_env -> identifier -> constr -> constr
+
diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml
new file mode 100644
index 00000000..732dcf08
--- /dev/null
+++ b/contrib/correctness/pred.ml
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pred.ml,v 1.6.14.1 2004/07/16 19:30:05 herbelin Exp $ *)
+
+open Pp
+open Past
+open Pmisc
+
+let rec cc_subst subst = function
+  | CC_var id as c -> 
+      (try CC_expr (List.assoc id subst) with Not_found -> c)
+  | CC_letin (b,ty,bl,c1,c2) ->
+      CC_letin (b, real_subst_in_constr subst ty, cc_subst_binders subst bl,
+		cc_subst subst c1, cc_subst (cc_cross_binders subst bl) c2)
+  | CC_lam (bl, c) ->
+      CC_lam (cc_subst_binders subst bl, 
+	      cc_subst (cc_cross_binders subst bl) c)
+  | CC_app (c, cl) ->
+      CC_app (cc_subst subst c, List.map (cc_subst subst) cl)
+  | CC_tuple (b, tl, cl) ->
+      CC_tuple (b, List.map (real_subst_in_constr subst) tl,
+		List.map (cc_subst subst) cl)
+  | CC_case (ty, c, cl) ->
+      CC_case (real_subst_in_constr subst ty, cc_subst subst c,
+	       List.map (cc_subst subst) cl)
+  | CC_expr c ->
+      CC_expr (real_subst_in_constr subst c)
+  | CC_hole ty ->
+      CC_hole (real_subst_in_constr subst ty)
+
+and cc_subst_binders subst = List.map (cc_subst_binder subst)
+
+and cc_subst_binder subst = function
+  | id,CC_typed_binder c -> id,CC_typed_binder (real_subst_in_constr subst c)
+  | b -> b
+
+and cc_cross_binders subst = function
+  | [] -> subst
+  | (id,_) :: bl -> cc_cross_binders (List.remove_assoc id subst) bl
+
+(* here we only perform eta-reductions on programs to eliminate
+ * redexes of the kind
+ *
+ *   let (x1,...,xn) = e in (x1,...,xn)  -->  e
+ *
+ *)
+
+let is_eta_redex bl al =
+  try
+    List.for_all2
+      (fun (id,_) t -> match t with CC_var id' -> id=id' | _ -> false)
+      bl al
+  with
+      Invalid_argument("List.for_all2") -> false
+
+let rec red = function
+  | CC_letin (_, _, [id,_], CC_expr c1, e2) ->
+      red (cc_subst [id,c1] e2)
+  | CC_letin (dep, ty, bl, e1, e2) ->
+      begin match red e2 with
+	| CC_tuple (false,tl,al) ->
+	    if is_eta_redex bl al then
+	      red e1
+	    else
+	      CC_letin (dep, ty, bl, red e1,
+			CC_tuple (false,tl,List.map red al))
+	| e -> CC_letin (dep, ty, bl, red e1, e)
+      end
+  | CC_lam (bl, e) ->
+      CC_lam (bl, red e)
+  | CC_app (e, al) ->
+      CC_app (red e, List.map red al)
+  | CC_case (ty, e1, el) ->
+      CC_case (ty, red e1, List.map red el)
+  | CC_tuple (dep, tl, al) ->
+      CC_tuple (dep, tl, List.map red al)
+  | e -> e
+
+
+(* How to reduce uncomplete proof terms when they have become constr *)
+
+open Term
+open Reductionops
+
+(* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait
+ * la substitution d'une métavariable.
+ * 
+ * On commence par rendre toutes les applications binaire (strong bin_app)
+ * puis on applique la reduction spéciale programmes définie dans
+ * typing/reduction *)
+
+(*i
+let bin_app = function
+  | DOPN(AppL,v) as c ->
+      (match Array.length v with
+	 | 1 -> v.(0)
+	 | 2 -> c
+	 | n ->
+	     let f = DOPN(AppL,Array.sub v 0 (pred n)) in
+	     DOPN(AppL,[|f;v.(pred n)|]))
+  | c -> c
+i*)
+
+let red_cci c = 
+  (*i let c = strong bin_app c in i*) 
+  strong whd_programs (Global.env ()) Evd.empty c
+
diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli
new file mode 100644
index 00000000..2f43f4ad
--- /dev/null
+++ b/contrib/correctness/pred.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pred.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *)
+
+open Term
+open Past
+
+(* reduction on intermediate programs 
+ * get rid of redexes of the kind let (x1,...,xn) = e in (x1,...,xn) *)
+
+val red : cc_term -> cc_term
+
+
+(* Ad-hoc reduction on partial proof terms *)
+
+val red_cci : constr -> constr
+
+
diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml
new file mode 100644
index 00000000..864f6abd
--- /dev/null
+++ b/contrib/correctness/prename.ml
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: prename.ml,v 1.3.14.1 2004/07/16 19:30:05 herbelin Exp $ *)
+
+open Names
+open Nameops
+open Util
+open Pp
+open Himsg
+open Pmisc
+
+(* Variables names management *)
+
+type date = string
+
+(* The following data structure keeps the successive names of the variables
+ * as we traverse the program. A each step a ``date'' and a
+ * collection of new names is (possibly) given, and updates the
+ * previous renaming.
+ * 
+ * Then, we can ask for the name of a variable, at current date or
+ * at a given date.
+ *
+ * It is easily represented by a list of date x assoc list, most recent coming 
+ * first i.e. as follows:
+ *
+ *   [ date (= current), [ (x,xi); ... ];
+ *     date            , [ (z,zk); ... ];
+ *     ...
+ *     date (= initial), [ (x,xj); (y,yi); ... ]
+ *
+ * We also keep a list of all names already introduced, in order to
+ * quickly get fresh names.
+ *)
+
+type t =
+    { levels : (date * (identifier * identifier) list) list;
+      avoid  : identifier list;
+      cpt    : int }
+    
+
+let empty_ren = { levels = []; avoid = []; cpt = 0 }
+
+let update r d ids =
+  let al,av = renaming_of_ids r.avoid ids in
+  { levels = (d,al) :: r.levels; avoid = av; cpt = r.cpt }
+
+let push_date r d = update r d []
+
+let next r ids =
+  let al,av = renaming_of_ids r.avoid ids in
+  let n = succ r.cpt in
+  let d = string_of_int n in
+  { levels = (d,al) :: r.levels; avoid = av; cpt = n }
+
+
+let find r x =
+  let rec find_in_one = function
+      []         -> raise Not_found
+    | (y,v)::rem -> if y = x then v else find_in_one rem
+  in
+  let rec find_in_all = function
+      []         -> raise Not_found
+    | (_,l)::rem -> try find_in_one l with Not_found -> find_in_all rem
+  in
+    find_in_all r.levels
+
+
+let current_var = find
+
+let current_vars r ids = List.map (fun id -> id,current_var r id) ids
+
+
+let avoid r ids = { levels = r.levels; avoid = r.avoid @ ids; cpt = r.cpt }
+
+let fresh r ids = fst (renaming_of_ids r.avoid ids)
+
+
+let current_date r =
+  match r.levels with
+      [] -> invalid_arg "Renamings.current_date"
+    | (d,_)::_ -> d
+
+let all_dates r = List.map fst r.levels
+
+let rec valid_date da r = 
+  let rec valid = function
+      [] -> false
+    | (d,_)::rem -> (d=da) or (valid rem)
+  in
+    valid r.levels
+
+(* [until d r] selects the part of the renaming [r] starting from date [d] *)
+let rec until da r =
+  let rec cut = function
+      [] -> invalid_arg "Renamings.until"
+    | (d,_)::rem as r -> if d=da then r else cut rem
+  in
+    { avoid = r.avoid; levels = cut r.levels; cpt = r.cpt }
+
+let var_at_date r d id =
+  try
+    find (until d r) id
+  with Not_found ->
+    raise (UserError ("Renamings.var_at_date",
+	      hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++
+		       str"at date " ++ str d)))
+
+let vars_at_date r d ids =
+  let r' = until d r in List.map (fun id -> id,find r' id) ids
+
+
+(* pretty-printers *)
+
+open Pp
+open Util
+open Himsg
+
+let pp r = 
+  hov 2 (prlist_with_sep (fun () -> (fnl ()))
+	   (fun (d,l) -> 
+	      (str d ++ str": " ++ 
+		 prlist_with_sep (fun () -> (spc ()))
+		   (fun (id,id') -> 
+		      (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")"))
+		   l))
+	   r.levels)
+
+let ppr e =
+  Pp.pp (pp e)
+
diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli
new file mode 100644
index 00000000..88b49d2c
--- /dev/null
+++ b/contrib/correctness/prename.mli
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: prename.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *)
+
+open Names
+
+(* Abstract type for renamings 
+ * 
+ * Records the names of the mutables objets (ref, arrays) at the different
+ * moments of the evaluation, called dates
+ *)
+
+type t
+
+type date = string
+
+
+val empty_ren : t
+val update    : t -> date -> identifier list -> t
+    (* assign new names for the given variables, associated to a new date *)
+val next      : t -> identifier list -> t
+    (* assign new names for the given variables, associated to a new
+     * date which is generated from an internal counter *)
+val push_date : t -> date -> t
+    (* put a new date on top of the stack *)
+
+val valid_date   : date -> t -> bool
+val current_date : t -> date
+val all_dates    : t -> date list
+
+val current_var  : t -> identifier      -> identifier
+val current_vars : t -> identifier list -> (identifier * identifier) list
+    (* gives the current names of some variables *)
+
+val avoid : t -> identifier list -> t
+val fresh : t -> identifier list -> (identifier * identifier) list
+    (* introduces new names to avoid and renames some given variables *)
+
+val var_at_date  : t -> date -> identifier -> identifier
+    (* gives the name of a variable at a given date *)
+val vars_at_date : t -> date -> identifier list
+                 -> (identifier * identifier) list
+    (* idem for a list of variables *)  
+
+(* pretty-printers *)
+
+val pp : t -> Pp.std_ppcmds
+val ppr : t -> unit
+
diff --git a/contrib/correctness/preuves.v b/contrib/correctness/preuves.v
new file mode 100644
index 00000000..33659b43
--- /dev/null
+++ b/contrib/correctness/preuves.v
@@ -0,0 +1,128 @@
+
+(* 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/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4
new file mode 100644
index 00000000..c1f00a3d
--- /dev/null
+++ b/contrib/correctness/psyntax.ml4
@@ -0,0 +1,1058 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: psyntax.ml4,v 1.29.2.1 2004/07/16 19:30:05 herbelin Exp $ *)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Options
+open Util
+open Names
+open Nameops
+open Vernacentries
+open Reduction
+open Term
+open Libnames
+open Topconstr
+
+open Prename
+open Pmisc
+open Putil
+open Ptype
+open Past
+open Penv
+open Pmonad
+open Vernacexpr
+
+
+(* We define new entries for programs, with the use of this module
+ * Programs. These entries are named Programs.<foo>
+ *)
+
+module Gram = Pcoq.Gram
+module Constr = Pcoq.Constr
+module Tactic = Pcoq.Tactic
+
+module Programs =
+  struct
+    let gec s = Gram.Entry.create ("Programs."^s)
+    (* types *)
+    let type_v   = gec "type_v"
+    let type_v0  = gec "type_v0"
+    let type_v1  = gec "type_v1"
+    let type_v2  = gec "type_v2"
+    let type_v3  = gec "type_v3"
+    let type_v_app  = gec "type_v_app"
+    let type_c   = gec "type_c"
+    let effects  = gec "effects"
+    let reads    = gec "reads"
+    let writes   = gec "writes"
+    let pre_condition = gec "pre_condition"
+    let post_condition = gec "post_condition"
+    (* binders *)
+    let binder  = gec "binder"
+    let binder_type = gec "binder_type"
+    let binders  = gec "binders"
+    (* programs *)
+    let program = gec "program"
+    let prog1 = gec "prog1"
+    let prog2 = gec "prog2"
+    let prog3 = gec "prog3"
+    let prog4 = gec "prog4"
+    let prog5 = gec "prog5"
+    let prog6 = gec "prog6"
+    let prog7 = gec "prog7"
+    let ast1 = gec "ast1"
+    let ast2 = gec "ast2"
+    let ast3 = gec "ast3"
+    let ast4 = gec "ast4"
+    let ast5 = gec "ast5"
+    let ast6 = gec "ast6"
+    let ast7 = gec "ast7"
+    let arg = gec "arg"
+    let block = gec "block"
+    let block_statement = gec "block_statement"
+    let relation = gec "relation"
+    let variable = gec "variable"
+    let invariant = gec "invariant"
+    let variant = gec "variant"
+    let assertion = gec "assertion"
+    let precondition = gec "precondition"
+    let postcondition = gec "postcondition"
+    let predicate = gec "predicate"
+    let name = gec "name"
+  end
+
+open Programs
+
+let ast_of_int n = 
+  CDelimiters
+    (dummy_loc, "Z", CNumeral (dummy_loc, Bignat.POS (Bignat.of_string n)))
+
+let constr_of_int n =
+  Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n)
+
+open Util
+open Coqast
+
+let mk_id loc id = mkRefC (Ident (loc, id))
+let mk_ref loc s = mk_id loc (Constrextern.id_of_v7_string s)
+let mk_appl loc1 loc2 f args =
+  CApp (join_loc loc1 loc2, (None,mk_ref loc1 f), List.map (fun a -> a,None) args)
+
+let conj_assert {a_name=n;a_value=a} {a_value=b} = 
+  let loc1 = constr_loc a in
+  let loc2 = constr_loc a in
+  { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n }
+
+let conj = function
+    None,None     -> None
+  | None,b        -> b
+  | a,None        -> a
+  | Some a,Some b -> Some (conj_assert a b)
+
+let without_effect loc d = 
+  { desc = d; pre = []; post = None; loc = loc; info = () }
+
+let isevar = Expression isevar
+
+let bin_op op loc e1 e2 =
+  without_effect loc
+    (Apply (without_effect loc (Expression (constant op)),
+            [ Term e1; Term e2 ]))
+
+let un_op op loc e =
+  without_effect loc
+    (Apply (without_effect loc (Expression (constant op)), [Term e]))
+
+let bool_bin op loc a1 a2 =
+  let w = without_effect loc in
+  let d = SApp ( [Variable op], [a1; a2]) in
+  w d
+
+let bool_or  loc = bool_bin connective_or loc
+let bool_and loc = bool_bin connective_and loc
+
+let bool_not loc a =
+  let w = without_effect loc in
+  let d = SApp ( [Variable connective_not ], [a]) in
+  w d
+
+let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "ZERO"]
+
+(* program -> Coq AST *)
+
+let bdize c =
+  let env = 
+    Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty)
+  in
+  Constrextern.extern_constr true env c
+
+let rec coqast_of_program loc = function
+  | Variable id -> mk_id loc id
+  | Acc id -> mk_id loc id
+  | Apply (f,l) -> 
+      let f = coqast_of_program f.loc f.desc in
+      let args = List.map 
+		   (function Term t -> (coqast_of_program t.loc t.desc,None)
+		      | _ -> invalid_arg "coqast_of_program") l
+      in
+      CApp (dummy_loc, (None,f), args)
+  | Expression c -> bdize c
+  | _ -> invalid_arg "coqast_of_program"
+
+(* The construction `for' is syntactic sugar.
+ *
+ * for i = v1 to v2 do { invariant Inv } block done
+ *
+ * ==> (let rec f i { variant v2+1-i } = 
+ *        { i <= v2+1 /\ Inv(i) }
+ *        (if i > v2 then tt else begin block; (f (i+1)) end) 
+ *        { Inv(v2+1) }
+ *      in (f v1)) { Inv(v2+1) }
+ *)
+
+let ast_plus_un loc ast =
+  let un = ast_of_int "1" in
+  mk_appl loc loc "Zplus" [ast;un]
+
+let make_ast_for loc i v1 v2 inv block =
+  let f = for_name() in
+  let id_i = id_of_string i in
+  let var_i = without_effect loc (Variable id_i) in
+  let var_f = without_effect loc (Variable f) in
+  let succ_v2 = 
+    let a_v2 = coqast_of_program v2.loc v2.desc in
+    ast_plus_un loc a_v2 in
+  let post = named_app (subst_ast_in_ast [ id_i, succ_v2 ]) inv in
+  let e1 =
+    let test = bin_op "Z_gt_le_bool" loc var_i v2 in
+    let br_t = without_effect loc (Expression (constant "tt")) in
+    let br_f = 
+      let un = without_effect loc (Expression (constr_of_int "1")) in
+      let succ_i = bin_op "Zplus" loc var_i un in
+      let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in
+      without_effect loc (Seq (block @ [Statement f_succ_i]))
+    in
+    let inv' = 
+      let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in
+      conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv
+    in
+    { desc = If(test,br_t,br_f); loc = loc; 
+      pre = [pre_of_assert false inv']; post = Some post; info = () } 
+  in
+  let bl = 
+    let typez = mk_ref loc "Z" in
+    [(id_of_string i, BindType (TypePure typez))] 
+  in
+  let fv1 = without_effect loc (Apply (var_f, [Term v1])) in
+  let v = TypePure (mk_ref loc "unit") in
+  let var = 
+    let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in
+    (a, ast_zwf_zero loc)
+  in
+  Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1)
+
+let mk_prog loc p pre post =
+  { desc = p.desc; 
+    pre = p.pre @ pre; 
+    post = conj (p.post,post); 
+    loc = loc; 
+    info = () }
+
+if !Options.v7 then
+GEXTEND Gram
+
+  (* Types ******************************************************************)
+  type_v:
+    [ [ t = type_v0 -> t ] ]
+  ;
+  type_v0:
+    [ [ t = type_v1 -> t ] ]
+  ;
+  type_v1:
+    [ [ t = type_v2 -> t ] ]
+  ;
+  type_v2:
+    [ LEFTA
+      [ v = type_v2; IDENT "ref" -> Ref v
+      | t = type_v3 -> t ] ]
+  ;
+  type_v3:
+    [ [ IDENT "array"; size = Constr.constr; "of"; v = type_v0 ->
+          Array (size,v)
+      | IDENT "fun"; bl = binders; c = type_c -> make_arrow bl c
+      | c = Constr.constr -> TypePure c	  
+      ] ]
+  ;
+  type_c:
+    [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
+        e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
+        ((id_of_string id, v), e, list_of_some p, q)
+      ] ] 
+  ;
+  effects:
+    [ [ r = OPT reads; w = OPT writes ->
+	let r' = match r with Some l -> l | _ -> [] in
+	let w' = match w with Some l -> l | _ -> [] in
+	List.fold_left (fun e x -> Peffect.add_write x e)
+	  (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
+          w'
+      ] ]
+  ;
+  reads:
+    [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
+  ;
+  writes:
+    [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
+  ;
+  pre_condition:
+    [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
+  ;
+  post_condition:
+    [ [ IDENT "post"; c = predicate -> c ] ]
+  ;
+
+  (* Binders (for both types and programs) **********************************)
+  binder:
+    [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
+	  List.map (fun s -> (id_of_string s, t)) sl
+      ] ]
+  ;
+  binder_type:
+    [ [ "Set" -> BindSet
+      | v = type_v -> BindType v
+      ] ]
+  ;
+  binders:
+    [ [ bl = LIST0 binder -> List.flatten bl ] ] 
+  ;
+
+  (* annotations *)
+  predicate:
+    [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
+  ;
+  name:
+    [ [ "as"; s = IDENT -> Name (id_of_string s)
+      | -> Anonymous
+      ] ]
+  ;
+
+  (* Programs ***************************************************************)
+  variable:
+    [ [ s = IDENT -> id_of_string s ] ]
+  ;
+  assertion:
+    [ [ "{"; c = predicate; "}" -> c ] ]
+  ;
+  precondition:
+    [ [ "{"; c = predicate; "}" -> pre_of_assert false c ] ]
+  ;
+  postcondition:
+    [ [ "{"; c = predicate; "}" -> c ] ]
+  ;
+  program:
+    [ [ p = prog1 -> p ] ]
+  ;
+  prog1:
+    [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog2:
+    [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog3:
+    [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog4:
+    [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog5:
+    [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog6:
+    [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+
+  ast1:
+    [ [ x = prog2; IDENT "or"; y = prog1  -> bool_or loc x y
+      | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
+      | x = prog2 -> x
+      ] ]
+  ;
+  ast2:
+    [ [ IDENT "not"; x = prog3 -> bool_not loc x
+      | x = prog3 -> x
+      ] ]
+  ;
+  ast3:
+    [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
+      | x = prog4 -> x
+      ] ]
+    ;
+  ast4:
+    [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
+      | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
+      | x = prog5 -> x
+      ] ]
+    ;
+  ast5:
+    [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y 
+      | x = prog6 -> x
+      ] ]
+    ;
+  ast6:
+    [ [ "-"; x = prog6 -> un_op "Zopp" loc x
+      | x = ast7 -> without_effect loc x
+      ] ]
+    ;
+  ast7:
+    [ [ v = variable -> 
+	  Variable v
+      | n = INT ->
+	  Expression (constr_of_int n)
+      | "!"; v = variable ->
+	  Acc v
+      | "?" ->
+	  isevar
+      | v = variable; ":="; p = program ->
+	  Aff (v,p)
+      | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
+      | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
+      | v = variable; "["; e = program; "]"; ":="; p = program -> 
+	  TabAff (true,v,e,p)
+      | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> 
+	  TabAff (true,v,e,p)
+      | IDENT "if"; e1 = program; IDENT "then"; e2 = program;
+	IDENT "else"; e3 = program ->
+	  If (e1,e2,e3)
+      | IDENT "if"; e1 = program; IDENT "then"; e2 = program ->
+	  If (e1,e2,without_effect loc (Expression (constant "tt")))
+      | IDENT "while"; b = program; IDENT "do"; 
+	"{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
+	bl = block; IDENT "done" ->
+	  While (b, inv, wf, bl)
+      | IDENT "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
+	IDENT "do"; "{"; inv = invariant; "}"; 
+	bl = block; IDENT "done" -> 
+	  make_ast_for loc i v1 v2 inv bl
+      | IDENT "let"; v = variable; "="; IDENT "ref"; p1 = program;
+	"in"; p2 = program ->
+	  LetRef (v, p1, p2)
+      | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
+	  Let (v, p1, p2)
+      | IDENT "begin"; b = block; "end" ->
+	  Seq b
+      | IDENT "fun"; bl = binders; "->"; p = program ->
+	  Lam (bl,p)
+      | IDENT "let"; IDENT "rec"; f = variable; 
+	bl = binders; ":"; v = type_v;
+	"{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
+	  LetRec (f,bl,v,var,p)
+      | IDENT "let"; IDENT "rec"; f = variable; 
+	bl = binders; ":"; v = type_v;
+	"{"; IDENT "variant"; var = variant; "}"; "="; p = program;
+ 	"in"; p2 = program ->
+	  Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
+
+      | "@"; s = STRING; p = program ->
+	  Debug (s,p)
+
+      | "("; p = program; args = LIST0 arg; ")" ->
+	  match args with 
+	      [] -> 
+		if p.pre<>[] or p.post<>None then
+		  Pp.warning "Some annotations are lost";
+		p.desc
+            | _  -> 
+		Apply(p,args)
+     ] ]
+  ;
+  arg:
+    [ [ "'"; t = type_v -> Type t
+      | p = program -> Term p
+      ] ]
+  ;
+  block:
+    [ [ s = block_statement; ";"; b = block -> s::b
+      | s = block_statement                 -> [s] ] ]
+  ;
+  block_statement:
+    [ [ IDENT "label"; s = IDENT -> Label s
+      | IDENT "assert"; c = assertion -> Assert c 
+      | p = program -> Statement p ] ]
+  ;
+  relation:
+    [ [ "<"  -> "Z_lt_ge_bool"
+      | "<=" -> "Z_le_gt_bool"
+      | ">"  -> "Z_gt_le_bool"
+      | ">=" -> "Z_ge_lt_bool"
+      | "="  -> "Z_eq_bool"
+      | "<>" -> "Z_noteq_bool" ] ] 
+  ;
+
+  (* Other entries (invariants, etc.) ***************************************)
+  invariant:
+    [ [ IDENT "invariant"; c = predicate -> c ] ]
+  ;
+  variant:
+    [ [ c = Constr.constr; IDENT "for"; r = Constr.constr -> (c, r)
+      | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
+  ;
+  END
+else
+GEXTEND Gram
+  GLOBAL: type_v program;
+
+  (* Types ******************************************************************)
+  type_v:
+    [ [ t = type_v0 -> t ] ]
+  ;
+  type_v0:
+    [ [ t = type_v1 -> t ] ]
+  ;
+  type_v1:
+    [ [ t = type_v2 -> t ] ]
+  ;
+  type_v2:
+    [ LEFTA
+      [ v = type_v2; IDENT "ref" -> Ref v
+      | t = type_v3 -> t ] ]
+  ;
+  type_v3:
+    [ [ IDENT "array"; size = Constr.constr; IDENT "of"; v = type_v0 ->
+          Array (size,v)
+      | "fun"; bl = binders; c = type_c -> make_arrow bl c
+      | c = Constr.constr -> TypePure c	  
+      ] ]
+  ;
+  type_c:
+    [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
+        e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
+        ((id_of_string id, v), e, list_of_some p, q)
+      ] ] 
+  ;
+  effects:
+    [ [ r = OPT reads; w = OPT writes ->
+	let r' = match r with Some l -> l | _ -> [] in
+	let w' = match w with Some l -> l | _ -> [] in
+	List.fold_left (fun e x -> Peffect.add_write x e)
+	  (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
+          w'
+      ] ]
+  ;
+  reads:
+    [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
+  ;
+  writes:
+    [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
+  ;
+  pre_condition:
+    [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
+  ;
+  post_condition:
+    [ [ IDENT "post"; c = predicate -> c ] ]
+  ;
+
+  (* Binders (for both types and programs) **********************************)
+  binder:
+    [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
+	  List.map (fun s -> (id_of_string s, t)) sl
+      ] ]
+  ;
+  binder_type:
+    [ [ "Set" -> BindSet
+      | v = type_v -> BindType v
+      ] ]
+  ;
+  binders:
+    [ [ bl = LIST0 binder -> List.flatten bl ] ] 
+  ;
+
+  (* annotations *)
+  predicate:
+    [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
+  ;
+  dpredicate:
+    [ [ c = Constr.lconstr; n = name -> { a_name = n; a_value = c } ] ]
+  ;
+  name:
+    [ [ "as"; s = IDENT -> Name (id_of_string s)
+      | -> Anonymous
+      ] ]
+  ;
+
+  (* Programs ***************************************************************)
+  variable:
+    [ [ s = IDENT -> id_of_string s ] ]
+  ;
+  assertion:
+    [ [ "{"; c = dpredicate; "}" -> c ] ]
+  ;
+  precondition:
+    [ [ "{"; c = dpredicate; "}" -> pre_of_assert false c ] ]
+  ;
+  postcondition:
+    [ [ "{"; c = dpredicate; "}" -> c ] ]
+  ;
+  program:
+    [ [ p = prog1 -> p ] ]
+  ;
+  prog1:
+    [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog2:
+    [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog3:
+    [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog4:
+    [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog5:
+    [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+  prog6:
+    [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
+	  mk_prog loc ast pre post ] ]
+  ;
+
+  ast1:
+    [ [ x = prog2; IDENT "or"; y = prog1  -> bool_or loc x y
+      | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
+      | x = prog2 -> x
+      ] ]
+  ;
+  ast2:
+    [ [ IDENT "not"; x = prog3 -> bool_not loc x
+      | x = prog3 -> x
+      ] ]
+  ;
+  ast3:
+    [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
+      | x = prog4 -> x
+      ] ]
+    ;
+  ast4:
+    [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
+      | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
+      | x = prog5 -> x
+      ] ]
+    ;
+  ast5:
+    [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y 
+      | x = prog6 -> x
+      ] ]
+    ;
+  ast6:
+    [ [ "-"; x = prog6 -> un_op "Zopp" loc x
+      | x = ast7 -> without_effect loc x
+      ] ]
+    ;
+  ast7:
+    [ [ v = variable -> 
+	  Variable v
+      | n = INT ->
+	  Expression (constr_of_int n)
+      | "!"; v = variable ->
+	  Acc v
+      | "?" ->
+	  isevar
+      | v = variable; ":="; p = program ->
+	  Aff (v,p)
+      | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
+      | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
+      | v = variable; "["; e = program; "]"; ":="; p = program -> 
+	  TabAff (true,v,e,p)
+      | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> 
+	  TabAff (true,v,e,p)
+      | "if"; e1 = program; "then"; e2 = program; "else"; e3 = program ->
+	  If (e1,e2,e3)
+      | "if"; e1 = program; "then"; e2 = program ->
+	  If (e1,e2,without_effect loc (Expression (constant "tt")))
+      | IDENT "while"; b = program; IDENT "do"; 
+	"{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
+	bl = block; IDENT "done" ->
+	  While (b, inv, wf, bl)
+      | "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
+	IDENT "do"; "{"; inv = invariant; "}"; 
+	bl = block; IDENT "done" -> 
+	  make_ast_for loc i v1 v2 inv bl
+      | "let"; v = variable; "="; IDENT "ref"; p1 = program;
+	"in"; p2 = program ->
+	  LetRef (v, p1, p2)
+      | "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
+	  Let (v, p1, p2)
+      | IDENT "begin"; b = block; "end" ->
+	  Seq b
+      | "fun"; bl = binders; "=>"; p = program ->
+	  Lam (bl,p)
+      | "let"; IDENT "rec"; f = variable; 
+	bl = binders; ":"; v = type_v;
+	"{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
+	  LetRec (f,bl,v,var,p)
+      | "let"; IDENT "rec"; f = variable; 
+	bl = binders; ":"; v = type_v;
+	"{"; IDENT "variant"; var = variant; "}"; "="; p = program;
+ 	"in"; p2 = program ->
+	  Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
+
+      | "@"; s = STRING; p = program ->
+	  Debug (s,p)
+
+      | "("; p = program; args = LIST0 arg; ")" ->
+	  match args with 
+	      [] -> 
+		if p.pre<>[] or p.post<>None then
+		  Pp.warning "Some annotations are lost";
+		p.desc
+            | _  -> 
+		Apply(p,args)
+     ] ]
+  ;
+  arg:
+    [ [ "'"; t = type_v -> Type t
+      | p = program -> Term p
+      ] ]
+  ;
+  block:
+    [ [ s = block_statement; ";"; b = block -> s::b
+      | s = block_statement                 -> [s] ] ]
+  ;
+  block_statement:
+    [ [ IDENT "label"; s = IDENT -> Label s
+      | IDENT "assert"; c = assertion -> Assert c 
+      | p = program -> Statement p ] ]
+  ;
+  relation:
+    [ [ "<"  -> "Z_lt_ge_bool"
+      | "<=" -> "Z_le_gt_bool"
+      | ">"  -> "Z_gt_le_bool"
+      | ">=" -> "Z_ge_lt_bool"
+      | "="  -> "Z_eq_bool"
+      | "<>" -> "Z_noteq_bool" ] ] 
+  ;
+
+  (* Other entries (invariants, etc.) ***************************************)
+  invariant:
+    [ [ IDENT "invariant"; c = predicate -> c ] ]
+  ;
+  variant:
+    [ [ c = Constr.constr; "for"; r = Constr.constr -> (c, r)
+      | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
+  ;
+  END
+;;
+
+let wit_program, globwit_program, rawwit_program =
+  Genarg.create_arg "program"
+let wit_type_v, globwit_type_v, rawwit_type_v =
+  Genarg.create_arg "type_v"
+
+open Pp
+open Util
+open Himsg
+open Vernacinterp
+open Vernacexpr
+open Declare
+
+let is_assumed global ids =
+  if List.length ids = 1 then
+    msgnl (str (if global then "A global variable " else "") ++ 
+	     pr_id (List.hd ids) ++ str " is assumed")
+  else
+    msgnl (str (if global then "Some global variables " else "") ++
+	     prlist_with_sep (fun () -> (str ", ")) pr_id ids ++
+	     str " are assumed")
+
+open Pcoq
+
+(* Variables *)
+
+let wit_variables, globwit_variables, rawwit_variables =
+  Genarg.create_arg "variables"
+
+let variables = Gram.Entry.create "Variables"
+
+GEXTEND Gram
+  variables: [ [ l = LIST1 Prim.ident SEP "," -> l ] ];
+END
+
+let pr_variables _prc _prtac l = spc() ++ prlist_with_sep pr_coma pr_id l
+
+let _ =
+  Pptactic.declare_extra_genarg_pprule true
+    (rawwit_variables, pr_variables)
+    (globwit_variables, pr_variables)
+    (wit_variables, pr_variables)
+
+(* then_tac *)
+
+open Genarg
+open Tacinterp
+
+let pr_then_tac _ prt = function
+  | None -> mt ()
+  | Some t -> pr_semicolon () ++ prt t
+
+ARGUMENT EXTEND then_tac
+  TYPED AS tactic_opt 
+  PRINTED BY pr_then_tac
+  INTERPRETED BY interp_genarg
+  GLOBALIZED BY intern_genarg
+| [ ";" tactic(t) ] -> [ Some t ]
+| [ ] -> [ None ]
+END
+
+(* Correctness *)
+
+VERNAC COMMAND EXTEND Correctness
+  [ "Correctness" preident(str) program(pgm) then_tac(tac) ]
+   -> [ Ptactic.correctness str pgm (option_app Tacinterp.interp tac) ]
+END
+
+(* Show Programs *)
+
+let show_programs () =
+  fold_all 
+    (fun (id,v) _ -> 
+      msgnl (pr_id id ++ str " : " ++ 
+      hov 2 (match v with TypeV v -> pp_type_v v
+	| Set -> (str "Set")) ++
+      fnl ()))
+    Penv.empty ()
+
+VERNAC COMMAND EXTEND ShowPrograms
+  [ "Show" "Programs" ] -> [ show_programs () ]
+END
+
+(* Global Variable *)
+
+let global_variable ids v =
+  List.iter
+    (fun id -> if Penv.is_global id then
+      Util.errorlabstrm "PROGVARIABLE"
+	(str"Clash with previous constant " ++ pr_id id))
+    ids;
+  Pdb.check_type_v (all_refs ()) v;
+  let env = empty in
+  let ren = update empty_ren "" [] in
+  let v = Ptyping.cic_type_v env ren v in
+  if not (is_mutable v) then begin
+    let c = 
+      Entries.ParameterEntry (trad_ml_type_v ren env v),
+      Decl_kinds.IsAssumption Decl_kinds.Definitional in
+    List.iter 
+      (fun id -> ignore (Declare.declare_constant id c)) ids;
+    if_verbose (is_assumed false) ids
+  end;
+  if not (is_pure v) then begin
+    List.iter (fun id -> ignore (Penv.add_global id v None)) ids;
+    if_verbose (is_assumed true) ids
+  end
+
+VERNAC COMMAND EXTEND ProgVariable
+  [ "Global" "Variable" variables(ids) ":" type_v(t) ]
+  -> [ global_variable ids t]
+END
+
+let pr_id id = pr_id (Constrextern.v7_to_v8_id id)
+
+(* Type printer *)
+
+let pr_reads = function
+  | [] -> mt ()
+  | l -> spc () ++
+      hov 0 (str "reads" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
+
+let pr_writes = function
+  | [] -> mt ()
+  | l -> spc () ++
+      hov 0 (str "writes" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
+
+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 ++
+  (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt())
+
+let pr_assert b { p_name = x; p_value = v } =
+  pr_predicate b { a_name = x; a_value = v }
+
+let pr_pre_condition_list = function
+  | [] -> mt ()
+  | [pre] -> spc() ++ hov 0 (str "pre" ++ spc () ++ pr_assert false pre)
+  | _ -> assert false
+
+let pr_post_condition_opt = function
+  | None -> mt ()
+  | Some post ->
+      spc() ++ hov 0 (str "post" ++ spc () ++ pr_predicate false post)
+
+let rec pr_type_v_v8 = function
+  | Array (a,v) ->
+      str "array" ++ spc() ++ Ppconstrnew.pr_constr a ++ spc() ++ str "of " ++
+      pr_type_v_v8 v
+  | v -> pr_type_v3 v
+
+and pr_type_v3 = function
+  | Ref v -> pr_type_v3 v ++ spc () ++ str "ref"
+  | Arrow (bl,((id,v),e,prel,postl)) ->
+      str "fun" ++ spc() ++ hov 0 (prlist_with_sep cut pr_binder bl) ++
+      spc () ++ str "returns" ++ spc () ++ pr_id id ++ str ":" ++ 
+      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
+  | v -> str "(" ++ pr_type_v_v8 v ++ str ")"
+
+and pr_binder = function
+  | (id,BindType c) ->
+      str "(" ++ pr_id id ++ str ":" ++ pr_type_v_v8 c ++ str ")"
+  | (id,BindSet) ->
+      str "(" ++ pr_id id ++ str ":" ++ str "Set" ++ str ")"
+  | (id,Untyped) ->
+      str "<<<<< TODO: Untyped binder >>>>"
+
+let _ =
+  Pptactic.declare_extra_genarg_pprule true
+    (rawwit_type_v, fun _ _ -> pr_type_v_v8)
+    (globwit_type_v, fun _ -> raise Not_found)
+    (wit_type_v, fun _ -> raise Not_found)
+
+(* Program printer *)
+
+let pr_precondition pred = str "{" ++ pr_assert true pred ++ str "}" ++ spc ()
+
+let pr_postcondition pred = str "{" ++ pr_predicate true pred ++ str "}"
+
+let pr_invariant = function
+  | None -> mt ()
+  | Some c -> hov 2 (str "invariant" ++ spc ()  ++ pr_predicate false c)
+
+let pr_variant (c1,c2) =
+  Ppconstrnew.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))
+
+let rec pr_desc = function
+  | Variable id ->
+      (* Unsafe: should distinguish global names and bound vars *)
+      let vars = (* TODO *) Idset.empty in
+      let id = try 
+        snd (repr_qualid
+          (snd (qualid_of_reference 
+            (Constrextern.extern_reference
+              dummy_loc vars (Nametab.locate (make_short_qualid id))))))
+      with _ -> id in
+      pr_id id
+  | Acc id -> str "!" ++ pr_id id
+  | Aff (id,p) -> pr_id id ++ spc() ++ str ":=" ++ spc() ++ pr_prog p
+  | TabAcc (b,id,p) -> pr_id id ++ str "[" ++ pr_prog p ++ str "]"
+  | TabAff (b,id,p1,p2) ->
+      pr_id id ++ str "[" ++ pr_prog p1 ++ str "]" ++
+      str ":=" ++ pr_prog p2
+  | Seq bll -> 
+      hv 0 (str "begin" ++ spc () ++ pr_block bll ++ spc () ++ str "end")
+  | While (p1,inv,var,bll) ->
+      hv 0 (
+	hov 0 (str "while" ++ spc () ++ pr_prog p1 ++ spc () ++ str "do") ++
+	brk (1,2) ++
+	hv 2 (
+	  str "{ " ++ 
+	  pr_invariant inv ++ spc() ++
+	  hov 0 (str "variant" ++ spc () ++ pr_variant var)
+	  ++ str " }") ++ cut () ++
+	hov 0 (pr_block bll) ++ cut () ++ 
+	str "done")
+  | If (p1,p2,p3) ->
+      hov 1 (str "if " ++ pr_prog p1) ++ spc () ++
+      hov 0 (str "then" ++ spc () ++ pr_prog p2) ++ spc () ++
+      hov 0 (str "else" ++ spc () ++ pr_prog p3)
+  | Lam (bl,p) ->
+      hov 0 
+        (str "fun" ++ spc () ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ 
+	 spc () ++ str "=>") ++
+      pr_prog p
+  | Apply ({desc=Expression e; pre=[]; post=None} as p,args) when isConst e ->
+      begin match
+	string_of_id (snd (repr_path (Nametab.sp_of_global (ConstRef (destConst e))))),
+	args
+      with
+      | "Zmult", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"*" ++ pr_arg a2 ++ str ")"
+      | "Zplus", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"+" ++ pr_arg a2 ++ str ")"
+      | "Zminus", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"-" ++ pr_arg a2 ++ str ")"
+      | "Zopp", [a] ->
+	  str "( -" ++ pr_arg a ++ str ")"
+      | "Z_lt_ge_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"<" ++ pr_arg a2 ++ str ")"
+      | "Z_le_gt_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"<=" ++ pr_arg a2 ++ str ")"
+      | "Z_gt_le_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str">" ++ pr_arg a2 ++ str ")"
+      | "Z_ge_lt_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str">=" ++ pr_arg a2 ++ str ")"
+      | "Z_eq_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"=" ++ pr_arg a2 ++ str ")"
+      | "Z_noteq_bool", [a1;a2] ->
+	  str "(" ++ pr_arg a1 ++ str"<> " ++ pr_arg a2 ++ str ")"
+      | _ -> 
+	  str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
+	  str ")"
+      end
+  | Apply (p,args) ->
+      str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
+      str ")"
+  | SApp ([Variable v], args) ->
+      begin match string_of_id v, args with
+	| "prog_bool_and", [a1;a2] -> 
+	    str"(" ++ pr_prog a1 ++ spc() ++ str"and " ++ pr_prog a2 ++str")"
+	| "prog_bool_or", [a1;a2] -> 
+	    str"(" ++ pr_prog a1 ++ spc() ++ str"or " ++ pr_prog a2 ++ str")"
+	| "prog_bool_not", [a] ->
+	    str "(not " ++ pr_prog a ++ str ")"
+	| _ -> failwith "Correctness printer: TODO"
+      end
+  | SApp _ -> failwith "Correctness printer: TODO"
+  | LetRef (v,p1,p2) ->
+      hov 2 (
+	str "let " ++ pr_id v ++ str " =" ++ spc () ++ str "ref" ++ spc () ++
+	pr_prog p1 ++ str " in") ++
+      spc () ++ pr_prog p2
+  | Let (id, {desc=LetRec (f,bl,v,var,p); pre=[]; post=None },p2) when f=id ->
+      hov 2 (
+	str "let rec " ++ pr_id f ++ spc () ++
+	hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
+	str ":" ++ pr_type_v_v8 v ++ spc () ++
+	hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ 
+	spc() ++ str "=" ++ spc () ++ pr_prog p ++
+ 	str " in") ++
+      spc () ++ pr_prog p2
+  | Let (v,p1,p2) ->
+      hov 2 (
+	str "let " ++ pr_id v ++ str " =" ++ spc () ++ pr_prog p1 ++ str" in")
+      ++ spc () ++ pr_prog p2
+  | LetRec (f,bl,v,var,p) ->
+      str "let rec " ++ pr_id f ++ spc () ++
+      hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
+      str ":" ++ pr_type_v_v8 v ++ spc () ++
+      hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++
+      spc () ++ str "=" ++ spc () ++ pr_prog p
+  | PPoint _ -> str "TODO: Ppoint" (* Internal use only *)
+  | Expression c ->
+      (* 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
+
+and pr_block_st = function
+  | Label s -> hov 0 (str "label" ++ spc() ++ str s)
+  | Assert pred -> 
+      hov 0 (str "assert" ++ spc() ++ hov 0 (pr_postcondition pred))
+  | Statement p -> pr_prog p
+
+and pr_block bl = prlist_with_sep pr_semicolon pr_block_st bl
+
+and pr_arg = function
+  | Past.Term p -> pr_prog p
+  | Past.Type t -> str "'" ++ pr_type_v_v8 t
+  | Refarg _ -> str "TODO: Refarg" (* Internal use only *)
+
+and pr_prog0 b { desc = desc; pre = pre; post = post } =
+  hv 0 (
+    prlist pr_precondition pre ++
+    hov 0
+      (if b & post<>None then str"(" ++ pr_desc desc ++ str")"
+       else pr_desc desc)
+    ++ Ppconstrnew.pr_opt pr_postcondition post)
+
+and pr_prog x = pr_prog0 true x
+
+let _ =
+  Pptactic.declare_extra_genarg_pprule true
+    (rawwit_program, fun _ _ a -> spc () ++ pr_prog0 false a)
+    (globwit_program, fun _ -> raise Not_found)
+    (wit_program, fun _ -> raise Not_found)
+
diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli
new file mode 100644
index 00000000..18912548
--- /dev/null
+++ b/contrib/correctness/psyntax.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: psyntax.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Pcoq
+open Ptype
+open Past
+open Topconstr
+
+(* Grammar for the programs and the tactic Correctness *)
+
+module Programs :
+  sig
+    val program : program Gram.Entry.e
+    val type_v  : constr_expr ml_type_v Gram.Entry.e
+    val type_c  : constr_expr ml_type_c Gram.Entry.e
+  end
diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml
new file mode 100644
index 00000000..4b22954e
--- /dev/null
+++ b/contrib/correctness/ptactic.ml
@@ -0,0 +1,258 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ptactic.ml,v 1.30.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Pp
+open Options
+open Names
+open Libnames
+open Term
+open Pretyping
+open Pfedit
+open Decl_kinds
+open Vernacentries
+
+open Pmisc
+open Putil
+open Past
+open Penv
+open Prename
+open Peffect
+open Pmonad
+
+(* [coqast_of_prog: program -> constr * constr]
+ * Traduction d'un programme impératif en un but (second constr)
+ * et un terme de preuve partiel pour ce but (premier constr)
+ *)
+
+let coqast_of_prog p =
+  (* 1. db : séparation dB/var/const *)
+  let p = Pdb.db_prog p in
+
+  (* 2. typage avec effets *)
+  deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ());
+  let env = Penv.empty in
+  let ren = initial_renaming env in
+  let p = Ptyping.states ren env p in
+  let ((_,v),_,_,_) as c = p.info.kappa in
+  Perror.check_for_not_mutable p.loc v;
+  deb_print pp_type_c c;
+
+  (* 3. propagation annotations *)
+  let p = Pwp.propagate ren p in
+
+  (* 4a. traduction type *)
+  let ty = Pmonad.trad_ml_type_c ren env c in
+  deb_print (Printer.prterm_env (Global.env())) ty;
+
+  (* 4b. traduction terme (terme intermédiaire de type cc_term) *)
+  deb_mess 
+    (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ());
+  let cc = Pmlize.trans ren p in
+  let cc = Pred.red cc in
+  deb_print Putil.pp_cc_term cc;
+
+  (* 5. traduction en constr *)
+  deb_mess 
+    (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;
+
+  (* 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);
+
+  p,oc,ty,v
+
+(* [automatic : tactic]
+ * 
+ * Certains buts engendrés par "correctness" (ci-dessous)
+ * sont réellement triviaux. On peut les résoudre aisément, sans pour autant
+ * tomber dans la solution trop lourde qui consiste à faire "; Auto."
+ *
+ * Cette tactique fait les choses suivantes :
+ *   o  elle élimine les hypothèses de nom loop<i>
+ *   o  sur  G |- (well_founded nat lt) ==> Exact lt_wf.  
+ *   o  sur  G |- (well_founded Z (Zwf c)) ==> Exact (Zwf_well_founded c)
+ *   o  sur  G |- e = e' ==> Reflexivity.  (arg. de decr. des boucles)
+ *                           sinon Try Assumption.
+ *   o  sur  G |- P /\ Q ==> Try (Split; Assumption). (sortie de boucle)
+ *   o  sinon, Try AssumptionBis (= Assumption + décomposition /\ dans hyp.)
+ *             (pour entrée dans corps de boucle par ex.)
+ *)
+
+open Pattern
+open Tacmach
+open Tactics
+open Tacticals
+open Equality
+open Nametab
+
+let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0)
+let lt = ConstRef (coq_constant ["Init";"Peano"] "lt")
+let well_founded = ConstRef (coq_constant ["Init";"Wf"] "well_founded")
+let z = IndRef (coq_constant ["ZArith";"BinInt"] "Z", 0)
+let and_ = IndRef (coq_constant ["Init";"Logic"] "and", 0)
+let eq = IndRef (coq_constant ["Init";"Logic"] "eq", 0)
+
+let mkmeta n = Nameops.make_ident "X" (Some n)
+let mkPMeta n = PMeta (Some (mkmeta n))
+
+(* ["(well_founded nat lt)"] *)
+let wf_nat_pattern = 
+  PApp (PRef well_founded, [| PRef nat; PRef lt |])
+(* ["((well_founded Z (Zwf ?1))"] *)
+let wf_z_pattern = 
+  let zwf = ConstRef (coq_constant ["ZArith";"Zwf"] "Zwf") in
+  PApp (PRef well_founded, [| PRef z; PApp (PRef zwf, [| mkPMeta 1 |]) |])
+(* ["(and ?1 ?2)"] *)
+let and_pattern = 
+  PApp (PRef and_, [| mkPMeta 1; mkPMeta 2 |])
+(* ["(eq ?1 ?2 ?3)"] *)
+let eq_pattern = 
+  PApp (PRef eq, [| mkPMeta 1; mkPMeta 2; mkPMeta 3 |])
+
+(* loop_ids: remove loop<i> hypotheses from the context, and rewrite
+ * using Variant<i> hypotheses when needed. *)
+ 
+let (loop_ids : tactic) = fun gl ->
+  let rec arec hyps gl =
+    let env = pf_env gl in
+    let concl = pf_concl gl in 
+    match hyps with
+      | [] -> tclIDTAC gl
+      | (id,a) :: al ->
+	  let s = string_of_id id in
+	  let n = String.length s in
+	  if n >= 4 & (let su = String.sub s 0 4 in su="loop" or su="Bool")
+	  then
+	    tclTHEN (clear [id]) (arec al) gl
+	  else if n >= 7 & String.sub s 0 7 = "Variant" then begin
+	    match pf_matches gl eq_pattern (body_of_type a) with
+	      | [_; _,varphi; _] when isVar varphi ->
+		  let phi = destVar varphi in
+		  if Termops.occur_var env phi concl then
+		    tclTHEN (rewriteLR (mkVar id)) (arec al) gl
+		  else
+		    arec al gl
+	      | _ -> assert false end
+	  else
+	    arec al gl
+  in 
+  arec (pf_hyps_types gl) gl
+
+(* assumption_bis: like assumption, but also solves ... h:A/\B ... |- A 
+ * (resp. B) *)
+
+let (assumption_bis : tactic) = fun gl ->
+  let concl = pf_concl gl in 
+  let rec arec = function
+    | [] -> Util.error "No such assumption"
+    | (s,a) :: al ->
+	let a = body_of_type a in
+	if pf_conv_x_leq gl a concl then 
+          refine (mkVar s) gl
+	else if pf_is_matching gl and_pattern a then
+	  match pf_matches gl and_pattern a with
+	    | [_,c1; _,c2] -> 
+		if pf_conv_x_leq gl c1 concl then
+		  exact_check (applistc (constant "proj1") [c1;c2;mkVar s]) gl
+		else if pf_conv_x_leq gl c2 concl then
+		  exact_check (applistc (constant "proj2") [c1;c2;mkVar s]) gl
+		else
+		  arec al
+	    | _ -> assert false
+	else
+	  arec al
+  in 
+  arec (pf_hyps_types gl)
+
+(* automatic: see above *)
+
+let (automatic : tactic) =
+  tclTHEN
+    loop_ids
+    (fun gl ->
+       let c = pf_concl gl in
+	 if pf_is_matching gl wf_nat_pattern c then
+	   exact_check (constant "lt_wf") gl
+	 else if pf_is_matching gl wf_z_pattern c then
+	   let (_,z) = List.hd (pf_matches gl wf_z_pattern c) in
+	   exact_check (Term.applist (constant "Zwf_well_founded",[z])) gl
+	 else if pf_is_matching gl and_pattern c then
+	   (tclORELSE assumption_bis
+	      (tclTRY (tclTHEN simplest_split assumption))) gl
+	 else if pf_is_matching gl eq_pattern c then
+	   (tclORELSE reflexivity (tclTRY assumption_bis)) gl
+	 else
+	   tclTRY assumption_bis gl)
+      
+(* [correctness s p] : string -> program -> tactic option -> unit
+ *
+ * Vernac: Correctness <string> <program> [; <tactic>].
+ *)
+
+let reduce_open_constr (em0,c) =
+  let existential_map_of_constr = 
+    let rec collect em c = match kind_of_term c with
+      | 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)
+                 else
+                   em
+	     | _ -> fold_constr collect em c)
+      | Evar _ -> 
+	  assert false (* all existentials should be casted *)
+      | _ -> 
+	  fold_constr collect em c
+    in
+    collect Evd.empty
+  in
+  let c = Pred.red_cci c in
+  let em = existential_map_of_constr c in
+  (em,c)
+
+let register id n =
+  let id' = match n with None -> id | Some id' -> id' in
+  Penv.register id id'
+
+  (* On dit à la commande "Save" d'enregistrer les nouveaux programmes *)
+let correctness_hook _ ref = 
+  let pf_id = Nametab.id_of_global ref in
+  register pf_id None
+
+let correctness s p opttac =
+  Library.check_required_library ["Coq";"correctness";"Correctness"];
+  Pmisc.reset_names();
+  let p,oc,cty,v = coqast_of_prog p in
+  let env = Global.env () in
+  let sign = Global.named_context () in
+  let sigma = Evd.empty in
+  let cty = Reduction.nf_betaiota cty in
+  let id = id_of_string s in 
+  start_proof id (IsGlobal (Proof Lemma)) sign cty correctness_hook;
+  Penv.new_edited id (v,p);
+  if !debug then msg (Pfedit.pr_open_subgoals());
+  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);
+  let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in
+  let tac = match opttac with 
+    | None -> tac
+    | Some t -> tclTHEN tac t
+  in
+  solve_nth 1 tac;
+  if_verbose msg (pr_open_subgoals ())
diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli
new file mode 100644
index 00000000..875e0780
--- /dev/null
+++ b/contrib/correctness/ptactic.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: ptactic.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+(* 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
+ * tactic with the partial proof term obtained by the translation of
+ * P into a functional program.
+ *
+ * Then an ad-hoc automatic tactic is applied on each subgoal to solve the
+ * trivial proof obligations *)
+
+val correctness : string -> Past.program -> Tacmach.tactic option -> unit
+
diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli
new file mode 100644
index 00000000..f2dc85e3
--- /dev/null
+++ b/contrib/correctness/ptype.mli
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ptype.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Term
+
+(* Types des valeurs (V) et des calculs (C).
+ *
+ * On a C = r:V,E,P,Q 
+ *
+ *   et V = (x1:V1)...(xn:Vn)C | V ref | V array | <type pur>
+ *
+ * INVARIANT: l'effet E contient toutes les variables apparaissant dans
+ *            le programme ET les annotations P et Q
+ *            Si E = { x1,...,xn | y1,...,ym }, les variables x sont les
+ *            variables en lecture seule et y1 les variables modifiées
+ *            les xi sont libres dans P et Q, et les yi,result liées dans Q
+ *            i.e.  P = p(x)
+ *               et Q = [y1]...[yn][res]q(x,y,res)
+ *)
+
+(* pre and post conditions *)
+
+type 'a precondition = { p_assert : bool; p_name : Names.name; p_value : 'a }
+
+type 'a assertion  = { a_name : Names.name; a_value : 'a }
+
+type 'a postcondition = 'a assertion
+
+type predicate = constr assertion
+
+(* binders *)
+
+type 'a binder_type =
+    BindType  of 'a
+  | BindSet
+  | Untyped
+
+type 'a binder = Names.identifier * 'a binder_type
+
+(* variant *)
+
+type variant = constr * constr * constr (* phi, R, A *)
+
+(* types des valeurs *)
+
+type 'a ml_type_v =
+    Ref       of 'a ml_type_v
+  | Array     of 'a * 'a ml_type_v   (* size x type *)
+  | Arrow     of 'a ml_type_v binder list * 'a ml_type_c
+
+  | TypePure  of 'a
+
+(* et type des calculs *)
+
+and 'a ml_type_c =
+    (Names.identifier * 'a ml_type_v) 
+  * Peffect.t
+  * ('a precondition list) * ('a postcondition option)
+
+(* at beginning they contain Coq AST but they become constr after typing *)
+type type_v = constr ml_type_v
+type type_c = constr ml_type_c
+
+
diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml
new file mode 100644
index 00000000..9047a925
--- /dev/null
+++ b/contrib/correctness/ptyping.ml
@@ -0,0 +1,600 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ptyping.ml,v 1.7.6.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Environ
+open Constrintern
+open Himsg
+open Proof_trees
+open Topconstr
+
+open Pmisc
+open Putil
+open Prename
+open Ptype
+open Past
+open Penv 
+open Peffect
+open Pcicenv
+
+(* Ce module implante le jugement  Gamma |-a e : kappa  de la thèse.
+ * Les annotations passent du type CoqAst.t au type Term.constr ici. 
+ * Les post-conditions sont abstraites par rapport au résultat. *)
+
+let simplify_type_of env sigma t =
+  Reductionops.nf_betaiota (Typing.type_of env sigma t)
+
+let just_reads e =
+  difference (get_reads e) (get_writes e)
+
+let type_v_sup loc t1 t2 =
+  if t1 = t2 then
+    t1
+  else
+    Perror.if_branches loc
+
+let typed_var ren env (phi,r) =
+  let sign = Pcicenv.before_after_sign_of ren env in
+  let a = simplify_type_of (Global.env_of_context sign) Evd.empty phi in
+  (phi,r,a)
+
+(* Application de fonction *)
+
+let rec convert = function
+  | (TypePure c1, TypePure c2) -> 
+      Reductionops.is_conv (Global.env ()) Evd.empty c1 c2
+  | (Ref v1, Ref v2) -> 
+      convert (v1,v2)
+  | (Array (s1,v1), Array (s2,v2)) -> 
+      (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2))
+  | (v1,v2) -> v1 = v2
+      
+let effect_app ren env f args =
+  let n = List.length args in
+  let tf = 
+    let ((_,v),_,_,_) = f.info.kappa in
+    match v with TypePure c -> v_of_constr c | _ -> v
+  in
+  let bl,c = 
+    match tf with
+	Arrow (bl, c) ->
+	  if List.length bl <> n then Perror.partial_app f.loc;
+	  bl,c
+      | _ -> Perror.app_of_non_function f.loc
+  in
+  let check_type loc v t so =
+    let v' = type_v_rsubst so v in
+    if not (convert (v',t)) then Perror.expected_type loc (pp_type_v v')
+  in
+  let s,so,ok = 
+    (* s est la substitution des références, so celle des autres arg. 
+     * ok nous dit si les arguments sont sans effet i.e. des expressions *)
+    List.fold_left
+    (fun (s,so,ok) (b,a) ->
+       match b,a with
+	   (id,BindType (Ref _ | Array _ as v)), Refarg id' ->
+	     let ta = type_in_env env id' in
+	     check_type f.loc v ta so;
+	     (id,id')::s, so, ok
+	 | _, Refarg _ -> Perror.should_be_a_variable f.loc
+	 | (id,BindType v), Term t ->
+	     let ((_,ta),_,_,_) = t.info.kappa in
+	     check_type t.loc v ta so;
+	     (match t.desc with
+		  Expression c -> s, (id,c)::so, ok
+		| _ -> s,so,false)
+	 | (id,BindSet), Type v ->
+	     let c = Pmonad.trad_ml_type_v ren env v in
+	     s, (id,c)::so, ok
+	 | (id,BindSet), Term t -> Perror.expects_a_type id t.loc
+	 | (id,BindType _), Type _ -> Perror.expects_a_term id
+	 | (_,Untyped), _ -> invalid_arg "effects_app")
+    ([],[],true)
+    (List.combine bl args)
+  in
+  let (id,v),ef,pre,post = type_c_subst s c in
+  (bl,c), (s,so,ok), ((id,type_v_rsubst so v),ef,pre,post)
+
+(* Execution of a Coq AST. Returns value and type.
+ * Also returns its variables *)
+
+let state_coq_ast sign a =
+  let env = Global.env_of_context sign in
+  let j =
+    reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in
+  let ids = global_vars env j.uj_val in
+  j.uj_val, j.uj_type, ids
+
+(* [is_pure p] tests wether the program p is an expression or not. *)
+
+let type_of_expression ren env c =
+  let sign = now_sign_of ren env in
+  simplify_type_of (Global.env_of_context sign) Evd.empty c
+
+let rec is_pure_type_v = function
+    TypePure _ -> true
+  | Arrow (bl,c) -> List.for_all is_pure_arg bl & is_pure_type_c c
+  | Ref _ | Array _ -> false
+and is_pure_arg = function
+    (_,BindType v) -> is_pure_type_v v
+  | (_,BindSet) -> true
+  | (_,Untyped) -> false
+and is_pure_type_c = function
+    (_,v),_,[],None -> is_pure_type_v v
+  | _ -> false
+
+let rec is_pure_desc ren env = function
+    Variable id ->
+      not (is_in_env env id) or (is_pure_type_v (type_in_env env id))
+  | Expression c -> 
+      (c = isevar) or (is_pure_cci (type_of_expression ren env c))
+  | Acc _ -> true
+  | TabAcc (_,_,p) -> is_pure ren env p
+  | Apply (p,args) -> 
+      is_pure ren env p & List.for_all (is_pure_arg ren env) args
+  | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _ 
+  | Lam _ | LetRef _ | Let _ | LetRec _ -> false
+  | Debug (_,p) -> is_pure ren env p
+  | PPoint (_,d) -> is_pure_desc ren env d
+and is_pure ren env p =
+  p.pre = [] & p.post = None & is_pure_desc ren env p.desc
+and is_pure_arg ren env = function
+    Term p -> is_pure ren env p
+  | Type _ -> true
+  | Refarg _ -> false
+
+(* [state_var ren env (phi,r)] returns a tuple (e,(phi',r')) 
+ * where e is the effect of the variant phi and phi',r' the corresponding 
+ * constr of phi and r.
+ *)
+
+let state_var ren env (phi,r) = 
+  let sign = Pcicenv.before_after_sign_of ren env in
+  let phi',_,ids = state_coq_ast sign phi in
+  let ef = List.fold_left
+	     (fun e id ->
+		if is_mutable_in_env env id then Peffect.add_read id e else e)
+	     Peffect.bottom ids in
+  let r',_,_ = state_coq_ast (Global.named_context ()) r in
+  ef,(phi',r')
+	
+(* [state_pre ren env pl] returns a pair (e,c) where e is the effect of the
+ * pre-conditions list pl and cl the corresponding constrs not yet abstracted
+ * over the variables xi (i.e. c NOT [x1]...[xn]c !)
+ *)
+
+let state_pre ren env pl =
+  let state e p =
+    let sign = Pcicenv.before_sign_of ren env in
+    let cc,_,ids = state_coq_ast sign p.p_value in
+    let ef = List.fold_left
+	       (fun e id ->
+		  if is_mutable_in_env env id then
+		    Peffect.add_read id e
+		  else if is_at id then
+		    let uid,_ = un_at id in
+		    if is_mutable_in_env env uid then
+		      Peffect.add_read uid e
+		    else
+		      e
+	     	  else
+		    e)
+	       e ids 
+    in
+    ef,{ p_assert = p.p_assert; p_name = p.p_name; p_value = cc }
+  in
+  List.fold_left 
+    (fun (e,cl) p -> let ef,c = state e p in (ef,c::cl)) 
+    (Peffect.bottom,[]) pl
+
+let state_assert ren env a =
+  let p = pre_of_assert true a in
+  let e,l = state_pre ren env [p] in
+  e,assert_of_pre (List.hd l)
+
+let state_inv ren env = function
+    None -> Peffect.bottom, None
+  | Some i -> let e,p = state_assert ren env i in e,Some p
+	  
+(* [state_post ren env (id,v,ef) q] returns a pair (e,c)
+ * where e is the effect of the
+ * post-condition q and c the corresponding constr not yet abstracted
+ * over the variables xi, yi and result.
+ * Moreover the RW variables not appearing in ef have been replaced by
+ * RO variables, and (id,v) is the result
+ *)
+
+let state_post ren env (id,v,ef) = function
+    None -> Peffect.bottom, None
+  | Some q ->
+      let v' = Pmonad.trad_ml_type_v ren env v in
+      let sign = Pcicenv.before_after_result_sign_of (Some (id,v')) ren env in
+      let cc,_,ids = state_coq_ast sign q.a_value in
+      let ef,c = 
+	List.fold_left
+	  (fun (e,c) id ->
+	     if is_mutable_in_env env id then
+	       if is_write ef id then
+		 Peffect.add_write id e, c
+	       else
+		 Peffect.add_read id e,
+		 subst_in_constr [id,at_id id ""] c
+	     else if is_at id then
+	       let uid,_ = un_at id in
+	       if is_mutable_in_env env uid then
+		 Peffect.add_read uid e, c
+	       else
+		 e,c
+	     else
+	       e,c)
+	  (Peffect.bottom,cc) ids 
+      in
+      let c = abstract [id,v'] c in
+      ef, Some { a_name = q.a_name; a_value = c }
+
+(* transformation of AST into constr in types V and C *)
+
+let rec cic_type_v env ren = function
+  | Ref v -> Ref (cic_type_v env ren v)
+  | Array (com,v) ->
+      let sign = Pcicenv.now_sign_of ren env in
+      let c = interp_constr Evd.empty (Global.env_of_context sign) com in
+      Array (c, cic_type_v env ren v)
+  | Arrow (bl,c) ->
+      let bl',ren',env' =
+	List.fold_left
+	(fun (bl,ren,env) b ->
+	   let b' = cic_binder env ren b in
+	   let env' = traverse_binders env [b'] in
+	   let ren' = initial_renaming env' in
+	     b'::bl,ren',env')
+	([],ren,env) bl
+      in
+      let c' = cic_type_c env' ren' c in
+      Arrow (List.rev bl',c')
+  | TypePure com ->
+      let sign = Pcicenv.cci_sign_of ren env in
+      let c = interp_constr Evd.empty (Global.env_of_context sign) com in
+      TypePure c
+
+and cic_type_c env ren ((id,v),e,p,q) =
+  let v' = cic_type_v env ren v in
+  let cv = Pmonad.trad_ml_type_v ren env v' in
+  let efp,p' = state_pre ren env p in
+  let efq,q' = state_post ren env (id,v',e) q in
+  let ef = Peffect.union e (Peffect.union efp efq) in
+  ((id,v'),ef,p',q')
+
+and cic_binder env ren = function
+  | (id,BindType v) ->
+      let v' = cic_type_v env ren v in
+      let env' = add (id,v') env in
+      let ren' = initial_renaming env' in
+      (id, BindType v')
+  | (id,BindSet) -> (id,BindSet)
+  | (id,Untyped) -> (id,Untyped)
+
+and cic_binders env ren = function
+    [] -> []
+  | b::bl ->
+      let b' = cic_binder env ren b in
+      let env' = traverse_binders env [b'] in
+      let ren' = initial_renaming env' in
+      b' :: (cic_binders env' ren' bl)
+
+
+(* The case of expressions.
+ * 
+ * Expressions are programs without neither effects nor pre/post conditions.
+ * But access to variables are allowed.
+ *
+ * Here we transform an expression into the corresponding constr,
+ * the variables still appearing as VAR (they will be abstracted in
+ * Mlise.trad)
+ * We collect the pre-conditions (e<N for t[e]) as we traverse the term.
+ * We also return the effect, which does contain only *read* variables.
+ *)
+
+let states_expression ren env expr =
+  let rec effect pl = function
+    | Variable id -> 
+	(if is_global id then constant (string_of_id id) else mkVar id),
+	pl, Peffect.bottom
+    | Expression c -> c, pl, Peffect.bottom
+    | Acc id -> mkVar id, pl, Peffect.add_read id Peffect.bottom
+    | TabAcc (_,id,p) ->
+	let c,pl,ef = effect pl p.desc in
+	let pre = Pmonad.make_pre_access ren env id c in
+	Pmonad.make_raw_access ren env (id,id) c, 
+	(anonymous_pre true pre)::pl, Peffect.add_read id ef
+    | Apply (p,args) ->
+	let a,pl,e = effect pl p.desc in
+	let args,pl,e =
+	  List.fold_right
+	    (fun arg (l,pl,e) -> 
+	       match arg with
+		   Term p ->
+		     let carg,pl,earg = effect pl p.desc in
+		     carg::l,pl,Peffect.union e earg
+		 | Type v ->
+		     let v' = cic_type_v env ren v in
+		     (Pmonad.trad_ml_type_v ren env v')::l,pl,e
+		 | Refarg _ -> assert false) 
+	    args ([],pl,e) 
+	in
+	Term.applist (a,args),pl,e
+    | _ -> invalid_arg "Ptyping.states_expression"
+  in
+  let e0,pl0 = state_pre ren env expr.pre in
+  let c,pl,e = effect [] expr.desc in
+  let sign = Pcicenv.before_sign_of ren env in
+  (*i WAS
+  let c = (Trad.ise_resolve true empty_evd [] (gLOB sign) c)._VAL in
+  i*)
+  let ty = simplify_type_of (Global.env_of_context sign) Evd.empty c in
+  let v = TypePure ty in
+  let ef = Peffect.union e0 e in
+  Expression c, (v,ef), pl0@pl
+
+
+(* We infer here the type with effects.
+ * The type of types with effects (ml_type_c) is defined in the module ProgAst.
+ * 
+ * A program of the shape {P} e {Q} has a type 
+ *   
+ *        V, E, {None|Some P}, {None|Some Q}
+ *
+ * where - V is the type of e
+ *       - E = (I,O) is the effect; the input I contains
+ *         all the input variables appearing in P,e and Q;
+ *         the output O contains variables possibly modified in e
+ *       - P is NOT abstracted
+ *       - Q = [y'1]...[y'k][result]Q where O = {y'j}
+ *         i.e. Q is only abstracted over the output and the result
+ *         the other variables now refer to value BEFORE
+ *)
+
+let verbose_fix = ref false
+
+let rec states_desc ren env loc = function
+	
+    Expression c ->
+      let ty = type_of_expression ren env c in
+      let v = v_of_constr ty in
+      Expression c, (v,Peffect.bottom)
+
+  | Acc _ ->
+      failwith "Ptyping.states: term is supposed not to be pure"
+
+  | Variable id ->
+      let v = type_in_env env id in
+      let ef = Peffect.bottom in
+      Variable id, (v,ef)
+
+  | Aff (x, e1) ->
+      Perror.check_for_reference loc x (type_in_env env x);
+      let s_e1 = states ren env e1 in
+      let _,e,_,_ = s_e1.info.kappa in
+      let ef = add_write x e in
+      let v = constant_unit () in
+      Aff (x, s_e1), (v, ef)
+
+  | TabAcc (check, x, e) ->
+      let s_e = states ren env e in
+      let _,efe,_,_ = s_e.info.kappa in
+      let ef = Peffect.add_read x efe in
+      let _,ty = dearray_type (type_in_env env x) in
+      TabAcc (check, x, s_e), (ty, ef)
+
+  | TabAff (check, x, e1, e2) ->
+      let s_e1 = states ren env e1 in
+      let s_e2 = states ren env e2 in 
+      let _,ef1,_,_ = s_e1.info.kappa in
+      let _,ef2,_,_ = s_e2.info.kappa in
+      let ef = Peffect.add_write x (Peffect.union ef1 ef2) in
+      let v = constant_unit () in
+      TabAff (check, x, s_e1, s_e2), (v,ef)
+
+  | Seq bl ->
+      let bl,v,ef,_ = states_block ren env bl in
+      Seq bl, (v,ef)
+	      
+  | While(b, invopt, var, bl) ->
+      let efphi,(cvar,r') = state_var ren env var in
+      let ren' = next ren [] in
+      let s_b = states ren' env b in
+      let s_bl,_,ef_bl,_ = states_block ren' env bl in
+      let cb = s_b.info.kappa in
+      let efinv,inv = state_inv ren env invopt in
+      let _,efb,_,_ = s_b.info.kappa in
+      let ef = 
+	Peffect.union (Peffect.union ef_bl efb) (Peffect.union efinv efphi)
+      in
+      let v = constant_unit () in
+      let cvar = 
+	let al = List.map (fun id -> (id,at_id id "")) (just_reads ef) in
+	subst_in_constr al cvar 
+      in
+      While (s_b,inv,(cvar,r'),s_bl), (v,ef)
+      
+  | Lam ([],_) ->
+      failwith "Ptyping.states: abs. should have almost one binder"
+
+  | Lam (bl, e) ->
+      let bl' = cic_binders env ren bl in
+      let env' = traverse_binders env bl' in
+      let ren' = initial_renaming env' in
+      let s_e = states ren' env' e in
+      let v = make_arrow bl' s_e.info.kappa in
+      let ef = Peffect.bottom in
+      Lam(bl',s_e), (v,ef)
+	 
+  (* Connectives AND and OR *)
+  | SApp ([Variable id], [e1;e2]) ->
+      let s_e1 = states ren env e1
+      and s_e2 = states ren env e2 in
+      let (_,ef1,_,_) = s_e1.info.kappa
+      and (_,ef2,_,_) = s_e2.info.kappa in
+      let ef = Peffect.union ef1 ef2 in
+      SApp ([Variable id], [s_e1; s_e2]), 
+      (TypePure (constant "bool"), ef)
+
+  (* Connective NOT *)
+  | SApp ([Variable id], [e]) ->
+      let s_e = states ren env e in
+      let (_,ef,_,_) = s_e.info.kappa in
+      SApp ([Variable id], [s_e]), 
+      (TypePure (constant "bool"), ef)
+      
+  | SApp _ -> invalid_arg "Ptyping.states (SApp)"
+
+  (* ATTENTION:
+     Si un argument réel de type ref. correspond à une ref. globale
+     modifiée par la fonction alors la traduction ne sera pas correcte.
+     Exemple:
+            f=[x:ref Int]( r := !r+1 ; x := !x+1) modifie r et son argument x
+            donc si on l'applique à r justement, elle ne modifiera que r
+            mais le séquencement ne sera pas correct. *)
+
+  | Apply (f, args) ->
+      let s_f = states ren env f in
+      let _,eff,_,_ = s_f.info.kappa in
+      let s_args = List.map (states_arg ren env) args in
+      let ef_args = 
+	List.map 
+	  (function Term t -> let (_,e,_,_) = t.info.kappa in e
+	          | _ -> Peffect.bottom) 
+	  s_args 
+      in
+      let _,_,((_,tapp),efapp,_,_) = effect_app ren env s_f s_args in
+      let ef = 
+	Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp
+      in
+      Apply (s_f, s_args), (tapp, ef)
+      
+  | LetRef (x, e1, e2) ->
+      let s_e1 = states ren env e1 in
+      let (_,v1),ef1,_,_ = s_e1.info.kappa in
+      let env' = add (x,Ref v1) env in
+      let ren' = next ren [x] in
+      let s_e2 = states ren' env' e2 in
+      let (_,v2),ef2,_,_ = s_e2.info.kappa in
+      Perror.check_for_let_ref loc v2;
+      let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in
+      LetRef (x, s_e1, s_e2), (v2,ef)
+	
+  | Let (x, e1, e2) ->
+      let s_e1 = states ren env e1 in
+      let (_,v1),ef1,_,_ = s_e1.info.kappa in
+      Perror.check_for_not_mutable e1.loc v1;
+      let env' = add (x,v1) env in
+      let s_e2 = states ren env' e2 in
+      let (_,v2),ef2,_,_ = s_e2.info.kappa in
+      let ef = Peffect.compose ef1 ef2 in
+      Let (x, s_e1, s_e2), (v2,ef)
+	    
+  | If (b, e1, e2) ->
+      let s_b = states ren env b in
+      let s_e1 = states ren env e1
+      and s_e2 = states ren env e2 in
+      let (_,tb),efb,_,_ = s_b.info.kappa in
+      let (_,t1),ef1,_,_ = s_e1.info.kappa in
+      let (_,t2),ef2,_,_ = s_e2.info.kappa in
+      let ef = Peffect.compose efb (disj ef1 ef2) in
+      let v = type_v_sup loc t1 t2 in
+      If (s_b, s_e1, s_e2), (v,ef)
+
+  | LetRec (f,bl,v,var,e) ->
+      let bl' = cic_binders env ren bl in
+      let env' = traverse_binders env bl' in
+      let ren' = initial_renaming env' in
+      let v' = cic_type_v env' ren' v in
+      let efvar,var' = state_var ren' env' var in
+      let phi0 = phi_name () in
+      let tvar = typed_var ren env' var' in
+      (* effect for a let/rec construct is computed as a fixpoint *)
+      let rec state_rec c =
+	let tf = make_arrow bl' c in
+	let env'' = add_recursion (f,(phi0,tvar)) (add (f,tf) env') in
+	let s_e = states ren' env'' e in
+	if s_e.info.kappa = c then
+	  s_e
+      	else begin
+	  if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ;
+	  state_rec s_e.info.kappa
+      	end
+      in 
+      let s_e = state_rec ((result_id,v'),efvar,[],None) in
+      let tf = make_arrow bl' s_e.info.kappa in
+      LetRec (f,bl',v',var',s_e), (tf,Peffect.bottom)
+
+  | PPoint (s,d) -> 
+      let ren' = push_date ren s in
+      states_desc ren' env loc d
+	
+  | Debug _ -> failwith "Ptyping.states: Debug: TODO"
+
+
+and states_arg ren env = function
+    Term a    -> let s_a = states ren env a in Term s_a
+  | Refarg id -> Refarg id
+  | Type v    -> let v' = cic_type_v env ren v in Type v'
+	
+
+and states ren env expr =
+  (* Here we deal with the pre- and post- conditions:
+   * we add their effects to the effects of the program *)
+  let (d,(v,e),p1) = 
+    if is_pure_desc ren env expr.desc then
+      states_expression ren env expr
+    else
+      let (d,ve) = states_desc ren env expr.loc expr.desc in (d,ve,[])
+  in
+  let (ep,p) = state_pre ren env expr.pre in
+  let (eq,q) = state_post ren env (result_id,v,e) expr.post in
+  let e' = Peffect.union e (Peffect.union ep eq) in
+  let p' = p1 @ p in
+  let tinfo = { env = env; kappa = ((result_id,v),e',p',q) } in
+  { desc = d;
+    loc = expr.loc;
+    pre = p'; post = q; (* on les conserve aussi ici pour prog_wp *)
+    info = tinfo }
+
+
+and states_block ren env bl =
+  let rec ef_block ren tyres = function
+      [] ->
+	begin match tyres with
+	    Some ty -> [],ty,Peffect.bottom,ren
+	  | None -> failwith "a block should contain at least one statement"
+	end
+    | (Assert p)::block -> 
+	let ep,c = state_assert ren env p in
+	let bl,t,ef,ren' = ef_block ren tyres block in
+	(Assert c)::bl,t,Peffect.union ep ef,ren'
+    | (Label s)::block ->
+	let ren' = push_date ren s in
+	let bl,t,ef,ren'' = ef_block ren' tyres block in
+	(Label s)::bl,t,ef,ren''
+    | (Statement e)::block ->
+	let s_e = states ren env e in
+	let (_,t),efe,_,_ = s_e.info.kappa in
+	let ren' = next ren (get_writes efe) in
+	let bl,t,ef,ren'' = ef_block ren' (Some t) block in
+	(Statement s_e)::bl,t,Peffect.compose efe ef,ren''
+  in
+  ef_block ren None bl
+
diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli
new file mode 100644
index 00000000..0c0d5905
--- /dev/null
+++ b/contrib/correctness/ptyping.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ptyping.mli,v 1.3.6.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Names
+open Term
+open Topconstr
+
+open Ptype
+open Past
+open Penv
+
+(* This module realizes type and effect inference *)
+
+val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v
+
+val effect_app : Prename.t -> local_env
+            -> (typing_info,'b) Past.t
+            -> (typing_info,constr) arg list
+            -> (type_v binder list * type_c) 
+             * ((identifier*identifier) list * (identifier*constr) list * bool)
+             * type_c
+
+val typed_var : Prename.t -> local_env -> constr * constr -> variant
+
+val type_of_expression : Prename.t -> local_env -> constr -> constr
+
+val states : Prename.t -> local_env -> program -> typed_program
diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml
new file mode 100644
index 00000000..48f0781a
--- /dev/null
+++ b/contrib/correctness/putil.ml
@@ -0,0 +1,303 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: putil.ml,v 1.10.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Pattern
+open Matching
+open Hipattern
+open Environ
+
+open Pmisc
+open Ptype
+open Past
+open Penv
+open Prename
+
+let is_mutable = function Ref _ | Array _ -> true | _ -> false
+let is_pure = function TypePure _ -> true | _ -> false
+
+let named_app f x = { a_name = x.a_name; a_value = (f x.a_value) }
+
+let pre_app f x = 
+  { p_assert = x.p_assert; p_name = x.p_name; p_value = f x.p_value }
+
+let post_app = named_app
+
+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
+
+let force_post_name x = force_name post_name x
+
+let force_bool_name x = 
+  force_name (function Name id -> id | Anonymous -> bool_name()) x
+
+let out_post = function
+    Some { a_value = x } -> x
+  | None -> invalid_arg "out_post"
+
+let pre_of_assert b x =
+  { p_assert = b; p_name = x.a_name; p_value = x.a_value }
+
+let assert_of_pre x =
+  { a_name = x.p_name; a_value = x.p_value }
+
+(* Some generic functions on programs *)
+
+let is_mutable_in_env env id =
+  (is_in_env env id) & (is_mutable (type_in_env env id))
+
+let now_vars env c =
+  Util.map_succeed 
+    (function id -> if is_mutable_in_env env id then id else failwith "caught")
+    (global_vars (Global.env()) c)
+
+let make_before_after c =
+  let ids = global_vars (Global.env()) c in
+  let al = 
+    Util.map_succeed
+      (function id -> 
+	 if is_at id then 
+	   match un_at id with (uid,"") -> (id,uid) | _ -> failwith "caught"
+	 else failwith "caught")
+      ids
+  in
+  subst_in_constr al c
+
+(* [apply_pre] and [apply_post] instantiate pre- and post- conditions
+ * according to a given renaming of variables (and a date that means
+ * `before' in the case of the post-condition).
+ *)
+
+let make_assoc_list ren env on_prime ids =
+  List.fold_left
+    (fun al id ->
+       if is_mutable_in_env env id then
+	 (id,current_var ren id)::al
+       else if is_at id then
+	 let uid,d = un_at id in
+	   if is_mutable_in_env env uid then
+	     (match d with
+		  "" -> (id,on_prime ren uid)
+		| _  -> (id,var_at_date ren d uid))::al
+	   else
+	     al
+       else
+	 al) 
+    [] ids
+
+let apply_pre ren env c =
+  let ids = global_vars (Global.env()) c.p_value in
+  let al = make_assoc_list ren env current_var ids in
+  { p_assert = c.p_assert; p_name = c.p_name; 
+    p_value = subst_in_constr al c.p_value }
+
+let apply_assert ren env c =
+  let ids = global_vars (Global.env()) c.a_value in
+  let al = make_assoc_list ren env current_var ids in
+  { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
+ 
+let apply_post ren env before c =
+  let ids = global_vars (Global.env()) c.a_value in
+  let al = 
+    make_assoc_list ren env (fun r uid -> var_at_date r before uid) ids in
+  { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
+
+(* [traverse_binder ren env bl] updates renaming [ren] and environment [env]
+ * as we cross the binders [bl]
+ *)
+
+let rec traverse_binders env = function
+    [] -> env
+  | (id,BindType v)::rem ->
+      traverse_binders (add (id,v) env) rem
+  | (id,BindSet)::rem ->
+      traverse_binders (add_set id env) rem
+  | (_,Untyped)::_ ->
+      invalid_arg "traverse_binders"
+	  
+let initial_renaming env =
+  let ids = Penv.fold_all (fun (id,_) l -> id::l) env [] in
+    update empty_ren "0" ids
+
+
+(* Substitutions *)
+
+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
+
+and type_v_subst s = function
+    Ref v -> Ref (type_v_subst s v)
+  | Array (n,v) -> Array (n,type_v_subst s v)
+  | Arrow (bl,c) -> Arrow(List.map (binder_subst s) bl, type_c_subst s c)
+  | (TypePure _) as v -> v
+
+and binder_subst s = function
+    (n, BindType v) -> (n, BindType (type_v_subst s v))
+  | b -> b
+
+(* substitution of constr by others *)
+
+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
+
+and type_v_rsubst s = function
+    Ref v -> Ref (type_v_rsubst s v)
+  | Array (n,v) -> Array (real_subst_in_constr s n,type_v_rsubst s v)
+  | Arrow (bl,c) -> Arrow(List.map (binder_rsubst s) bl, type_c_rsubst s c)
+  | TypePure c -> TypePure (real_subst_in_constr s c)
+
+and binder_rsubst s = function
+  | (n, BindType v) -> (n, BindType (type_v_rsubst s v))
+  | b -> b
+
+(* make_arrow bl c = (x1:V1)...(xn:Vn)c *)
+
+let make_arrow bl c = match bl with
+  | [] -> invalid_arg "make_arrow: no binder"
+  | _ -> Arrow (bl,c)
+
+(* misc. functions *)
+
+let deref_type = function
+  | Ref v -> v
+  | _ -> invalid_arg "deref_type"
+
+let dearray_type = function
+  | Array (size,v) -> size,v
+  | _ -> invalid_arg "dearray_type"
+
+let constant_unit () = TypePure (constant "unit")
+
+let id_from_name = function Name id -> id | Anonymous -> (id_of_string "X")
+
+(* v_of_constr : traduit un type CCI en un type ML *)
+
+(* TODO: faire un test plus serieux sur le type des objets Coq *)
+let rec is_pure_cci c = match kind_of_term c with
+  | Cast (c,_) -> is_pure_cci c
+  | Prod(_,_,c') -> is_pure_cci c'
+  | Rel _ | Ind _ | Const _ -> true (* heu... *)
+  | App _ -> not (is_matching_sigma c)
+  | _ -> Util.error "CCI term not acceptable in programs"
+
+let rec v_of_constr c = match kind_of_term c with
+  | Cast (c,_) -> v_of_constr c
+  | Prod _ ->
+      let revbl,t2 = Term.decompose_prod c in
+      let bl =
+	List.map
+	  (fun (name,t1) -> (id_from_name name, BindType (v_of_constr t1)))
+	  (List.rev revbl)
+      in
+      let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in
+      Arrow (bl, c_of_constr (substl vars t2))
+  | Ind _ | Const _ | App _ ->
+      TypePure c
+  | _ -> 
+      failwith "v_of_constr: TODO"
+
+and c_of_constr c =
+  if is_matching_sigma c then
+    let (a,q) = match_sigma c in
+    (result_id, v_of_constr a), Peffect.bottom, [], Some (anonymous q)
+  else
+    (result_id, v_of_constr c), Peffect.bottom, [], None
+
+
+(* pretty printers (for debugging purposes) *)
+
+open Pp
+open Util
+
+let prterm x = Printer.prterm_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)
+
+let pp_post = function
+    None -> (mt ())
+  | Some c -> hov 0 (str"post " ++ prterm 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)
+  | Arrow (b,c) -> 
+      hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ 
+	       pp_type_c c)
+  | TypePure c -> prterm c
+
+and pp_type_c ((id,v),e,p,q) =
+  hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ 
+	   Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++
+	   spc () ++ str"end")
+
+and pp_binder = function
+    id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")")
+  | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)")
+  | id,Untyped -> (str"(" ++ pr_id id ++ str")")
+
+(* pretty-print of cc-terms (intermediate terms) *)
+
+let rec pp_cc_term = function
+    CC_var id -> pr_id id
+  | CC_letin (_,_,bl,c,c1) ->
+      hov 0 (hov 2 (str"let " ++
+		  	prlist_with_sep (fun () -> (str","))
+			  (fun (id,_) -> pr_id id) bl ++
+		  	str" =" ++ spc () ++
+		  	pp_cc_term c ++
+		  	str " in") ++
+	       fnl () ++
+	       pp_cc_term c1)
+  | CC_lam (bl,c) ->
+      hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++
+	       cut () ++
+	       pp_cc_term c)
+  | CC_app (f,args) ->
+      hov 2 (str"(" ++ 
+	       pp_cc_term f ++ spc () ++
+	       prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++
+	       str")")
+  | CC_tuple (_,_,cl) ->
+      hov 2 (str"(" ++
+	       prlist_with_sep (fun () -> (str"," ++ cut ()))
+		 pp_cc_term cl ++
+	       str")")
+  | CC_case (_,b,[e1;e2]) ->
+      hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++
+	       str"  " ++ hov 0 (pp_cc_term e1) ++ fnl () ++
+	       str"else" ++ fnl () ++
+	       str"  " ++ hov 0 (pp_cc_term e2))
+  | CC_case _ ->
+      hov 0 (str"<Case: not yet implemented>")
+  | CC_expr c ->
+      hov 0 (prterm c)
+  | CC_hole c ->
+      (str"(?::" ++ prterm c ++ str")")
+
diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli
new file mode 100644
index 00000000..b44774ae
--- /dev/null
+++ b/contrib/correctness/putil.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        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: putil.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Pp
+open Names
+open Term
+open Pmisc
+open Ptype
+open Past
+open Penv
+
+val is_mutable : 'a ml_type_v -> bool
+val is_pure : 'a ml_type_v -> bool
+
+val named_app : ('a -> 'b) -> 'a assertion -> 'b assertion
+val pre_app : ('a -> 'b) -> 'a precondition -> 'b precondition
+val post_app : ('a -> 'b) -> 'a postcondition -> 'b postcondition
+
+val anonymous : 'a -> 'a assertion
+val anonymous_pre : bool -> 'a -> 'a precondition
+val out_post : 'a postcondition option -> 'a
+val pre_of_assert : bool -> 'a assertion -> 'a precondition
+val assert_of_pre : 'a precondition -> 'a assertion
+
+val force_post_name : 'a postcondition option -> 'a postcondition option
+val force_bool_name : 'a postcondition option -> 'a postcondition option
+
+val make_before_after : constr -> constr
+
+val traverse_binders : local_env -> (type_v binder) list -> local_env
+val initial_renaming : local_env -> Prename.t
+
+val apply_pre : Prename.t -> local_env -> constr precondition ->
+  constr precondition
+val apply_post : Prename.t -> local_env -> string -> constr postcondition ->
+  constr postcondition
+val apply_assert : Prename.t -> local_env -> constr assertion ->
+  constr assertion
+
+val type_v_subst : (identifier * identifier) list -> type_v -> type_v
+val type_c_subst : (identifier * identifier) list -> type_c -> type_c
+
+val type_v_rsubst : (identifier * constr) list -> type_v -> type_v
+val type_c_rsubst : (identifier * constr) list -> type_c -> type_c
+
+val make_arrow : ('a ml_type_v binder) list -> 'a ml_type_c -> 'a ml_type_v
+
+val is_mutable_in_env : local_env -> identifier -> bool
+val now_vars : local_env -> constr -> identifier list
+
+val deref_type : 'a ml_type_v -> 'a ml_type_v
+val dearray_type : 'a ml_type_v -> 'a * 'a ml_type_v
+val constant_unit : unit -> constr ml_type_v
+val v_of_constr : constr -> constr ml_type_v
+val c_of_constr : constr -> constr ml_type_c
+val is_pure_cci : constr -> bool
+
+(* pretty printers *)
+
+val pp_type_v : type_v -> std_ppcmds
+val pp_type_c : type_c -> std_ppcmds
+val pp_cc_term : cc_term -> std_ppcmds
+
diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml
new file mode 100644
index 00000000..58bef673
--- /dev/null
+++ b/contrib/correctness/pwp.ml
@@ -0,0 +1,347 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pwp.ml,v 1.8.2.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Term
+open Termops
+open Environ
+open Nametab
+
+open Pmisc
+open Ptype
+open Past
+open Putil
+open Penv
+open Peffect
+open Ptyping
+open Prename
+
+(* In this module:
+ *  - we try to insert more annotations to achieve a greater completeness;
+ *  - we recursively propagate annotations inside programs;
+ *  - we normalize boolean expressions.
+ *
+ * The propagation schemas are the following:
+ * 
+ *  1. (f a1 ... an)  ->  (f a1 ... an) {Qf} if the ai are functional
+ *
+ *  2. (if e1 then e2 else e3) {Q}  ->  (if e1 then e2 {Q} else e3 {Q}) {Q}
+ * 
+ *  3. (let x = e1 in e2) {Q}  ->  (let x = e1 in e2 {Q}) {Q}
+ *)
+
+(* force a post-condition *)
+let update_post env top ef c =
+  let i,o = Peffect.get_repr ef in
+  let al = 
+    List.fold_left 
+      (fun l id -> 
+	 if is_mutable_in_env env id then
+	   if is_write ef id then l else (id,at_id id "")::l
+	 else if is_at id then
+	   let (uid,d) = un_at id in
+	   if is_mutable_in_env env uid & d="" then 
+	     (id,at_id uid top)::l 
+	   else 
+	     l
+	 else
+	   l) 
+      [] (global_vars (Global.env()) c)
+  in
+  subst_in_constr al 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 
+  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 }
+
+(* put a post-condition if none is present *)
+let post_if_none_up env top q = function
+  | { post = None } as p -> force_post true env top q p 
+  | p -> p
+
+let post_if_none env q = function
+  | { post = None } as p -> force_post false env "" q p 
+  | p -> p
+
+(* [annotation_candidate p] determines if p is a candidate for a 
+ * post-condition *)
+
+let annotation_candidate = function
+  | { desc = If _ | Let _ | LetRef _ ; post = None } -> true
+  | _ -> false
+
+(* [extract_pre p] erase the pre-condition of p and returns it *)
+let extract_pre pr =
+  let (v,e,p,q) = pr.info.kappa in
+  { desc = pr.desc; pre = []; post = pr.post; loc = pr.loc;
+    info = { env = pr.info.env; kappa = (v,e,[],q) } },
+  p
+
+(* adds some pre-conditions *)
+let add_pre p1 pr =
+  let (v,e,p,q) = pr.info.kappa in
+  let p' = p1 @ p in
+  { desc = pr.desc; pre = p'; post = pr.post; loc = pr.loc;
+    info = { env = pr.info.env; kappa = (v,e,p',q) } }
+  
+(* change the statement *)
+let change_desc p d =
+  { desc = d; pre = p.pre; post = p.post; loc = p.loc; info = p.info }
+
+let create_bool_post c =
+  Some { a_value = c; a_name = Name (bool_name()) }
+
+(* [normalize_boolean b] checks if the boolean expression b (of type bool) is 
+ * annotated, and if it is not the case tries to add the annotation
+ * (if result then c=true else c=false) if b is an expression c.
+ *)
+
+let is_bool = function
+  | TypePure c ->
+      (match kind_of_term (strip_outer_cast c) with
+	 | Ind op ->
+             string_of_id (id_of_global (IndRef op)) = "bool"
+	 | _ -> false)
+  | _ -> false
+
+let normalize_boolean ren env b =
+  let ((res,v),ef,p,q) = b.info.kappa in
+  Perror.check_no_effect b.loc ef;
+  if is_bool v then
+    match q with
+      | Some _ ->
+	  (* il y a une annotation : on se contente de lui forcer un nom *)
+	  let q = force_bool_name q in
+	  { desc = b.desc; pre = b.pre; post = q; loc = b.loc;
+	    info = { env = b.info.env; kappa = ((res,v),ef,p,q) } }
+      | None -> begin
+	  (* il n'y a pas d'annotation : on cherche à en mettre une *)
+	  match b.desc with
+	      Expression c ->
+	    	let c' = Term.applist (constant "annot_bool",[c]) in
+		let ty = type_of_expression ren env c' in
+		let (_,q') = Hipattern.match_sigma ty in
+		let q' = Some { a_value = q'; a_name = Name (bool_name()) } in
+		{ desc = Expression c'; 
+		  pre = b.pre; post = q'; loc = b.loc;
+		  info = { env = b.info.env; kappa = ((res, v),ef,p,q') } }
+	    | _ -> b
+	end
+  else
+    Perror.should_be_boolean b.loc
+
+(* [decomp_boolean c] returns the specs R and S of a boolean expression *)
+
+let decomp_boolean = function
+  | Some { a_value = q } ->
+      Reductionops.whd_betaiota (Term.applist (q, [constant "true"])),
+      Reductionops.whd_betaiota (Term.applist (q, [constant "false"]))
+  | _ -> invalid_arg "Ptyping.decomp_boolean"
+
+(* top point of a program *)
+
+let top_point = function
+  | PPoint (s,_) as p -> s,p
+  | p -> let s = label_name() in s,PPoint(s,p)
+
+let top_point_block = function
+  | (Label s :: _) as b -> s,b
+  | b -> let s = label_name() in s,(Label s)::b
+
+let abstract_unit q = abstract [result_id,constant "unit"] q
+
+(* [add_decreasing env ren ren' phi r bl] adds the decreasing condition
+ *    phi(ren') r phi(ren)
+ * to the last assertion of the block [bl], which is created if needed
+ *)
+
+let add_decreasing env inv (var,r) lab bl =
+  let ids = now_vars env var in
+  let al = List.map (fun id -> (id,at_id id lab)) ids in
+  let var_lab = subst_in_constr al var in
+  let dec = Term.applist (r, [var;var_lab]) in
+  let post = match inv with
+      None -> anonymous dec
+    | Some i -> { a_value = conj dec i.a_value; a_name = i.a_name }
+  in
+  bl @ [ Assert post ]
+
+(* [post_last_statement env top q bl] annotates the last statement of the
+ * sequence bl with q if necessary *)
+
+let post_last_statement env top q bl =
+  match List.rev bl with
+    | Statement e :: rem when annotation_candidate e -> 
+	List.rev ((Statement (post_if_none_up env top q e)) :: rem)
+    | _ -> bl
+
+(* [propagate_desc] moves the annotations inside the program 
+ * info is the typing information coming from the outside annotations *)
+let rec propagate_desc ren info d = 
+  let env = info.env in
+  let (_,_,p,q) = info.kappa in
+  match d with
+    | If (e1,e2,e3) ->
+      (* propagation number 2 *)
+	let e1' = normalize_boolean ren env (propagate ren e1) in
+	if e2.post = None or e3.post = None then
+	  let top = label_name() in
+	  let ren' = push_date ren top in
+	  PPoint (top, If (e1', 
+			   propagate ren' (post_if_none_up env top q e2),
+			   propagate ren' (post_if_none_up env top q e3)))
+	else
+	  If (e1', propagate ren e2, propagate ren e3)
+    | Aff (x,e) ->
+      	Aff (x, propagate ren e)
+    | TabAcc (ch,x,e) ->
+      	TabAcc (ch, x, propagate ren e)
+    | TabAff (ch,x,({desc=Expression c} as e1),e2) ->
+	let p = Pmonad.make_pre_access ren env x c in
+	let e1' = add_pre [(anonymous_pre true p)] e1 in
+      	TabAff (false, x, propagate ren e1', propagate ren e2)
+    | TabAff (ch,x,e1,e2) ->
+      	TabAff (ch, x, propagate ren e1, propagate ren e2)
+    | Apply (f,l) ->
+      	Apply (propagate ren f, List.map (propagate_arg ren) l)
+    | SApp (f,l) ->
+	let l = 
+	  List.map (fun e -> normalize_boolean ren env (propagate ren e)) l
+	in
+      	SApp (f, l)
+    | Lam (bl,e) ->
+      	Lam (bl, propagate ren e)
+    | Seq bl ->
+	let top,bl = top_point_block bl in
+	let bl = post_last_statement env top q bl in
+      	Seq (propagate_block ren env bl)
+    | While (b,inv,var,bl) ->
+	let b = normalize_boolean ren env (propagate ren b) in
+	let lab,bl = top_point_block bl in
+	let bl = add_decreasing env inv var lab bl in
+      	While (b,inv,var,propagate_block ren env bl)
+    | LetRef (x,e1,e2) ->
+	let top = label_name() in
+	let ren' = push_date ren top in
+	PPoint (top, LetRef (x, propagate ren' e1, 
+	      		     propagate ren' (post_if_none_up env top q e2)))
+    | Let (x,e1,e2) ->
+	let top = label_name() in
+	let ren' = push_date ren top in
+      	PPoint (top, Let (x, propagate ren' e1, 
+			    propagate ren' (post_if_none_up env top q e2)))
+    | LetRec (f,bl,v,var,e) ->
+      	LetRec (f, bl, v, var, propagate ren e)
+    | PPoint (s,d) -> 
+      	PPoint (s, propagate_desc ren info d)
+    | Debug _ | Variable _ 
+    | Acc _ | Expression _ as d -> d
+	  
+
+(* [propagate] adds new annotations if possible *)
+and propagate ren p =
+  let env = p.info.env in
+  let p = match p.desc with
+    | 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
+	  post_if_none env q p
+	else
+	  p
+    | _ -> p
+  in
+  let d = propagate_desc ren p.info p.desc in
+  let p = change_desc p d in
+  match d with
+    | Aff (x,e) ->
+	let e1,p1 = extract_pre e in
+	change_desc (add_pre p1 p) (Aff (x,e1))
+
+    | TabAff (check, x, ({ desc = Expression _ } as e1), e2) ->
+	let e1',p1 = extract_pre e1 in
+	let e2',p2 = extract_pre e2 in
+	change_desc (add_pre (p1@p2) p) (TabAff (check,x,e1',e2'))
+
+    | While (b,inv,_,_) ->
+	let _,s = decomp_boolean b.post in
+	let s = make_before_after s in
+	let q = match inv with
+	    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
+	post_if_none env q p
+
+    | SApp ([Variable id], [e1;e2]) 
+      when id = connective_and or id = connective_or ->
+	let (_,_,_,q1) = e1.info.kappa
+	and (_,_,_,q2) = e2.info.kappa in
+	let (r1,s1) = decomp_boolean q1
+	and (r2,s2) = decomp_boolean q2 in
+	let q =
+	  let conn = if id = connective_and then "spec_and" else "spec_or" in
+	  let c = Term.applist (constant conn, [r1; s1; r2; s2]) in
+	  let c = Reduction.whd_betadeltaiota (Global.env()) c in
+	  create_bool_post c
+	in
+	let d = 
+	  SApp ([Variable id;
+                 Expression (out_post q1);
+                 Expression (out_post q2)], 
+		[e1; e2] ) 
+	in
+	post_if_none env q (change_desc p d)
+
+    | SApp ([Variable id], [e1]) when id = connective_not ->
+	let (_,_,_,q1) = e1.info.kappa in
+	let (r1,s1) = decomp_boolean q1 in
+	let q = 
+	  let c = Term.applist (constant "spec_not", [r1; s1]) in
+	  let c = Reduction.whd_betadeltaiota (Global.env ()) c in
+	  create_bool_post c 
+	in
+	let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in
+	post_if_none env q (change_desc p d)
+
+    | _ -> p
+
+and propagate_arg ren = function
+  | Type _ | Refarg _ as a -> a
+  | Term e -> Term (propagate ren e)
+
+
+and propagate_block ren env = function 
+  | [] -> 
+      []
+  | (Statement p) :: (Assert q) :: rem when annotation_candidate p ->
+      (* TODO: plutot p.post = None ? *)
+      let q' =
+	let ((id,v),_,_,_) = p.info.kappa in
+	let tv = Pmonad.trad_ml_type_v ren env v in
+	named_app (abstract [id,tv]) q
+      in
+      let p' = post_if_none env (Some q') p in
+      (Statement (propagate ren p')) :: (Assert q) 
+      :: (propagate_block ren env rem)
+  | (Statement p) :: rem ->
+      (Statement (propagate ren p)) :: (propagate_block ren env rem)
+  | (Label s as x) :: rem ->
+      x :: propagate_block (push_date ren s) env rem
+  | x :: rem ->
+      x :: propagate_block ren env rem
diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli
new file mode 100644
index 00000000..015031a0
--- /dev/null
+++ b/contrib/correctness/pwp.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: pwp.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *)
+
+open Term
+open Penv
+
+val update_post : local_env -> string -> Peffect.t -> constr -> constr
+
+val propagate : Prename.t -> typed_program -> typed_program
diff --git a/contrib/extraction/BUGS b/contrib/extraction/BUGS
new file mode 100644
index 00000000..7f3f59c1
--- /dev/null
+++ b/contrib/extraction/BUGS
@@ -0,0 +1,2 @@
+It's not a bug, it's a lack of feature !!
+Cf TODO.
diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES
new file mode 100644
index 00000000..83ea4910
--- /dev/null
+++ b/contrib/extraction/CHANGES
@@ -0,0 +1,409 @@
+7.4 -> 8.0
+
+No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, 
+but also a few steps toward a more user-friendly extraction:
+
+* syntax of extraction: 
+- The old   (Recursive) Extraction Module M.
+  is now    (Recursive) Extraction Library M.
+  The old name was misleading since this command only works with M being a 
+  library M.v, and not a module produced by interactive command Module M. 
+- The other commands 
+    Extraction foo.
+    Recursive Extraction foo bar.
+    Extraction "myfile.ml" foo bar. 
+  now accept that foo can be a module name instead of just a constant name. 
+
+* Support of type scheme axioms (i.e. axiom whose type is an arity 
+  (x1:X1)...(xn:Xn)s with s a sort). For example: 
+
+   Axiom myprod : Set -> Set -> Set.
+   Extract Constant myprod "'a" "'b" => "'a * 'b". 
+   Recursive Extraction myprod. 
+   -------> type ('a,'b) myprod = 'a * 'b		
+
+* More flexible support of axioms. When an axiom isn't realized via Extract 
+  Constant before extraction, a warning is produced (instead of an error), 
+  and the extracted code must be completed later by hand. To find what
+  needs to be completed, search for the following string: AXIOM TO BE REALIZED
+
+* Cosmetics: When extraction produces a file, it tells it. 
+
+* (Experimental) It is allowed to extract under a opened interactive module
+  (but still outside sections). Feature to be used with caution. 
+
+* A problem has been identified concerning .v files used as normal interactive 
+  modules, like in 
+    
+    <file A.v>
+    Definition foo :=O.
+    <End file A.v>
+
+    <at toplevel>
+    Require A.
+    Module M:=A
+    Extraction M.
+
+  I might try to support that in the future. In the meanwhile, the
+  current behaviour of extraction is to forbid this.
+
+* bug fixes: 
+- many concerning Records. 
+- a Stack Overflow with mutual inductive (PR#320)
+- some optimizations have been removed since they were not type-safe:
+  For example if e has type:  type 'x a = A
+  Then:       match e with A -> A     -----X---->    e
+  To be investigated further.
+
+
+7.3 -> 7.4
+
+* The two main new features: 
+  - Automatic generation of Obj.magic when the extracted code 
+  in Ocaml is not directly typable.
+  - An experimental extraction of Coq's new modules to Ocaml modules. 
+
+* Concerning those Obj.magic: 
+  - The extraction now computes the expected type of any terms. Then 
+  it compares it with the actual type of the produced code. And when 
+  a mismatch is found, a Obj.magic is inserted. 
+  
+  - As a rule, any extracted development that was compiling out of the box 
+  should not contain any Obj.magic. At the other hand, generation of 
+  Obj.magic is not optimized yet: there might be several of them at a place 
+  were one would have been enough. 
+  
+  - Examples of code needing those Obj.magic: 
+     * contrib/extraction/test_extraction.v in the Coq source
+     * in the users' contributions: 
+	Lannion
+	Lyon/CIRCUITS
+        Rocq/HIGMAN
+ 
+  - As a side-effect of this Obj.magic feature, we now print the types 
+  of the extracted terms, both in .ml files as commented documentation 
+  and in interfaces .mli files
+
+  - This feature hasn't been ported yet to Haskell. We are aware of 
+  some unsafe casting functions like "unsafeCoerce" on some Haskell implems.
+  So it will eventually be done.
+
+* Concerning the extraction of Coq's new modules: 
+  - Taking in account the new Coq's modules system has implied a *huge*
+  rewrite of most of the extraction code.
+
+  - The extraction core (translation from Coq to an abstract mini-ML) 
+  is now complete and fairly stable, and supports modules, modules type 
+  and functors and all that stuff.
+
+  - The ocaml pretty-print part, especially the renaming issue, is 
+  clearly weaker, and certainly still contains bugs. 
+
+  - Nothing done for translating these Coq Modules to Haskell.
+
+  - A temporary drawback of this module extraction implementation is that 
+  efficiency (especially extraction speed) has been somehow neglected.
+  To improve ...
+
+  - As an interesting side-effect, definitions are now printed according to 
+  the user's original order. No more of this "dependency-correct but weird"
+  order. In particular realized axioms via Extract Constant are now at their 
+  right place, and not at the beginning. 
+
+* Other news: 
+  
+  - Records are now printed using the Ocaml record syntax
+ 
+  - Syntax output toward Scheme. Quite funny, but quite experimental and 
+  not documented. I recommend using the bigloo compiler since it contains 
+  natively some pattern matching.
+
+  - the dummy constant "__" have changed. see README
+
+  - a few bug-fixes (#191 and others)
+
+7.2 -> 7.3
+
+* Improved documentation in the Reference Manual.
+
+* Theoretical bad news: 
+- a naughty example (see the end of test_extraction.v)
+forced me to stop eliminating lambdas and arguments corresponding to 
+so-called "arity" in the general case. 
+
+- The dummy constant used in extraction ( let prop = () in ocaml ) 
+may in some cases be applied to arguments. This problem is dealt by 
+generating sufficient abstraction before the (). 
+
+
+* Theoretical good news: 
+- there is now a mechanism that remove useless prop/arity lambdas at the 
+top of function declarations. If your function had signature 
+nat -> prop -> nat in the previous extraction, it will now be nat -> nat. 
+So the extractions of common terms should look very much like the old 
+V6.2 one, except in some particular cases (functions as parameters, partial 
+applications, etc). In particular the bad news above have nearly no 
+impact...
+
+
+* By the way there is no more "let prop = ()" in ocaml. Those () are
+directly inlined. And in Haskell the dummy constant is now __ (two
+underscore) and is defined by 
+__ = Prelude.error "Logical or arity value used"
+This dummy constant should never be evaluated when computing an
+informative value, thanks to the lazy strategy. Hence the error message. 
+
+
+* Syntax changes, see Documentation for details: 
+
+Extraction Language Ocaml.
+Extraction Language Haskell. 
+Extraction Language Toplevel.
+
+That fixes the target language of extraction. Default is Ocaml, even in the 
+coq toplevel: you can now do copy-paste from the coq toplevel without 
+renaming problems. Toplevel language is the ocaml pseudo-language used 
+previously used inside the coq toplevel: coq names are printed with the coq 
+way, i.e. with no renaming. 
+
+So there is no more particular commands for Haskell, like 
+Haskell Extraction "file" id. Just set your favourite language and go... 
+
+
+* Haskell extraction has been tested at last (and corrected...). 
+See specificities in Documentation. 
+
+
+* Extraction of CoInductive in Ocaml language is now correct: it uses the 
+Lazy.force and lazy features of Ocaml. 
+
+
+* Modular extraction in Ocaml is now far more readable: 
+instead of qualifying everywhere (A.foo), there are now some "open" at the 
+beginning of files. Possible clashes are dealt with. 
+
+
+* By default, any recursive function associated with an inductive type 
+(foo_rec and foo_rect when foo is inductive type) will now be inlined 
+in extracted code. 
+
+
+* A few constants are explicitely declared to be inlined in extracted code. 
+For the moment there are: 
+	Wf.Acc_rec
+	Wf.Acc_rect
+	Wf.well_founded_induction
+	Wf.well_founded_induction_type
+Those constants does not match the auto-inlining criterion based on strictness.
+Of course, you can still overide this behaviour via some Extraction NoInline. 
+
+* There is now a web page showing the extraction of all standard theories: 
+http://www.lri.fr/~letouzey/extraction
+
+
+7.1 -> 7.2 :
+
+* Syntax changes, see Documentation for more details: 
+
+Set/Unset Extraction Optimize. 
+
+Default is Set. This control all optimizations made on the ML terms 
+(mostly reduction of dummy beta/iota redexes, but also simplications on 
+Cases, etc). Put this option to Unset if you what a ML term as close as 
+possible to the Coq term.
+
+Set/Unset Extraction AutoInline. 
+
+Default in Set, so by default, the extraction mechanism feels free to 
+inline the bodies of some defined constants, according to some heuristics 
+like size of bodies, useness of some arguments, etc. Those heuristics are 
+not always perfect, you may want to disable this feature, do it by Unset. 
+
+Extraction Inline toto foo. 
+Extraction NoInline titi faa bor. 
+
+In addition to the automatic inline feature, you can now tell precisely to 
+inline some more constants by the Extraction Inline command. Conversely, 
+you can forbid the inlining of some specific constants by automatic inlining. 
+Those two commands enable a precise control of what is inlined and what is not. 
+
+Print Extraction Inline. 
+
+Sum up the current state of the table recording the custom inlings 
+(Extraction (No)Inline). 
+
+Reset Extraction Inline. 
+
+Put the table recording the custom inlings back to empty. 
+
+As a consequence, there is no more need for options inside the commands of 
+extraction: 
+
+Extraction foo. 
+Recursive Extraction foo bar. 
+Extraction "file" foo bar. 
+Extraction Module Mymodule. 
+Recursive Extraction Module Mymodule. 
+
+New: The last syntax extracts the module Mymodule and all the modules 
+it depends on. 
+
+You can also try the Haskell versions (not tested yet): 
+
+Haskell Extraction foo.
+Haskell Recursive Extraction foo bar.
+Haskell Extraction "file" foo bar.
+Haskell Extraction Module Mymodule.
+Haskell Recursive Extraction Module Mymodule.
+
+And there's still the realization syntax: 
+
+Extract Constant coq_bla => "caml_bla".
+Extract Inlined Constant coq_bla => "caml_bla".
+Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ].
+
+Note that now, the Extract Inlined Constant command is sugar for an Extract 
+Constant followed by a Extraction Inline. So be careful with 
+Reset Extraction Inline. 
+
+ 
+
+* Lot of works around optimization of produced code. Should make code more 
+readable. 
+
+- fixpoint definitions : there should be no more stupid printings like 
+
+let foo x = 
+  let rec f x = 
+    .... (f y) ....
+  in f x
+
+but rather 
+
+let rec foo x = 
+  .... (foo y) .... 
+
+- generalized iota (in particular iota and permutation cases/cases):
+
+A generalized iota redex is a "Cases e of ...." where e is ok. 
+And the recursive predicate "ok" is given by:  
+e is ok if e is a Constructor or a Cases where all branches are ok.
+In the case of generalized iota redex, it might be good idea to reduce it, 
+so we do it. 
+Example: 
+
+match (match t with 
+         O -> Left
+       | S n -> match n with 
+                  O -> Right 
+                | S m -> Left) with 
+ Left -> blabla 
+| Right -> bloblo
+
+After simplification, that gives: 
+
+match t with 
+  O -> blabla
+| S n -> match n with 
+          O -> bloblo
+        | S n -> blabla
+
+As shown on the example, code duplication can occur. In practice 
+it seems not to happen frequently. 
+
+- "constant" case:
+In V7.1 we used to simplify cases where all branches are the same. 
+In V7.2 we can simplify in addition terms like 
+	cases e of 
+	  C1 x y -> f (C x y)
+	| C2 z -> f (C2 z) 
+If x y z don't occur in f, we can produce (f e). 
+
+- permutation cases/fun: 
+extracted code has frequenty functions in branches of cases: 
+
+let foo x = match x with 
+   O -> fun _ -> .... 
+ | S y -> fun _ -> .... 
+
+the optimization consist in lifting the common "fun _ ->", and that gives
+ 
+let foo x _ = match x with 
+   O -> .....
+ | S y -> ....
+ 
+
+* Some bug corrections (many thanks in particular to Michel Levy). 
+
+* Testing in coq contributions: 
+If you are interested in extraction, you can look at the extraction tests 
+I'have put in the following coq contributions 
+
+Bordeaux/Additions			computation of fibonacci(2000)
+Bordeaux/EXCEPTIONS			multiplication using exception.
+Bordeaux/SearchTrees			list -> binary tree. maximum.
+Dyade/BDDS				boolean tautology checker.
+Lyon/CIRCUITS				multiplication via a modelization of a circuit.
+Lyon/FIRING-SQUAD			print the states of the firing squad.
+Marseille/CIRCUITS			compares integers via a modelization of a circuit. 
+Nancy/FOUnify				unification of two first-orderde deux termes.
+Rocq/ARITH/Chinese			computation of the chinese remaindering.  
+Rocq/COC				small coc typechecker. (test by B. Barras, not by me)
+Rocq/HIGMAN				run the proof on one example. 
+Rocq/GRAPHS				linear constraints checker in Z. 
+Sophia-Antipolis/Stalmarck		boolean tautology checker.
+Suresnes/BDD				boolean tautology checker.
+
+Just do "make" in those contributions, the extraction test is integrated. 
+More tests will follow on more contributions.
+
+
+
+7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with.
+
+* The semantics of Extract Constant changed: If you provide a extraction 
+for p by Extract Constant p => "0", your generated ML file will begin by 
+a let p = 0. The old semantics, which was to replace p everywhere by the
+provided terms, is still available via the Extract Inlined Constant p => 
+"0" syntax.
+
+
+* There are more optimizations applied to the generated code: 
+- identity cases: match e with P x y -> P x y | Q z -> Q z | ...
+is simplified into e. Especially interesting with the sumbool terms: 
+there will be no more match ... with Left -> Left | Right -> Right
+
+- constant cases: match e with P x y -> c | Q z -> c | ...
+is simplified into c as soon as x, y, z do not occur in c.
+So no more match ... with Left -> Left | Right -> Left.
+  
+
+* the extraction at Toplevel (Extraction foo and Recursive Extraction foo),
+which was only a development tool at the beginning, is now closer to 
+the real extraction to a file. In particular optimizations are done, 
+and constants like recursors ( ..._rec ) are expanded. 
+
+
+* the singleton optimization is now protected against circular type.
+( Remind : this optimization is the one that simplify 
+type 'a sig = Exists of 'a  into type 'a sig = 'a and 
+match e with (Exists c) -> d into let c = e in d ) 
+
+
+* Fixed one bug concerning casted code
+
+
+* The inductives generated should now have always correct type-var list 
+('a,'b,'c...)
+
+
+* Code cleanup until three days before release. Messing-up code 
+in the last three days before release.
+
+
+
+
+
+
+
+6.x -> 7.0 : Everything changed. See README
diff --git a/contrib/extraction/README b/contrib/extraction/README
new file mode 100644
index 00000000..7350365e
--- /dev/null
+++ b/contrib/extraction/README
@@ -0,0 +1,139 @@
+
+Status of Extraction in Coq version 7.x
+======================================
+
+(* 22 jan 2003 : Updated for version 7.4 *)
+
+
+J.C. Filliâtre
+P. Letouzey
+
+
+
+Extraction code has been completely rewritten since version V6.3. 
+This work is still not finished, but most parts of it are already usable. 
+In consequence it is included in the Coq V7.0 final release. 
+But don't be mistaken: 
+
+	THIS WORK IS STILL EXPERIMENTAL !
+
+1) Principles 
+
+The main goal of the new extraction is to handle any Coq term, even 
+those upon sort Type, and to produce code that always compiles. 
+Thus it will never answer something like "Not an ML type", but rather
+a dummy term like the ML unit. 
+
+Translation between Coq and ML is based upon the following principles: 
+
+- Terms of sort Prop don't have any computational meaning, so they are
+merged into one ML term "__". This part is done according to P. Letouzey's 
+works (*) and (**).
+
+This dummy constant "__" used to be implemented by the unit (), but 
+we recently found that this constant might be applied in some cases. 
+So "__" is now in Ocaml a fixpoint that forgets its arguments: 
+
+           let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+
+- Terms that are type schemes (i.e. something of type ( : )( : )...s with 
+s a sort ) don't have any ML counterpart at the term level, since they 
+are types transformers. In fact they do not have any computational
+meaning either. So we also merge them into that dummy term "__".
+
+- A Coq term gives a ML term or a ML type depending of its type: 
+type schemes will (try to) give ML types, and all other terms give ML terms.
+
+And the rest of the translation is (almost) straightforward: an inductive
+gives an inductive, etc...
+
+This gives ML code that have no special reason to typecheck, due 
+to the incompatibilities between Coq and ML typing systems. In fact
+most of the time everything goes right. For example, it is sufficient 
+to extract and compile everything in the "theories" directory 
+(cf test subdirectory).
+
+We now verify during extraction that the produced code is typecheckable, 
+and if it is not we insert unsafe type casting at critical points in the 
+code. For the moment, it is an Ocaml-only feature, using the "Obj.magic"
+function, but the same kind of trick will be soon made in Haskell.
+
+
+2) Differences with previous extraction (V6.3 and before)
+
+2.a) The pros 
+
+The ability to extract every Coq term, as explain in the previous 
+paragraph. 
+
+The ability to extract from a file an ML module (cf Extraction Module in the 
+documentation)
+
+You can have a taste of extraction directly at the toplevel by 
+using the "Extraction <ident>" or the "Recursive Extraction <ident>".
+This toplevel extraction was already there in V6.3, but was printing 
+Fw terms. It now prints in the language of your choice: 
+Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. 
+
+The optimization done on extracted code has been ported between 
+V6.3 and V7 and enhanced, and in particular the mechanism of automatic
+expansion. 
+
+2.b) The cons 
+
+The presence of some parasite "__" as dummy arguments
+in functions. This denotes the rests of a proof part. The previous 
+extraction was able to remove them totally. The current implementation
+removes a good deal of them (more that in 7.0), but not all. 
+
+This problem is due to extraction upon Type.
+For example, let's take this pathological term: 
+	(if b then Set else Prop)  : Type
+The only way to know if this is an Set (to keep) or a Prop (to remove) 
+is to compute the boolean b, and we do not want to do that during 
+extraction. 
+
+There is no more "ML import" feature. You can compensate by using 
+Axioms, and then "Extract Constant ..." 
+
+3) Examples 
+
+The file "test-extraction.v" is made of some examples used while debugging.
+
+In the subdirectory "test", you can test extraction on the Coq theories.
+Go there.
+"make tree" to make a local copy of the "theories" tree
+"make" to extract & compile most of the theories file in Ocaml
+"make -f Makefile.haskell" to extract & compile in Haskell
+
+See also Reference Manual for explanation of extraction syntaxes
+and more examples. 
+
+
+(*):
+Exécution de termes de preuves: une nouvelle méthode d'extraction 
+pour le Calcul des Constructions Inductives, Pierre Letouzey,
+DEA thesis, 2000, 
+http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz
+
+(**) 
+A New Extraction for Coq, Pierre Letouzey, 
+Types 2002 Post-Workshop Proceedings, to appear, 
+draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz
+
+
+Any feedback is welcome: 
+Pierre.Letouzey@lri.fr
+Jean.Christophe.Filliatre@lri.fr
+
+
+
+
+
+
+
+
+
+
+
diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO
new file mode 100644
index 00000000..174be06e
--- /dev/null
+++ b/contrib/extraction/TODO
@@ -0,0 +1,31 @@
+
+ 16. Haskell : 
+     - equivalent of Obj.magic (unsafeCoerce ?) 
+     - look again at the syntax (make it independant of layout ...)  
+     - producing .hi files
+     - modules/modules types/functors in Haskell ?
+
+ 17. Scheme : 
+     - modular Scheme ? 
+
+ 18. Improve speed (profiling)
+
+ 19. Look again at those hugly renamings functions. 
+     Especially get rid of ML clashes like 
+   
+    let t = 0
+    module M = struct 
+       let t = 1 
+       let u = The.External.t (* ?? *)
+    end
+
+ 20. Support the .v-as-internal-module, like in 
+    
+    <file A.v>
+    Definition foo :=O.
+    <End file A.v>
+
+    <at toplevel>
+    Require A.
+    Module M:=A
+    Extraction M.
\ No newline at end of file
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
new file mode 100644
index 00000000..53a2631e
--- /dev/null
+++ b/contrib/extraction/common.ml
@@ -0,0 +1,441 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: common.ml,v 1.51.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Declarations
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Modutil
+open Ocaml
+
+(*S Renamings. *)
+
+(*s Tables of global renamings *)
+
+let keywords = ref Idset.empty
+let global_ids = ref Idset.empty
+let modular = ref false
+
+(* For each [global_reference], this table will contain the different parts 
+   of its renamings, in [string list] form. *)
+let renamings = Hashtbl.create 97
+let rename r l = Hashtbl.add renamings r l
+let get_renamings r = Hashtbl.find renamings r 
+
+(* Idem for [module_path]. *)
+let mp_renamings = Hashtbl.create 97
+let mp_rename mp l = Hashtbl.add mp_renamings mp l
+let mp_get_renamings mp = Hashtbl.find mp_renamings mp 
+
+let modvisited = ref MPset.empty
+let modcontents = ref Gset.empty
+let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents
+let module_contents mp s = Gset.mem (mp,s) !modcontents
+
+let to_qualify = ref Refset.empty
+
+let mod_1st_level = ref Idmap.empty
+
+(*s Uppercase/lowercase renamings. *) 
+
+let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+
+let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+(* This function creates from [id] a correct uppercase/lowercase identifier. 
+   This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes 
+   with previous [Coq_id] variable, these prefixes are duplicated if already 
+   existing. *)
+
+let modular_rename up id = 
+  let s = string_of_id id in
+  let prefix = if up then "Coq_" else "coq_" in 
+  let check = if up then is_upper else is_lower in 
+  if not (check s) ||
+    (Idset.mem id !keywords) ||
+    (String.length s >= 4 && String.sub s 0 4 = prefix) 
+  then prefix ^ s
+  else s
+
+let rename_module = modular_rename true 
+
+(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when 
+   [mpl] is the context of visible modules. More precisely, we check if 
+   there exists a mp1, module (sub-)path of an element of [mpl], such as 
+   module [mp1-l] contains [s]. 
+   The verification stops if we encounter [mp1=mp0]. *)
+
+exception Stop 
+
+let clash mp0 l s mpl = 
+  let rec clash_one mp = match mp with
+    | _ when mp = mp0 -> raise Stop
+    | MPdot (mp',_) -> 
+	(module_contents (add_labels_mp mp l) s) || (clash_one mp') 
+    | mp when is_toplevel mp -> false
+    | _ -> module_contents (add_labels_mp mp l) s
+  in
+  let rec clash_list = function 
+    | [] -> false
+    | mp :: mpl -> (clash_one mp) || (clash_list mpl) 
+  in try clash_list mpl with Stop -> false
+
+(*s [contents_first_level mp] finds the names of the first-level objects 
+  exported by module [mp]. Nota: it might fail if [mp] isn't a directly 
+  visible module. Ex: [MPself] under functor, [MPbound], etc ... *)
+
+let contents_first_level mp = 
+  if not (MPset.mem mp !modvisited) then begin 
+    modvisited := MPset.add mp !modvisited; 
+    match (Global.lookup_module mp).mod_type with 
+      | MTBsig (msid,msb) -> 
+	  let add b id = add_module_contents mp (modular_rename b id) in 
+	  let upper_type = (lang () = Haskell) in
+	  List.iter 
+	    (function 
+	       | (l, SPBconst cb) -> 
+		   (match Extraction.constant_kind (Global.env ()) cb with 
+		      | Extraction.Logical -> () 
+		      | Extraction.Type -> add upper_type (id_of_label l)
+		      | Extraction.Term -> add false (id_of_label l))
+	       | (_, SPBmind mib) ->
+		   Array.iter 
+		     (fun mip -> if mip.mind_sort <> (Prop Null) then begin
+			add upper_type mip.mind_typename; 
+			Array.iter (add true) mip.mind_consnames
+		      end)
+		     mib.mind_packets
+	       | _ -> ())
+	    (Modops.subst_signature_msid msid mp msb)
+      | _ -> ()
+  end
+
+(*s Initial renamings creation, for modular extraction. *) 
+
+let rec mp_create_modular_renamings mp = 
+  try mp_get_renamings mp 
+  with Not_found -> 
+    let ren = match mp with 
+      | MPdot (mp,l) -> 
+	  (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp)
+      | MPself msid -> [rename_module (id_of_msid msid)]
+      | MPbound mbid -> [rename_module (id_of_mbid mbid)]
+      | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))]
+    in mp_rename mp ren; ren
+
+
+let create_modular_renamings struc = 
+  let current_module = fst (List.hd struc) in 
+  let modfiles = ref MPset.empty in 
+  let { up = u ; down = d } = struct_get_references_set struc 
+  in 
+  (* 1) creates renamings of objects *)
+  let add upper r = 
+    let mp = modpath (kn_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;    
+    rename r (s::l); 
+    begin try 
+      let mp = modfile_of_mp mp in 
+      if mp <> current_module then modfiles := MPset.add mp !modfiles
+    with Not_found -> () 
+    end; 
+  in
+  Refset.iter (add true) u; 
+  Refset.iter (add false) d; 
+  
+  (* 2) determines the opened libraries. *)
+  let used_modules = MPset.elements !modfiles in 
+
+  (* [s] will contain all first-level sub-modules of [cur_mp] *)
+  let s = ref Stringset.empty in 
+  begin 
+    let add l = s := Stringset.add (rename_module (id_of_label l)) !s in 
+    match (Global.lookup_module current_module).mod_type with 
+      | MTBsig (_,msb) ->
+	  List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb
+      | _ -> ()
+  end;
+  (* We now compare [s] with the modules coming from [used_modules]. *)
+  List.iter 
+    (function 
+       | MPfile d -> 
+	   let s_mp = 
+	     String.capitalize (string_of_id (List.hd (repr_dirpath d))) in 
+	   if Stringset.mem s_mp !s then error_module_clash s_mp 
+	   else s:= Stringset.add s_mp !s 
+       | _ -> assert false)
+    used_modules;
+
+  (* 3) determines the potential clashes *)
+  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 
+    if (is_modfile mp) && mp <> current_module && 
+      (clash mp [] (List.hd (get_renamings r)) used_modules')
+    then to_qualify := Refset.add r !to_qualify
+  in
+  Refset.iter needs_qualify u;
+  Refset.iter needs_qualify d; 
+  used_modules
+
+(*s Initial renamings creation, for monolithic extraction. *)
+
+let begins_with_CoqXX s = 
+  (String.length s >= 4) && 
+  (String.sub s 0 3 = "Coq") &&
+  (try 
+     for i = 4 to (String.index s '_')-1 do 
+       match s.[i] with 
+	 | '0'..'9' -> () 
+	 | _ -> raise Not_found
+     done; 
+     true
+   with Not_found -> false)
+
+let mod_1st_level_rename l =
+  let coqid = id_of_string "Coq" in 
+  let id = id_of_label l in 
+  try 
+    let coqset = Idmap.find id !mod_1st_level in 
+    let nextcoq = next_ident_away coqid coqset in 
+    mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level; 
+    (string_of_id nextcoq)^"_"^(string_of_id id) 
+  with Not_found -> 
+    let s = string_of_id id in 
+    if is_lower s || begins_with_CoqXX s then
+      (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s)
+    else
+      (mod_1st_level := Idmap.add id [] !mod_1st_level; s)
+
+let rec mp_create_mono_renamings mp = 
+  try mp_get_renamings mp 
+  with Not_found -> 
+    let ren = match mp with 
+       | _ when (at_toplevel mp) -> [""]
+       | MPdot (mp,l) -> 
+	   let lmp = mp_create_mono_renamings mp in
+	   if lmp = [""] then (mod_1st_level_rename l)::lmp
+	   else (rename_module (id_of_label l))::lmp
+       | MPself msid -> [rename_module (id_of_msid msid)]
+       | MPbound mbid -> [rename_module (id_of_mbid mbid)]
+       | _ -> assert false
+    in mp_rename mp ren; ren
+
+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 l = mp_create_mono_renamings mp in
+    let mycase = if upper then uppercase_id else lowercase_id in 
+    let id = 
+      if l = [""] then 
+	next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids)
+      else id_of_string (modular_rename upper (id_of_global r))
+    in 
+    global_ids := Idset.add id !global_ids;    
+    rename r ((string_of_id id)::l) 
+  in
+  List.iter (add true) (List.rev u); 
+  List.iter (add false) (List.rev d)
+		    
+(*s Renaming issues at toplevel *)
+
+module TopParams = struct
+  let globals () = Idset.empty
+  let pp_global _ r = pr_id (id_of_global r)
+  let pp_module _ mp = str (string_of_mp mp)
+end
+
+(*s Renaming issues for a monolithic or modular extraction. *)
+
+module StdParams = struct
+
+  let globals () = !global_ids
+
+  (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *)
+
+  let rec dottify = function 
+    | [] -> assert false 
+    | [s] -> s 
+    | s::[""] -> s 
+    | s::l -> (dottify l)^"."^s
+
+  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 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
+    in 
+    add_module_contents mp s; (* update the visible environment *)
+    str (dottify ls)
+
+  let pp_module mpl mp = 
+    let ls = 
+      if !modular 
+      then mp_create_modular_renamings mp 
+      else mp_create_mono_renamings mp 
+    in 
+    let ls = 
+      try (* has [mp] something in common with one of those in [mpl] ? *)
+	let pref = common_prefix_from_list mp mpl in 
+	(*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
+    in str (dottify ls) 
+
+end
+
+module ToplevelPp = Ocaml.Make(TopParams)
+module OcamlPp = Ocaml.Make(StdParams)
+module HaskellPp = Haskell.Make(StdParams)
+module SchemePp = Scheme.Make(StdParams)
+
+let pp_decl mp d = match lang () with 
+  | Ocaml -> OcamlPp.pp_decl mp d 
+  | Haskell -> HaskellPp.pp_decl mp d
+  | Scheme -> SchemePp.pp_decl mp d 
+  | Toplevel -> ToplevelPp.pp_decl mp d 
+
+let pp_struct s = match lang () with 
+  | Ocaml -> OcamlPp.pp_struct s 
+  | Haskell -> HaskellPp.pp_struct s
+  | Scheme -> SchemePp.pp_struct s
+  | Toplevel -> ToplevelPp.pp_struct s
+
+let pp_signature s = match lang () with 
+  | Ocaml -> OcamlPp.pp_signature s 
+  | Haskell -> HaskellPp.pp_signature s
+  | _ -> assert false
+
+let set_keywords () =
+  (match lang () with 
+    | Ocaml -> keywords := Ocaml.keywords
+    | Haskell -> keywords := Haskell.keywords
+    | Scheme -> keywords := Scheme.keywords
+    | Toplevel -> keywords := Idset.empty);
+  global_ids := !keywords; 
+  to_qualify := Refset.empty
+    
+let preamble prm = match lang () with 
+  | Ocaml -> Ocaml.preamble prm   
+  | Haskell -> Haskell.preamble prm
+  | Scheme -> Scheme.preamble prm
+  | Toplevel -> (fun _ _ -> mt ())
+
+let preamble_sig prm = match lang () with 
+  | Ocaml -> Ocaml.preamble_sig prm   
+  | _ -> assert false
+
+(*S Extraction of one decl to stdout. *)
+
+let print_one_decl struc mp decl = 
+  set_keywords (); 
+  modular := false; 
+  create_mono_renamings struc;
+  msgnl (pp_decl [mp] decl)
+
+(*S Extraction to a file. *)
+
+let info f = 
+  Options.if_verbose msgnl 
+    (str ("The file "^f^" has been created by extraction."))
+
+let print_structure_to_file f prm struc =
+  cons_cofix := Refset.empty;
+  Hashtbl.clear renamings;
+  mod_1st_level := Idmap.empty; 
+  modcontents := Gset.empty;
+  modvisited := MPset.empty; 
+  set_keywords ();
+  modular := prm.modular; 
+  let used_modules =
+    if lang () = Toplevel then []
+    else if prm.modular then create_modular_renamings struc
+    else (create_mono_renamings struc; [])
+  in 
+  let print_dummys =
+    (struct_ast_search MLdummy struc, 
+     struct_type_search Tdummy struc, 
+     struct_type_search Tunknown struc)
+  in
+  (* print the implementation *)
+  let cout = option_app (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 
+  begin try 
+    msg_with ft (preamble prm used_modules print_dummys);
+    msg_with ft (pp_struct struc);
+    option_iter close_out cout; 
+  with e -> 
+    option_iter close_out cout; raise e
+  end;
+  option_iter (fun (f,_) -> info f) f;
+  (* print the signature *)
+  match f with 
+    | Some (_,f) when lang () = Ocaml -> 
+	let cout = open_out f in
+	let ft = Pp_control.with_output_to cout in
+	begin try 
+	  msg_with ft (preamble_sig prm used_modules print_dummys);
+	  msg_with ft (pp_signature (signature_of_structure struc));
+	  close_out cout;
+	with e -> 
+	  close_out cout; raise e 
+	end; 
+	info f 
+    | _ -> ()
+	  
+
+(*i 
+  (* DO NOT REMOVE: used when making names resolution *)
+  let cout = open_out (f^".ren") in 
+  let ft = Pp_control.with_output_to cout in
+  Hashtbl.iter 
+    (fun r id -> 
+       if short_module r = !current_module then 
+	 msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r)))
+    renamings;
+  pp_flush_with ft ();
+  close_out cout;
+i*)    
+
+
+
+
+
+
+
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
new file mode 100644
index 00000000..3e5efa0c
--- /dev/null
+++ b/contrib/extraction/common.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: common.mli,v 1.19.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Names
+open Miniml
+open Mlutil
+
+val print_one_decl :
+  ml_structure -> module_path -> ml_decl -> unit
+
+val print_structure_to_file : 
+  (string * string) option -> extraction_params -> ml_structure -> unit
+
+
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
new file mode 100644
index 00000000..d725a1d7
--- /dev/null
+++ b/contrib/extraction/extract_env.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 $Id: extract_env.ml,v 1.74.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+open Term
+open Declarations
+open Names
+open Libnames
+open Pp
+open Util
+open Miniml
+open Table
+open Extraction
+open Modutil
+open Common
+
+(*s Obtaining Coq environment. *)
+
+let toplevel_env () = 
+  let seg = Lib.contents_after None in 
+  let get_reference = function 
+    | (_,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)
+	  | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) 
+	  | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l)))
+	  | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn)
+	  | _ -> failwith "caught"
+	in l,seb
+    | _ -> failwith "caught"
+  in 
+  match current_toplevel () with 
+    | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg))
+    | _ -> assert false
+
+let environment_until dir_opt = 
+  let rec parse = function 
+    | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
+    | [] -> [] 
+    | d :: l -> 
+	match (Global.lookup_module (MPfile d)).mod_expr with 
+	  | Some meb -> 
+	      if dir_opt = Some d then [MPfile d, meb]
+	      else (MPfile d, meb) :: (parse l)
+	  | _ -> 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) 
+
+exception Impossible
+
+let check_arity env cb = 
+  if Reduction.is_arity env cb.const_type then raise Impossible
+
+let check_fix env cb i = 
+  match cb.const_body with 
+    | None -> raise Impossible
+    | Some lbody -> 
+	match kind_of_term (Declarations.force lbody) with 
+	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
+	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
+	  | _ -> raise Impossible
+
+let factor_fix env l cb msb = 
+  let _,recd as check = check_fix env cb 0 in 
+  let n = Array.length (let fi,_,_ = recd in fi) in
+  if n = 1 then [|l|], recd, msb
+  else begin 
+    if List.length msb < n-1 then raise Impossible; 
+    let msb', msb'' = list_chop (n-1) msb in 
+    let labels = Array.make n l in 
+    list_iter_i 
+      (fun j -> 
+	 function 
+	   | (l,SEBconst cb') -> 
+	       if check <> check_fix env cb' (j+1) then raise Impossible; 
+	       labels.(j+1) <- l; 
+	   | _ -> raise Impossible) 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 
+  | [] -> [] 
+  | (l,SPBconst cb) :: msig -> 
+      let kn = make_kn 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
+      else begin
+	get_spec_references v s; 
+	(l,Spec s) :: (extract_msig env v 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
+      else begin 
+	get_spec_references v s; 
+	(l,Spec s) :: (extract_msig env v 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,SPBmodtype mtb) :: msig -> 
+      (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig)
+
+and extract_mtb env v mpo = function 
+  | MTBident kn -> visit_kn v 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') 
+  | 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) 
+
+let rec extract_msb env v 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 
+	 if all || b then 
+	   let d = extract_fixpoint env vkn recd in 
+	   if (not b) && (logical_decl d) then ms 
+	   else begin get_decl_references v 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 
+	 if all || b then 
+	   let d = extract_constant env kn cb in
+	   if (not b) && (logical_decl d) then ms 
+	   else begin get_decl_references v d; (l,SEdecl d) :: ms end
+	 else ms)
+  | (l,SEBmind mib) :: msb ->
+      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 
+      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 ms
+  | (l,SEBmodule mb) :: msb -> 
+      let ms = extract_msb env v 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
+      else ms
+  | (l,SEBmodtype mtb) :: msb ->
+      let ms = extract_msb env v 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
+      else ms
+
+and extract_meb env v mpo all = function 
+  | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
+  | MEBident mp -> visit_mp v mp; MEident mp 
+  | MEBapply (meb, meb',_) -> 
+      MEapply (extract_meb env v None true meb, 
+	       extract_meb env v 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)
+  | 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) 
+
+and extract_module env v 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
+  let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in
+  (* 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 }
+
+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 
+  let env = Global.env () in 
+  List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) 
+    (List.rev 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. *)
+
+let mono_extraction (f,m) qualids = 
+  check_inside_section (); 
+  check_inside_module ();
+  let rec find = function 
+    | [] -> [],[]
+    | q::l -> 
+	let refs,mps = find l in 
+	try 
+	  let mp = Nametab.locate_module (snd (qualid_of_reference q))
+	  in refs,(mp::mps)
+	with Not_found -> (Nametab.global q)::refs, mps 
+  in 	    
+  let refs,mps = find qualids in
+  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; 
+  reset_tables ()
+
+let extraction_rec = mono_extraction (None,id_of_string "Main")
+
+(*s Extraction in the Coq toplevel. We display the extracted term in
+    Ocaml syntax and we use the Coq printers for globals. The
+    vernacular command is \verb!Extraction! [qualid]. *)
+
+let extraction qid = 
+  check_inside_section (); 
+  check_inside_module ();
+  try 
+    let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in 
+    extraction_rec [qid]
+  with Not_found -> 
+    let r = Nametab.global qid in 
+    if is_custom r then
+      msgnl (str "User defined extraction:" ++ spc () ++ 
+	     str (find_custom r) ++ fnl ()) 
+    else begin 
+      let prm = 
+	{ modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in 
+      let kn = kn_of_r 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
+
+(*s Extraction to a file (necessarily recursive). 
+    The vernacular command is 
+    \verb!Extraction "file"! [qualid1] ... [qualidn].*)
+
+let lang_suffix () = match lang () with 
+  | Ocaml -> ".ml",".mli"
+  | Haskell -> ".hs",".hi"
+  | Scheme -> ".scm",".scm"
+  | Toplevel -> assert false
+
+let filename f = 
+  let s,s' = lang_suffix () in
+  if Filename.check_suffix f s then 
+    let f' = Filename.chop_suffix f s in 
+    Some (f,f'^s'),id_of_string f' 
+  else Some (f^s,f^s'),id_of_string f
+
+let extraction_file f vl =
+  if lang () = Toplevel then error_toplevel () 
+  else mono_extraction (filename f) vl
+
+(*s Extraction of a module at the toplevel. *)
+
+let extraction_module m = 
+  check_inside_section (); 
+  check_inside_module ();
+  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 ()
+
+(*s (Recursive) Extraction of a library. The vernacular command is 
+  \verb!(Recursive) Extraction Library! [M]. *) 
+
+let module_file_name m = match lang () with 
+  | Ocaml -> let f = String.uncapitalize (string_of_id m) in  f^".ml", f^".mli"
+  | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi"
+  | _ -> assert false
+
+let dir_module_of_id m = 
+  let q = make_short_qualid m in 
+  try Nametab.full_name_module q with Not_found -> error_unknown_module q
+
+let extraction_library is_rec m =
+  check_inside_section (); 
+  check_inside_module ();  
+  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 ()
+
+
+
+
+
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
new file mode 100644
index 00000000..8ce64342
--- /dev/null
+++ b/contrib/extraction/extract_env.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: extract_env.mli,v 1.13.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*s This module declares the extraction commands. *)
+
+open Names
+open Libnames
+
+val extraction : reference -> unit
+val extraction_rec : reference list -> unit
+val extraction_file : string -> reference list -> unit
+val extraction_module : reference -> unit
+val extraction_library : bool -> identifier -> unit
diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
new file mode 100644
index 00000000..46bf06dd
--- /dev/null
+++ b/contrib/extraction/extraction.ml
@@ -0,0 +1,855 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: extraction.ml,v 1.136.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Declarations
+open Environ
+open Reduction
+open Reductionops
+open Inductive
+open Termops
+open Inductiveops
+open Recordops
+open Nameops
+open Summary
+open Libnames
+open Nametab
+open Miniml
+open Table
+open Mlutil
+(*i*)
+
+exception I of inductive_info
+
+(* A set of all inductive currently being computed, 
+   to avoid loops in [extract_inductive] *)
+let internal_call = ref KNset.empty
+
+let none = Evd.empty
+
+let type_of env c = Retyping.get_type_of env none (strip_outer_cast c)
+
+let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c)
+
+let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
+
+(*S Generation of flags and signatures. *)
+
+(* The type [flag] gives us information about any Coq term: 
+   \begin{itemize}
+   \item [TypeScheme] denotes a type scheme, that is 
+     something that will become a type after enough applications. 
+     More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with 
+     [s = Set], [Prop] or [Type] 
+   \item [Default] denotes the other cases. It may be inexact after 
+     instanciation. For example [(X:Type)X] is [Default] and may give [Set]
+     after instanciation, which is rather [TypeScheme]
+   \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
+   \item [Info] is the opposite. The same example [(X:Type)X] shows 
+     that an [Info] term might in fact be [Logic] later on. 
+   \end{itemize} *)
+
+type info = Logic | Info
+
+type scheme = TypeScheme | Default
+
+type flag = info * scheme
+
+(*s [flag_of_type] transforms a type [t] into a [flag]. 
+  Really important function. *)
+
+let rec flag_of_type env t = 
+  let t = whd_betadeltaiota env none t in 
+  match kind_of_term t with
+    | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
+    | Sort (Prop Null) -> (Logic,TypeScheme)
+    | Sort _ -> (Info,TypeScheme)
+    | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
+
+(*s Two particular cases of [flag_of_type]. *)
+
+let is_default env t = (flag_of_type env t = (Info, Default))
+
+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. *)
+
+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)
+    | _ -> []
+
+let rec type_scheme_nb_args env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) -> 
+	let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in 
+	if is_info_scheme env t then n+1 else n
+    | _ -> 0
+
+let _ = register_type_scheme_nb_args type_scheme_nb_args
+
+(*s [type_sign_vl] does the same, plus a type var list. *)
+
+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
+    | _ -> [],[]
+
+let rec nb_default_params env c = 
+  match kind_of_term (whd_betadeltaiota env none c) with
+    | Prod (n,t,d) ->
+	let n = nb_default_params (push_rel_assum (n,t) env) d in 
+	if is_default env t then n+1 else n
+    | _ -> 0
+
+(*S Management of type variable contexts. *)
+
+(* A De Bruijn variable context (db) is a context for translating Coq [Rel]  
+   into ML type [Tvar]. *)
+
+(*s From a type signature toward a type variable context (db). *)
+
+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
+  in make 1 [] s
+
+(*s Create a type variable context from indications taken from 
+  an inductive type (see just below). *) 
+
+let rec db_from_ind dbmap i = 
+  if i = 0 then []
+  else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
+
+(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument 
+  of a constructor corresponds to the j-th type var of the ML inductive. *)
+
+(* \begin{itemize}
+   \item [si] : signature of the inductive
+   \item [i] :  counter of Coq args for [(I args)] 
+   \item [j] : counter of ML type vars 
+   \item [relmax] : total args number of the constructor 
+   \end{itemize} *)
+
+let parse_ind_args si args relmax = 
+  let rec parse i j = function 
+    | [] -> Intmap.empty
+    | false :: s -> parse (i+1) j s
+    | true :: 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)
+  in parse 1 1 si 
+
+(*S Extraction of a type. *)
+
+(* [extract_type env db c args] is used to produce an ML type from the 
+   coq term [(c args)], which is supposed to be a Coq type. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+(* [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') ->
+	(* We just accumulate the arguments. *)
+	extract_type env db j d (Array.to_list args' @ args)
+    | Lambda (_,_,d) -> 
+	(match args with 
+	   | [] -> assert false (* otherwise the lambda would be reductible. *)
+	   | a :: args -> extract_type env db j (subst1 a d) args)
+    | Prod (n,t,d) ->
+	assert (args = []); 
+	let env' = push_rel_assum (n,t) env in 
+	(match flag_of_type env t with 
+	   | (Info, Default) -> 
+	       (* Standard case: two [extract_type] ... *)
+	       let mld = extract_type env' (0::db) j d [] in 
+	       if mld = Tdummy then Tdummy 
+	       else 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 mld = Tdummy then Tdummy else Tarr (Tdummy, mld)
+	   | _ -> 
+	       let mld = extract_type env' (0::db) j d [] in 
+	       if mld = Tdummy then Tdummy else Tarr (Tdummy, mld))
+    | Sort _ -> Tdummy (* The two logical cases. *)
+    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy 
+    | Rel n -> 
+	(match lookup_rel n env with
+           | (_,Some t,_) -> extract_type env db j (lift n t) args
+	   | _ -> 
+	       (* Asks [db] a translation for [n]. *)
+	       if n > List.length db then Tunknown 
+	       else let n' = List.nth db (n-1) in 
+	       if n' = 0 then Tunknown else Tvar n')
+    | Const kn -> 
+	let r = ConstRef kn in 
+	let cb = lookup_constant kn env in 
+	let typ = 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 
+	       (match cb.const_body with 
+		  | None -> mlt
+		  | Some _ when is_custom r -> mlt 
+		  | Some lbody -> 
+		      let newc = applist (Declarations.force lbody, args) in 
+		      let mlt' = extract_type env db j newc [] in 
+		      (* ML type abbreviations interact badly with Coq *)
+		      (* reduction, so [mlt] and [mlt'] might be different: *)
+		      (* 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')
+	   | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
+	       (match cb.const_body with 
+		  | None -> Tunknown (* Brutal approximation ... *)
+		  | Some lbody -> 
+		      (* We try to reduce. *)
+		      let newc = applist (Declarations.force lbody, args) in 
+		      extract_type env db j newc []))
+    | Ind ((kn,i) as ip) ->
+	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
+    | _ -> assert false
+
+(* [extract_maybe_type] calls [extract_type] when used on a Coq type, 
+   and otherwise returns [Tdummy] or [Tunknown] *)
+
+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
+
+(*s Auxiliary function dealing with type application. 
+  Precondition: [r] is a type scheme represented by the signature [s], 
+  and is completely applied: [List.length args = List.length s]. *)
+		  
+and extract_type_app env db (r,s) args =
+  let ml_args = 
+    List.fold_right 
+      (fun (b,c) a -> if b 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
+       else a)
+      (List.combine s args) []
+  in Tglob (r,  ml_args)
+
+(*S Extraction of a type scheme. *)
+
+(* [extract_type_scheme env db c p] works on a Coq term [c] which is
+  an informative type scheme. It means that [c] is not a Coq type, but will 
+  be when applied to sufficiently many arguments ([p] in fact).  
+  This function decomposes p lambdas, with eta-expansion if needed. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+and extract_type_scheme env db c p = 
+  if p=0 then extract_type env db 0 c [] 
+  else 
+    let c = whd_betaiotazeta c in 
+    match kind_of_term c with 
+      | Lambda (n,t,d) -> 
+          extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
+      | _ ->  
+          let rels = fst (splay_prod env none (type_of env c)) in
+          let env = push_rels_assum rels env in  
+          let eta_args = List.rev_map mkRel (interval 1 p) in 
+          extract_type env db 0 (lift p c) eta_args
+
+
+(*S Extraction of an inductive type. *)
+
+and extract_ind env kn = (* kn is supposed to be in long form *)
+  try 
+    if KNset.mem kn !internal_call then lookup_ind kn (* Already started. *)
+    else if visible_kn kn then lookup_ind kn (* Standard situation. *)
+    else raise Not_found (* Never trust the table for a internal kn. *)
+  with Not_found -> 
+    internal_call := KNset.add kn !internal_call;
+    let mib = Environ.lookup_mind kn env in 
+    (* 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
+    (* 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
+	   let t = Array.make (Array.length mip.mind_nf_lc) [] in 
+	   { ip_typename = mip.mind_typename;
+	     ip_consnames = mip.mind_consnames;
+	     ip_logical = (not b); 
+	     ip_sign = s; 
+	     ip_vars = v; 
+	     ip_types = t }) 
+	mib.mind_packets 
+    in 
+    add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets};
+    (* Second pass: we extract constructors *)
+    for i = 0 to mib.mind_ntypes - 1 do
+      let p = packets.(i) in 
+      if not p.ip_logical then
+	let types = arities_of_constructors env (kn,i) in 
+	for j = 0 to Array.length types - 1 do 
+	  let t = snd (decompose_prod_n npar types.(j)) in
+	  let prods,head = dest_prod epar t in 
+	  let nprods = List.length prods in 
+          let args = match kind_of_term head with
+            | App (f,args) -> args (* [kind_of_term f = Ind ip] *)
+            | _ -> [||]
+          in
+	  let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in 
+	  let db = db_from_ind dbmap npar in 
+	  p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
+	done
+    done;
+    (* Third pass: we determine special cases. *)
+    let ind_info = 
+      try 
+	if not mib.mind_finite then raise (I Coinductive); 
+	if mib.mind_ntypes <> 1 then raise (I Standard); 
+	let p = packets.(0) in 
+	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 
+	if List.length l = 1 && not (type_mem_kn kn (List.hd l)) 
+	then raise (I Singleton); 
+	if l = [] then raise (I Standard);
+	let ip = (kn, 0) in 
+	if is_custom (IndRef ip) then raise (I Standard); 
+	let projs = 
+	  try (find_structure ip).s_PROJ 
+	  with Not_found -> raise (I Standard);
+	in 
+	let n = nb_default_params env mip0.mind_nf_arity in
+	let projs = try List.map out_some projs with _ -> raise (I Standard) in
+	let is_true_proj kn = 
+          let (_,body) = Sign.decompose_lam_assum (constant_value env kn) in
+          match kind_of_term body with
+              | Rel _ -> false
+              | Case _ -> true
+              | _ -> assert false
+	in 
+	let projs = List.filter is_true_proj projs in 
+ 	let rec check = function 
+          | [] -> [],[]
+          | (typ, kn) :: l -> 
+              let l1,l2 = check l in 
+              if type_eq (mlt_env env) Tdummy typ then l1,l2 
+              else 
+                let r = ConstRef kn in 
+                if List.mem false (type_to_sign (mlt_env env) typ) 
+                then r :: l1, l2 
+                else r :: l1, r :: l2
+	in 
+	add_record kn n (check (List.combine typ projs)); 
+	raise (I Record)
+      with (I info) -> info
+    in
+    let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in 
+    add_ind kn i; 
+    internal_call := KNset.remove kn !internal_call;
+    i
+
+(*s [extract_type_cons] extracts the type of an inductive 
+  constructor toward the corresponding list of ML types. *)
+
+(* \begin{itemize}
+   \item [db] is a context for translating Coq [Rel] into ML type [Tvar] 
+   \item [dbmap] is a translation map (produced by a call to [parse_in_args])
+   \item [i] is the rank of the current product (initially [params_nb+1]) 
+   \end{itemize} *)
+
+and extract_type_cons env db dbmap c i =
+  match kind_of_term (whd_betadeltaiota env none c) with 
+    | Prod (n,t,d) -> 
+	let env' = push_rel_assum (n,t) env in
+	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
+	let l = extract_type_cons env' db' dbmap d (i+1) in 
+	(extract_type env db 0 t []) :: l 
+    | _ -> [] 
+
+(*s Recording the ML type abbreviation of a Coq type scheme constant. *)
+
+and mlt_env env r = match r with 
+  | ConstRef kn -> 
+      (try 
+	 if not (visible_kn 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
+	 match cb.const_body with
+	   | None -> None
+	   | Some l_body -> 
+	       (match flag_of_type env typ with 
+		  | Info,TypeScheme -> 
+		      let body = Declarations.force l_body in
+		      let s,vl = type_sign_vl env typ in 
+		      let db = db_from_sign s in 
+		      let t = extract_type_scheme env db body (List.length s) 
+		      in add_term kn (Dtype (r, vl, t)); Some t
+		  | _ -> 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)
+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; 
+    lookup_type kn 
+  with Not_found ->
+    let typ = match opt_typ with 
+      | None -> constant_type env kn 
+      | Some typ -> typ 
+    in let mlt = extract_type env [] 1 typ [] 
+    in let schema = (type_maxvar mlt, mlt)
+    in add_type kn schema; schema
+
+(*S Extraction of a term. *)
+
+(* Precondition: [(c args)] is not a type scheme, and is informative. *)
+
+(* [mle] is a ML environment [Mlenv.t]. *)
+(* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
+
+let rec extract_term env mle mlt c args = 
+  match kind_of_term c with
+    | App (f,a) ->
+	extract_term env mle mlt f (Array.to_list a @ args)
+    | Lambda (n, t, d) ->
+	let id = id_of_name n in 
+	(match args with 
+	   | a :: l -> 
+	       (* We make as many [LetIn] as possible. *)
+ 	       let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
+	       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 b = new_meta () in 
+	       (* If [mlt] cannot be unified with an arrow type, then magic! *)
+	       let magic = needs_magic (mlt, Tarr (a, b)) in 
+	       let d' = extract_term env' (Mlenv.push_type mle a) b d [] in 
+	       put_magic_if magic (MLlam (id, d')))
+    | LetIn (n, c1, t1, c2) ->
+	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 
+	  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')
+    | Const kn ->
+	extract_cst_app env mle mlt kn args
+    | Construct cp ->
+	extract_cons_app env mle mlt cp args
+    | Rel n ->
+	(* As soon as the expected [mlt] for the head is known, *)
+	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
+	let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
+	in extract_app env mle mlt extract_rel args 
+    | Case ({ci_ind=ip},_,c0,br) ->
+ 	extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
+    | Fix ((_,i),recd) ->
+ 	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
+    | 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
+
+(*s Generic way to deal with an application. *)
+
+(* We first type all arguments starting with unknown meta types. 
+   This gives us the expected type of the head. Then we use the 
+   [mk_head] to produce the ML head from this type. *)
+
+and extract_app env mle mlt mk_head args = 
+  let metas = List.map new_meta args in 
+  let type_head = type_recomp (metas, mlt) in 
+  let mlargs = List.map2 (extract_maybe_term env mle) metas args in 
+  if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs)
+
+(*s Auxiliary function used to extract arguments of constant or constructor. *)
+
+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 rec f = function  
+    | [], [] -> [] 
+    | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt))
+    | _::la, _::lt -> f (la,lt)
+    | _ -> assert false 
+  in f (args,typs)
+
+(*s Extraction of a constant applied to arguments. *)
+
+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 
+  (* Then the expected type of this constant. *)
+  let metas = List.map new_meta args 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 
+  (* 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 ls = List.length s in 
+  let la = List.length args in
+  let mla = make_mlargs env mle s args metas in 
+  let mla =
+    if not magic1 then 
+      try 
+	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in 
+	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
+	else mla
+      with _ -> mla
+    else mla
+  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 then put_magic_if (magic2 && not magic1) (MLapp (head, mla))
+    else 
+      (* Not enough arguments. We complete via eta-expansion. *)
+      let ls' = ls-la in
+      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 
+    (* 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))
+
+(*s Extraction of an inductive constructor applied to arguments. *)
+
+(* \begin{itemize}
+   \item In ML, contructor arguments are uncurryfied. 
+   \item We managed to suppress logical parts inside inductive definitions,
+   but they must appears outside (for partial applications for instance)
+   \item We also suppressed all Coq parameters to the inductives, since
+   they are fixed, and thus are not used for the computation.
+   \end{itemize} *)
+
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+  (* First, we build the type of the constructor, stored in small pieces. *)
+  let mi = extract_ind env kn in 
+  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
+  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 ((<>) Tdummy) types in
+  let ls = List.length s in 
+  let la = List.length args in 
+  assert (la <= ls + params_nb);
+  let la' = max 0 (la - params_nb) in 
+  let args' = list_lastn la' args in 
+  (* Now, we build the expected type of the constructor *)
+  let metas = List.map new_meta args' in 
+  (* If stored and expected types differ, then magic! *)
+  let a = new_meta () in 
+  let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
+  let magic2 = needs_magic (a, mlt) in 
+  let head mla = 
+    if mi.ind_info = Singleton then 
+      put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
+    else put_magic_if magic1 (MLcons (ConstructRef cp, mla))
+  in 
+  (* Different situations depending of the number of arguments: *)
+  if la < params_nb then 
+    let head' = head (eta_args_sign ls s) in 
+    put_magic_if magic2 
+      (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
+  else 
+    let mla = make_mlargs env mle s args' metas in 
+    if la = ls + params_nb 
+    then put_magic_if (magic2 && not magic1) (head mla)
+    else (* [ params_nb <= la <= ls + params_nb ] *) 
+      let ls' = params_nb + ls - la in 
+      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 (head mla) s')
+
+(*S Extraction of a case. *)
+
+and extract_case env mle ((kn,i) as ip,c,br) mlt = 
+  (* [br]: bodies of each branch (in functional form) *)
+  (* [ni]: number of arguments without parameters in each branch *)
+  let ni = mis_constr_nargs_env env ip in
+  let br_size = Array.length br in 
+  assert (Array.length ni = br_size); 
+  if br_size = 0 then begin
+    add_recursors env kn; (* May have passed unseen if logical ... *)
+    MLexn "absurd case"
+  end else 
+    (* [c] has an inductive type, and is not a type scheme type. *)
+    let t = type_of env c in 
+    (* The only non-informative case: [c] is of sort [Prop] *)
+    if (sort_of env t) = InProp then 
+      begin 
+	add_recursors env kn; (* May have passed unseen if logical ... *)
+	(* 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 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. *)
+      let type_head = Tglob (IndRef ip, Array.to_list metas) in
+      let a = extract_term env mle type_head c [] in 
+      (* 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 l = List.map f 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. *)
+	let ids,e = case_expunge (List.map ((<>) Tdummy) l) e in
+	(ConstructRef (ip,i+1), List.rev ids, e)
+      in
+      if mi.ind_info = Singleton then 
+	begin 
+	  (* Informative singleton case: *)
+	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
+	  assert (br_size = 1);
+	  let (_,ids,e') = extract_branch 0 in
+	  assert (List.length ids = 1);
+	  MLletin (List.hd ids,a,e')
+	end 
+      else 
+	(* Standard case: we apply [extract_branch]. *)
+	MLcase (a, Array.init br_size extract_branch)
+  
+(*s Extraction of a (co)-fixpoint. *)
+
+and extract_fix env mle i (fi,ti,ci as recd) mlt = 
+  let env = push_rec_types recd env in 
+  let metas = Array.map new_meta fi in
+  metas.(i) <- mlt; 
+  let mle = Array.fold_left Mlenv.push_type mle metas in 
+  let ei = array_map2 (extract_maybe_term env mle) metas ci in 
+  MLfix (i, Array.map id_of_name fi, ei)
+
+(*S ML declarations. *)
+
+(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], 
+   and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
+
+let rec decomp_lams_eta_n n env c t = 
+  let rels = fst (decomp_n_prod env none n t) in 
+  let rels = List.map (fun (id,_,c) -> (id,c)) rels in 
+  let m = nb_lam c in 
+  if m >= n then decompose_lam_n n c 
+  else
+    let rels',c = decompose_lam c in 
+    let d = n - m in 
+    (* we'd better keep rels' as long as possible. *)
+    let rels = (list_firstn d rels) @ rels' in
+    let eta_args = List.rev_map mkRel (interval 1 d) in 
+    rels, applist (lift d c,eta_args)
+
+(*s From a constant to a ML declaration. *)
+
+let extract_std_constant env kn body typ = 
+  reset_meta_count (); 
+  (* The short type [t] (i.e. possibly with abbreviations). *)
+  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 ((<>) Tdummy) 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]. *)
+  let rels,c = decomp_lams_eta_n (List.length s) env body typ in
+  (* The lambdas names. *)
+  let ids = List.map (fun (n,_) -> id_of_name n) rels in 
+  (* The according Coq environment. *)
+  let env = push_rels_assum rels env in
+  (* The real extraction: *)
+  let e = extract_term env mle t' c [] in
+  (* Expunging term and type from dummy lambdas. *) 
+  term_expunge s (ids,e), type_expunge env t
+
+let extract_fixpoint env vkn (fi,ti,ci) = 
+  let n = Array.length vkn in 
+  let types = Array.make n Tdummy
+  and terms = Array.make n MLdummy in 
+  (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
+  let sub = List.rev_map mkConst (Array.to_list vkn) 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
+      terms.(i) <- e; 
+      types.(i) <- t;
+    end 
+  done; 
+  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
+  match cb.const_body with
+    | None -> (* A logical axiom is risky, an informative one is fatal. *) 
+        (match flag_of_type env typ with
+	   | (Info,TypeScheme) -> 
+	       if not (is_custom r) then warning_info_ax r; 
+	       let n = type_scheme_nb_args env typ in 
+	       let ids = iterate (fun l -> anonymous::l) n [] in 
+	       Dtype (r, ids, Taxiom) 
+           | (Info,Default) -> 
+	       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))
+    | Some body ->
+	(match flag_of_type env typ with
+	   | (Logic, Default) -> Dterm (r, MLdummy, Tdummy)
+	   | (Logic, TypeScheme) -> Dtype (r, [], Tdummy)
+	   | (Info, Default) -> 
+	       let e,t = extract_std_constant env kn (force body) typ in 
+	       Dterm (r,e,t)
+	   | (Info, TypeScheme) -> 
+	       let s,vl = type_sign_vl env typ in 
+               let db = db_from_sign s in 
+               let t = extract_type_scheme env db (force body) (List.length s) 
+	       in Dtype (r, vl, t))
+
+let extract_constant_spec env kn cb = 
+  let r = ConstRef kn in 
+  let typ = cb.const_type in
+  match flag_of_type env typ with 
+    | (Logic, TypeScheme) -> Stype (r, [], Some Tdummy)
+    | (Logic, Default) -> Sval (r, Tdummy) 
+    | (Info, TypeScheme) -> 
+	let s,vl = type_sign_vl env typ in 
+	(match cb.const_body with 
+	  | None -> Stype (r, vl, None)
+	  | Some body -> 
+	      let db = db_from_sign s in 
+	      let t = extract_type_scheme env db (force body) (List.length s)
+	      in Stype (r, vl, Some t)) 
+    | (Info, Default) -> 
+	let t = snd (record_constant_type env kn (Some typ)) in 
+	Sval (r, type_expunge env t)
+
+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 packets = 
+    Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) 
+      ind.ind_packets
+  in { ind with ind_packets = packets }
+
+(*s From a global reference to a ML declaration. *)
+
+let extract_declaration env r = match r with
+  | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env)
+  | IndRef (kn,_) -> Dind (kn, extract_inductive env kn)
+  | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn)
+  | VarRef kn -> assert false
+
+(*s Without doing complete extraction, just guess what a constant would be. *) 
+
+type kind = Logical | Term | Type 
+    
+let constant_kind env cb = 
+  match flag_of_type env cb.const_type with 
+    | (Logic,_) -> Logical
+    | (Info,TypeScheme) -> Type
+    | (Info,Default) -> Term
+
+(*s Is a [ml_decl] logical ? *) 
+
+let logical_decl = function 
+  | Dterm (_,MLdummy,Tdummy) -> true
+  | Dtype (_,[],Tdummy) -> true 
+  | Dfix (_,av,tv) -> 
+      (array_for_all ((=) MLdummy) av) && (array_for_all ((=) Tdummy) 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
+  | 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
new file mode 100644
index 00000000..fc5782c9
--- /dev/null
+++ b/contrib/extraction/extraction.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: extraction.mli,v 1.27.2.1 2004/07/16 19:30:07 herbelin Exp $ i*)
+
+(*s Extraction from Coq terms to Miniml. *)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Libnames
+open Miniml
+
+val extract_constant : env -> kernel_name -> constant_body -> ml_decl
+
+val extract_constant_spec : env -> kernel_name -> constant_body -> ml_spec
+
+val extract_fixpoint : 
+  env -> kernel_name array -> (constr, types) prec_declaration -> ml_decl 
+
+val extract_inductive : env -> kernel_name -> ml_ind
+
+(*s ML declaration corresponding to a Coq reference. *)
+
+val extract_declaration : env -> global_reference -> ml_decl
+
+(*s Without doing complete extraction, just guess what a constant would be. *) 
+
+type kind = Logical | Term | Type 
+
+val constant_kind : env -> constant_body -> kind
+
+(*s Is a [ml_decl] or a [ml_spec] logical ? *) 
+
+val logical_decl : ml_decl -> bool
+val logical_spec : ml_spec -> bool
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
new file mode 100644
index 00000000..33a6117d
--- /dev/null
+++ b/contrib/extraction/g_extraction.ml4
@@ -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        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* ML names *)
+
+open Vernacexpr
+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)
+
+ARGUMENT EXTEND mlname
+  TYPED AS string
+  PRINTED BY pr_mlname
+| [ preident(id) ] -> [ id ]
+| [ string(s) ] -> [ s ]
+END
+
+open Table
+open Extract_env
+
+VERNAC ARGUMENT EXTEND language
+| [ "Ocaml" ] -> [ Ocaml ]
+| [ "Haskell" ] -> [ Haskell ]
+| [ "Scheme" ] -> [ Scheme ]
+| [ "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
+(* Extraction in the Coq toplevel *)
+| [ "Extraction" global(x) ] -> [ extraction x ]
+| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ]
+
+(* Monolithic extraction to a file *)
+| [ "Extraction" string(f) ne_global_list(l) ] 
+  -> [ extraction_file f l ]
+END
+
+(* Modular extraction (one Coq library = one ML module) *)
+VERNAC COMMAND EXTEND ExtractionLibrary
+| [ "Extraction" "Library" ident(m) ]
+  -> [ extraction_library false m ]
+END
+
+VERNAC COMMAND EXTEND RecursiveExtractionLibrary
+| [ "Recursive" "Extraction" "Library" ident(m) ]
+  -> [ extraction_library true m ]
+END
+
+(* Target Language *)
+VERNAC COMMAND EXTEND ExtractionLanguage
+| [ "Extraction" "Language" language(l) ] 
+  -> [ extraction_language l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInline
+(* Custom inlining directives *)
+| [ "Extraction" "Inline" ne_global_list(l) ] 
+  -> [ extraction_inline true l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionNoInline
+| [ "Extraction" "NoInline" ne_global_list(l) ] 
+  -> [ extraction_inline false l ]
+END
+
+VERNAC COMMAND EXTEND PrintExtractionInline
+| [ "Print" "Extraction" "Inline" ]
+  -> [ print_extraction_inline () ]
+END
+
+VERNAC COMMAND EXTEND ResetExtractionInline
+| [ "Reset" "Extraction" "Inline" ]
+  -> [ reset_extraction_inline () ]
+END
+
+(* Overriding of a Coq object by an ML one *)
+VERNAC COMMAND EXTEND ExtractionConstant
+| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
+  -> [ extract_constant_inline false x idl y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInlinedConstant
+| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
+  -> [ extract_constant_inline true x [] y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInductive
+| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ]
+  -> [ extract_inductive x (id,idl) ]
+END
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
new file mode 100644
index 00000000..29c8cd18
--- /dev/null
+++ b/contrib/extraction/haskell.ml
@@ -0,0 +1,280 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: haskell.ml,v 1.40.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Haskell syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Ocaml
+
+(*s Haskell renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+  [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
+    "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; 
+    "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
+    "as"; "qualified"; "hiding" ; "unit" ]
+  Idset.empty
+
+let preamble prm used_modules (mldummy,tdummy,tunknown) =
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in  
+  str "module " ++ pr_upper_id prm.mod_name ++ str " where" ++ fnl () 
+  ++ fnl() ++ 
+  str "import qualified Prelude" ++ fnl() ++
+  prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ fnl () ++
+  (if mldummy then 
+     str "__ = Prelude.error \"Logical or arity value used\"" 
+     ++ fnl () ++ fnl()
+   else mt())
+
+let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO" 
+
+let pp_abst = function
+  | [] -> (mt ())
+  | l  -> (str "\\" ++
+             prlist_with_sep (fun () -> (str " ")) pr_id l ++
+             str " ->" ++ spc ())
+
+let pr_lower_id id = pr_id (lowercase_id id)
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let local_mpl = ref ([] : module_path list)
+
+let pp_global r = P.pp_global !local_mpl r
+let empty_env () = [], P.globals()
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+    are needed or not. *)
+
+let rec pp_type par vl t =
+  let rec pp_rec par = function
+    | Tmeta _ | Tvar' _ -> assert false 
+    | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i))
+    | Tglob (r,[]) -> pp_global r	
+    | Tglob (r,l) -> 
+	pp_par par 
+	  (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l)
+    | Tarr (t1,t2) ->
+	pp_par par 
+	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+    | Tdummy -> str "()"
+    | Tunknown -> str "()"
+    | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
+    | Tcustom s -> str s
+ in 
+  hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+    parentheses are needed or not. [env] is the list of names for the
+    de Bruijn variables. [args] is the list of collected arguments
+    (already pretty-printed). *)
+
+let expr_needs_par = function
+  | MLlam _  -> true
+  | MLcase _ -> true
+  | _        -> false 
+
+
+let rec pp_expr par env args =
+  let par' = args <> [] || par
+  and apply st = pp_apply st par args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr true env []) args' in
+        pp_expr par env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
+	apply (pp_par par' st)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	let pp_id = pr_id (List.hd i)
+	and pp_a1 = pp_expr false env [] a1
+	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in
+	hv 0 
+	  (apply 
+	     (pp_par par' 
+		(hv 0 
+		   (hov 5 
+		      (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ 
+		    spc () ++ str "in") ++
+		 spc () ++ hov 0 pp_a2)))
+    | MLglob r -> 
+	apply (pp_global r)
+    | MLcons (r,[]) ->
+	assert (args=[]); pp_global r
+    | MLcons (r,[a]) ->
+	assert (args=[]);
+	pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a)
+    | MLcons (r,args') ->
+	assert (args=[]);
+	pp_par par (pp_global r ++ spc () ++ 
+		    prlist_with_sep spc (pp_expr true env []) args')
+    | MLcase (t, pv) ->
+      	apply (pp_par par' 
+		 (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
+		       fnl () ++ str "  " ++ pp_pat env pv)))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	pp_par par (str "Prelude.error" ++ spc () ++ qs s)
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->  pp_expr par env args a
+    | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"")
+
+and pp_pat env pv = 
+  let pp_one_pat (name,ids,t) =
+    let ids,env' = push_vars (List.rev ids) env in
+    let par = expr_needs_par t in
+    hov 2 (pp_global name ++
+	   (match ids with 
+	      | [] -> mt ()
+	      | _  -> (str " " ++ 
+		       prlist_with_sep 
+			 (fun () -> (spc ())) pr_id (List.rev ids))) ++
+	   str " ->" ++ spc () ++ pp_expr par env' [] t)
+  in 
+  (prvect_with_sep (fun () -> (fnl () ++ str "  ")) pp_one_pat pv)
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+  pp_par par
+    (v 0  
+       (v 2 (str "let" ++ fnl () ++
+	     prvect_with_sep fnl 
+	       (fun (fi,ti) -> pp_function env (pr_id fi) ti) 
+	       (array_map2 (fun a b -> a,b) ids bl)) ++ 
+	fnl () ++ 
+	hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+and pp_function env f t =
+  let bl,t' = collect_lams t in
+  let bl,env' = push_vars bl env in
+  (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 ()
+
+let pp_logical_ind packet = 
+  pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
+  pp_comment (str "with constructors : " ++ 
+	      prvect_with_sep spc pr_id packet.ip_consnames)
+
+let pp_singleton kn packet = 
+  let l = rename_tvars keywords packet.ip_vars in 
+  let l' = List.rev l in 
+  hov 2 (str "type " ++ pp_global (IndRef (kn,0)) ++ spc () ++ 
+	 prlist_with_sep spc pr_id l ++
+	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
+	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
+	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+		     pr_id packet.ip_consnames.(0)))
+
+let pp_one_ind ip pl cv =
+  let pl = rename_tvars keywords pl in
+  let pp_constructor (r,l) =
+    (pp_global r ++
+     match l with
+       | [] -> (mt ()) 
+       | _  -> (str " " ++
+      	       	prlist_with_sep 
+		  (fun () -> (str " ")) (pp_type true (List.rev pl)) l))
+  in
+  str (if cv = [||] 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"
+  else 
+    (v 0 (str "= " ++
+	  prvect_with_sep (fun () -> fnl () ++ str "  | ") pp_constructor 
+	    (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv)))
+  
+let rec pp_ind first kn i ind =
+  if i >= Array.length ind.ind_packets then 
+    if first then mt () else fnl () 
+  else 
+    let ip = (kn,i) in 
+    let p = ind.ind_packets.(i) in 
+    if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind 
+    else 
+      if p.ip_logical then  
+	pp_logical_ind p ++ pp_ind first kn (i+1) ind
+      else 
+	pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ 
+	pp_ind false kn (i+1) ind
+	  
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_decl mpl = 
+  local_mpl := mpl;
+  function
+  | Dind (kn,i) when i.ind_info = Singleton -> 
+      pp_singleton kn i.ind_packets.(0) ++ fnl ()
+  | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
+  | Dtype (r, l, t) ->
+      if is_inline_custom r then mt () 
+      else 
+	let l = rename_tvars keywords l in
+	let l' = List.rev l in 
+	hov 2 (str "type " ++ pp_global r ++ spc () ++ 
+	       prlist (fun id -> pr_id id ++ str " ") l ++
+	       str "=" ++ spc () ++ pp_type false l' t) ++ 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 ()
+  | Dterm (r, a, _) ->
+      if is_inline_custom r then mt () 
+      else 
+	hov 0 (pp_function (empty_env ()) (pp_global r) a ++ fnl () ++ fnl ())
+
+let pp_structure_elem mpl = function 
+  | (l,SEdecl d) -> pp_decl mpl d
+  | (l,SEmodule m) -> 
+      failwith "TODO: Haskell extraction of modules not implemented yet"
+  | (l,SEmodtype m) -> 
+      failwith "TODO: Haskell extraction of modules not implemented yet"
+
+let pp_struct = 
+  prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel)
+
+let pp_signature s = failwith "TODO"
+
+end
+
diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli
new file mode 100644
index 00000000..4da5db0c
--- /dev/null
+++ b/contrib/extraction/haskell.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: haskell.mli,v 1.15.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Pp
+open Names
+open Miniml
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+module Make : functor(P : Mlpp_param) -> Mlpp
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
new file mode 100644
index 00000000..866ff847
--- /dev/null
+++ b/contrib/extraction/miniml.mli
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: miniml.mli,v 1.46.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Target language for extraction: a core ML called MiniML. *)
+
+open Pp
+open Util
+open Names
+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. *)
+   
+(* Convention: outmost lambda/product gives the head of the list, 
+   and [true] means that the argument is to be kept. *)
+
+type signature = bool list
+
+(*s ML type expressions. *)
+
+type ml_type = 
+  | Tarr    of ml_type * ml_type
+  | Tglob   of global_reference * ml_type list 
+  | Tvar    of int
+  | Tvar'   of int (* same as Tvar, used to avoid clash *)
+  | Tmeta   of ml_meta (* used during ML type reconstruction *)
+  | Tdummy
+  | Tunknown
+  | Taxiom
+  | Tcustom of string
+
+and ml_meta = { id : int; mutable contents : ml_type option }
+
+(* ML type schema. 
+   The integer is the number of variable in the schema. *)
+
+type ml_schema = int * ml_type 
+
+(*s ML inductive types. *)
+
+type inductive_info = Record | Singleton | Coinductive | Standard
+
+(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. 
+   If the inductive is logical ([ip_logical = false]), then all other fields
+   are unused. Otherwise, 
+   [ip_sign] is a signature concerning the arguments of the inductive, 
+   [ip_vars] contains the names of the type variables surviving in ML, 
+   [ip_types] contains the ML types of all constructors.    
+*)
+
+type ml_ind_packet = { 
+  ip_typename : identifier; 
+  ip_consnames : identifier array; 
+  ip_logical : bool;
+  ip_sign : signature; 
+  ip_vars : identifier list; 
+  ip_types : (ml_type list) array }  
+
+(* [ip_nparams] contains the number of parameters. *)
+
+type ml_ind = {
+  ind_info : inductive_info;
+  ind_nparams : int; 	       
+  ind_packets : ml_ind_packet array }
+
+(*s ML terms. *)
+
+type ml_ast = 
+  | MLrel    of int
+  | MLapp    of ml_ast * ml_ast list
+  | MLlam    of identifier * ml_ast
+  | MLletin  of identifier * ml_ast * ml_ast
+  | MLglob   of global_reference
+  | MLcons   of global_reference * ml_ast list
+  | MLcase   of ml_ast * (global_reference * identifier list * ml_ast) array
+  | MLfix    of int * identifier array * ml_ast array
+  | MLexn    of string
+  | MLdummy
+  | MLaxiom
+  | MLmagic  of ml_ast
+
+(*s ML declarations. *)
+
+type ml_decl = 
+  | Dind  of kernel_name * ml_ind
+  | Dtype of global_reference * identifier list * ml_type
+  | Dterm of global_reference * ml_ast * ml_type
+  | Dfix  of global_reference array * ml_ast array * ml_type array
+
+type ml_spec = 
+  | Sind  of kernel_name * ml_ind
+  | Stype of global_reference * identifier list * ml_type option 
+  | Sval  of global_reference * ml_type
+
+type ml_specif = 
+  | Spec of ml_spec 
+  | Smodule of ml_module_type
+  | Smodtype of ml_module_type
+
+and ml_module_type = 
+  | MTident of kernel_name
+  | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
+  | MTsig of mod_self_id * ml_module_sig
+
+and ml_module_sig = (label * ml_specif) list
+
+type ml_structure_elem = 
+  | SEdecl of ml_decl
+  | SEmodule of ml_module
+  | SEmodtype of ml_module_type
+
+and ml_module_expr =
+  | MEident of module_path
+  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr 
+  | MEstruct of mod_self_id * ml_module_structure
+  | MEapply of ml_module_expr * ml_module_expr
+
+and ml_module_structure = (label * ml_structure_elem) list
+
+and ml_module = 
+    { ml_mod_expr : ml_module_expr; 
+      ml_mod_type : ml_module_type }
+
+(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] 
+   implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *)
+
+type ml_structure = (module_path * ml_module_structure) list
+
+type ml_signature = (module_path * ml_module_sig) list
+
+(*s Pretty-printing of MiniML in a given concrete syntax is parameterized
+    by a function [pp_global] that pretty-prints global references. 
+    The resulting pretty-printer is a module of type [Mlpp] providing
+    functions to print types, terms and declarations. *)
+
+module type Mlpp_param = sig
+  val globals : unit -> Idset.t
+  val pp_global : module_path list -> global_reference -> std_ppcmds
+  val pp_module : module_path list -> module_path -> std_ppcmds
+end
+
+module type Mlpp = sig
+  val pp_decl : module_path list -> ml_decl -> std_ppcmds
+  val pp_struct : ml_structure -> std_ppcmds
+  val pp_signature : ml_signature -> std_ppcmds
+end
+
+type extraction_params =  
+  { modular : bool; 
+    mod_name : identifier; 
+    to_appear : global_reference list }
diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml
new file mode 100644
index 00000000..fbe423a7
--- /dev/null
+++ b/contrib/extraction/mlutil.ml
@@ -0,0 +1,1136 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: mlutil.ml,v 1.104.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Nametab
+open Table
+open Miniml
+(*i*)
+
+(*s Exceptions. *)
+
+exception Found
+exception Impossible
+
+(*S Names operations. *)
+
+let anonymous = id_of_string "x"
+let dummy_name = id_of_string "_"
+
+let id_of_name = function
+  | Anonymous -> anonymous
+  | Name id when id = dummy_name -> anonymous
+  | Name id -> id 
+
+(*S Operations upon ML types (with meta). *)
+
+let meta_count = ref 0 
+		     
+let reset_meta_count () = meta_count := 0
+			      
+let new_meta _ = 
+  incr meta_count; 
+  Tmeta {id = !meta_count; contents = None}
+
+(*s Sustitution of [Tvar i] by [t] in a ML type. *)
+
+let type_subst i t0 t = 
+  let rec subst t = match t with
+    | Tvar j when i = j -> t0
+    | Tmeta {contents=None} -> t 
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a 
+  in subst t
+       
+(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
+
+let type_subst_list l t = 
+  let rec subst t = match t with 
+    | Tvar j -> List.nth l (j-1)
+    | Tmeta {contents=None} -> t
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a
+  in subst t
+
+(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *)
+
+let type_subst_vect v t = 
+  let rec subst t = match t with 
+    | Tvar j -> v.(j-1)
+    | Tmeta {contents=None} -> t
+    | Tmeta {contents=Some u} -> subst u
+    | Tarr (a,b) -> Tarr (subst a, subst b)
+    | Tglob (r, l) -> Tglob (r, List.map subst l)
+    | a -> a
+  in subst t
+
+(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *)
+
+let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
+
+(*s Occur-check of a free meta in a type *)
+
+let rec type_occurs alpha t =
+  match t with
+  | Tmeta {id=beta; contents=None} -> alpha = beta
+  | Tmeta {contents=Some u} -> type_occurs alpha u
+  | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
+  | Tglob (r,l) -> List.exists (type_occurs alpha) l  
+  | _ -> false
+
+(*s Most General Unificator *)
+
+let rec mgu = function
+  | Tmeta m, Tmeta m' when m.id = m'.id -> ()
+  | Tmeta m, t when m.contents=None -> 
+      if type_occurs m.id t then raise Impossible
+      else m.contents <- Some t
+  | t, Tmeta m when m.contents=None -> 
+      if type_occurs m.id t then raise Impossible
+      else m.contents <- Some t
+  | Tmeta {contents=Some u}, t -> mgu (u, t)
+  | t, Tmeta {contents=Some u} -> mgu (t, u)
+  | Tarr(a, b), Tarr(a', b') ->
+      mgu (a, a'); mgu (b, b')
+  | Tglob (r,l), Tglob (r',l') when r = r' ->
+       List.iter mgu (List.combine l l')
+  | Tvar i, Tvar j when i = j -> ()
+  | Tvar' i, Tvar' j when i = j -> ()
+  | Tdummy, Tdummy -> ()
+  | Tunknown, Tunknown -> ()
+  | _ -> raise Impossible
+
+let needs_magic p = try mgu p; false with Impossible -> true
+
+let put_magic_if b a = if b then MLmagic a else a
+
+let put_magic p a = if needs_magic p then MLmagic a else a
+
+
+(*S ML type env. *)
+
+module Mlenv = struct 
+  
+  let meta_cmp m m' = compare m.id m'.id 
+  module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end)
+
+  (* Main MLenv type. [env] is the real environment, whereas [free] 
+     (tries to) record the free meta variables occurring in [env]. *)
+
+  type t = { env : ml_schema list; mutable free : Metaset.t}
+
+  (* Empty environment. *)
+
+  let empty = { env = []; free = Metaset.empty }
+
+  (* [get] returns a instantiated copy of the n-th most recently added 
+     type in the environment. *)
+
+  let get mle n = 
+    assert (List.length mle.env >= n); 
+    instantiation (List.nth mle.env (n-1))
+
+  (* [find_free] finds the free meta in a type. *) 
+
+  let rec find_free set = function 
+    | Tmeta m when m.contents = None -> Metaset.add m set
+    | Tmeta {contents = Some t} -> find_free set t
+    | Tarr (a,b) -> find_free (find_free set a) b
+    | Tglob (_,l) -> List.fold_left find_free set l
+    | _ -> set
+
+  (* The [free] set of an environment can be outdate after 
+     some unifications. [clean_free] takes care of that. *) 
+			
+  let clean_free mle = 
+    let rem = ref Metaset.empty 
+    and add = ref Metaset.empty in 
+    let clean m = match m.contents with 
+      | None -> () 
+      | Some u -> rem := Metaset.add m !rem; add := find_free !add u
+    in 
+    Metaset.iter clean mle.free; 
+    mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add
+
+  (* From a type to a type schema. If a [Tmeta] is still uninstantiated
+     and does appears in the [mle], then it becomes a [Tvar]. *)
+
+  let generalization mle t = 
+    let c = ref 0 in 
+    let map = ref (Intmap.empty : int Intmap.t) in 
+    let add_new i = incr c; map := Intmap.add i !c !map; !c in 
+    let rec meta2var t = match t with 
+      | Tmeta {contents=Some u} -> meta2var u 
+      | Tmeta ({id=i} as m) -> 
+	  (try Tvar (Intmap.find i !map) 
+	   with Not_found ->  
+	     if Metaset.mem m mle.free then t 
+	     else Tvar (add_new i))
+      | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2)
+      | Tglob (r,l) -> Tglob (r, List.map meta2var l) 
+      | t -> t 
+    in !c, meta2var t
+	
+  (* Adding a type in an environment, after generalizing. *)
+
+  let push_gen mle t = 
+    clean_free mle; 
+    { env = generalization mle t :: mle.env; free = mle.free }
+
+  (* Adding a type with no [Tvar], hence no generalization needed. *)
+
+  let push_type {env=e;free=f} t = 
+    { env = (0,t) :: e; free = find_free f t} 
+    
+  (* Adding a type with no [Tvar] nor [Tmeta]. *)
+
+  let push_std_type {env=e;free=f} t = 
+    { env = (0,t) :: e; free = f}
+
+end
+
+(*S Operations upon ML types (without meta). *)
+
+(*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
+  | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
+  | _ -> false
+
+(*s Greatest variable occurring in [t]. *)
+
+let type_maxvar t = 
+  let rec parse n = function 
+    | Tmeta _ -> assert false
+    | Tvar i -> max i n 
+    | Tarr (a,b) -> parse (parse n a) b
+    | Tglob (_,l) -> List.fold_left parse n l 
+    | _ -> n 
+  in parse 0 t
+
+(*s From [a -> b -> c] to [[a;b],c]. *) 
+
+let rec type_decomp = function 
+  | Tmeta _ -> assert false
+  | Tarr (a,b) -> let l,h = type_decomp b in a::l, h 
+  | a -> [],a
+
+(*s The converse: From [[a;b],c] to [a -> b -> c]. *)
+
+let rec type_recomp (l,t) = match l with 
+  | [] -> t 
+  | a::l -> Tarr (a, type_recomp (l,t))
+
+(*s Translating [Tvar] to [Tvar'] to avoid clash. *)
+
+let rec var2var' = function 
+  | Tmeta _ -> assert false
+  | Tvar i -> Tvar' i
+  | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
+  | Tglob (r,l) -> Tglob (r, List.map var2var' l)
+  | a -> a
+
+type abbrev_map = global_reference -> ml_type option
+
+(*s Delta-reduction of type constants everywhere in a ML type [t].
+   [env] is a function of type [ml_type_env]. *)
+
+let type_expand env t = 
+  let rec expand = function
+    | Tmeta _ -> assert false
+    | Tglob (r,l) as t ->    
+	(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
+
+(*s Idem, but only at the top level of implications. *)
+
+let is_arrow = function Tarr _ -> true | _ -> false
+
+let type_weak_expand env t = 
+  let rec expand = function
+    | Tmeta _ -> assert false
+    | Tglob (r,l) as t ->    
+	(match env r with 
+	   | Some mlt -> 
+	       let u = expand (type_subst_list l mlt) in 
+	       if is_arrow u then u else t
+	   | None -> t)
+    | Tarr (a,b) -> Tarr (a, expand b)
+    | 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 rec f = function 
+    | Tmeta _ -> assert false
+    | Tarr (a,b) -> (Tdummy <> a) :: (f b)
+    | _ -> [] 
+  in f (type_expand env t)
+
+(*s Removing [Tdummy] from the top level of a ML type. *)
+
+let type_expunge env t = 
+  let s = type_to_sign env t in 
+  if s = [] then t 
+  else if List.mem true s then 
+    let rec f t s = 
+      if List.mem false s then 
+	match t with 
+	  | Tmeta _ -> assert false
+	  | Tarr (a,b) -> 
+	      let t = f b (List.tl s) in 
+	      if List.hd s then Tarr (a, t) else t  
+	  | Tglob (r,l) ->
+	      (match env r with 
+		 | Some mlt -> f (type_subst_list l mlt) s
+		 | None -> assert false)
+	  | _ -> assert false
+      else t 
+    in f t s 
+  else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) 
+
+(*S Generic functions over ML ast terms. *)
+
+(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care 
+   of the number of bingings crossed before reaching the [MLrel]. *)
+
+let ast_iter_rel f = 
+  let rec iter n = function
+    | MLrel i -> f (i-n)
+    | MLlam (_,a) -> iter (n+1) a
+    | MLletin (_,a,b) -> iter n a; iter (n+1) b
+    | MLcase (a,v) ->
+	iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
+    | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
+    | MLapp (a,l) -> iter n a; List.iter (iter n) l
+    | MLcons (_,l) ->  List.iter (iter n) l
+    | MLmagic a -> iter n a
+    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
+  in iter 0 
+
+(*s Map over asts. *)
+
+let ast_map_case f (c,ids,a) = (c,ids,f a)
+
+let ast_map f = function
+  | MLlam (i,a) -> MLlam (i, f a)
+  | MLletin (i,a,b) -> MLletin (i, f a, f b)
+  | MLcase (a,v) -> MLcase (f a, Array.map (ast_map_case f) v)
+  | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
+  | MLapp (a,l) -> MLapp (f a, List.map f l)
+  | MLcons (c,l) -> MLcons (c, List.map f l)
+  | MLmagic a -> MLmagic (f a)
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
+
+(*s Map over asts, with binding depth as parameter. *)
+
+let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
+
+let ast_map_lift f n = function 
+  | MLlam (i,a) -> MLlam (i, f (n+1) a)
+  | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
+  | MLcase (a,v) -> MLcase (f n a,Array.map (ast_map_lift_case f n) v)
+  | MLfix (i,ids,v) -> 
+      let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
+  | MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
+  | MLcons (c,l) -> MLcons (c, List.map (f n) l)
+  | MLmagic a -> MLmagic (f n a)
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a	
+
+(*s Iter over asts. *) 
+
+let ast_iter_case f (c,ids,a) = f a
+
+let ast_iter f = function
+  | MLlam (i,a) -> f a
+  | MLletin (i,a,b) -> f a; f b
+  | MLcase (a,v) -> f a; Array.iter (ast_iter_case f) v
+  | MLfix (i,ids,v) -> Array.iter f v
+  | 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 -> ()
+
+(*S Operations concerning De Bruijn indices. *)
+
+(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *)
+
+let ast_occurs k t = 
+  try 
+    ast_iter_rel (fun i -> if i = k then raise Found) t; false 
+  with Found -> true
+
+(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] 
+   in [t] with [k<=i<=k'] *)
+
+let ast_occurs_itvl k k' t = 
+  try 
+    ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false 
+  with Found -> true
+
+(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *)
+
+let nb_occur_k k t =
+  let cpt = ref 0 in 
+  ast_iter_rel (fun i -> if i = k then incr cpt) t;
+  !cpt
+
+let nb_occur t = nb_occur_k 1 t
+
+(* Number of occurences of [Rel 1] in [t], with special treatment of match:
+   occurences in different branches aren't added, but we rather use max. *)
+
+let nb_occur_match = 
+  let rec nb k = function 
+    | MLrel i -> if i = k then 1 else 0
+    | MLcase(a,v) -> 
+        (nb k a) +
+	Array.fold_left 
+	  (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
+    | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) 
+    | MLfix (_,ids,v) -> let k = k+(Array.length ids) in 
+      Array.fold_left (fun r a -> r+(nb k a)) 0 v
+    | MLlam (_,a) -> nb (k+1) a
+    | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
+    | MLcons (_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l 
+    | MLmagic a -> nb k a
+    | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
+  in nb 1
+
+(*s Lifting on terms.
+    [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *)
+
+let ast_lift k t = 
+  let rec liftrec n = function
+    | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
+    | a -> ast_map_lift liftrec n a
+  in if k = 0 then t else liftrec 0 t
+
+let ast_pop t = ast_lift (-1) t
+
+(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... 
+  Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *)
+
+let permut_rels k k' = 
+  let rec permut n = function
+    | MLrel i as a ->
+	let i' = i-n in
+	if i'<1 || i'>k+k' then a 
+	else if i'<=k then MLrel (i+k')
+	else MLrel (i-k)
+    | a -> ast_map_lift permut n a
+  in permut 0  
+
+(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. 
+    Lifting (of one binder) is done at the same time. *)
+
+let ast_subst e =
+  let rec subst n = function
+    | MLrel i as a ->
+	let i' = i-n in 
+	if i'=1 then ast_lift n e
+	else if i'<1 then a 
+	else MLrel (i-1)
+    | a -> ast_map_lift subst n a
+  in subst 0
+
+(*s Generalized substitution. 
+   [gen_subst v d t] applies to [t] the substitution coded in the 
+   [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies 
+   to [Rel] greater than [Array.length v]. *)
+
+let gen_subst v d t = 
+  let rec subst n = function
+    | MLrel i as a -> 
+	let i'= i-n in 
+	if i' < 1 then a 
+	else if i' <= Array.length v then 
+	  ast_lift n v.(i'-1) 
+	else MLrel (i+d) 
+    | a -> ast_map_lift subst n a
+  in subst 0 t
+
+(*S Operations concerning lambdas. *)
+
+(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
+    [[idn;...;id1]] and the term [t]. *)
+
+let collect_lams = 
+  let rec collect acc = function
+    | MLlam(id,t) -> collect (id::acc) t
+    | x           -> acc,x
+  in collect []
+
+(*s [collect_n_lams] does the same for a precise number of [MLlam]. *)
+
+let collect_n_lams = 
+  let rec collect acc n t = 
+    if n = 0 then acc,t 
+    else match t with 
+      | MLlam(id,t) -> collect (id::acc) (n-1) t
+      | _ -> assert false
+  in collect [] 
+
+(*s [remove_n_lams] just removes some [MLlam]. *)
+
+let rec remove_n_lams n t = 
+  if n = 0 then t  
+  else match t with 
+      | MLlam(_,t) -> remove_n_lams (n-1) t
+      | _ -> assert false
+
+(*s [nb_lams] gives the number of head [MLlam]. *)
+
+let rec nb_lams = function 
+  | MLlam(_,t) -> succ (nb_lams t)
+  | _ -> 0 
+
+(*s [named_lams] does the converse of [collect_lams]. *)
+
+let rec named_lams ids a = match ids with 
+  | [] -> a 
+  | id :: ids -> named_lams ids (MLlam (id,a))
+
+(*s The same in anonymous version. *)
+
+let rec anonym_lams a = function 
+  | 0 -> a 
+  | n -> anonym_lams (MLlam (anonymous,a)) (pred n)
+
+(*s Idem for [dummy_name]. *)
+
+let rec dummy_lams a = function 
+  | 0 -> a 
+  | n -> dummy_lams (MLlam (dummy_name,a)) (pred n)
+
+(*s mixed according to a signature. *)
+
+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)
+
+(*S Operations concerning eta. *)
+
+(*s The following function creates [MLrel n;...;MLrel 1] *)
+
+let rec eta_args n = 
+  if n = 0 then [] else (MLrel n)::(eta_args (pred n))
+
+(*s Same, but filtered by a signature. *)
+
+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
+
+(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
+
+let rec test_eta_args_lift k n = function 
+  | [] -> n=0
+  | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
+
+(*s Computes an eta-reduction. *)
+
+let eta_red e = 
+  let ids,t = collect_lams e in 
+  let n = List.length ids in
+  if n = 0 then e 
+  else match t with 
+    | MLapp (f,a) -> 
+	let m = (List.length a) - n in 
+	if m < 0 then e 
+	else
+	  let a1,a2 = list_chop m a in 
+	  let f = if m = 0 then f else MLapp (f,a1) in 
+	  if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f)
+	  then ast_lift (-n) f
+	  else e 
+    | _ -> e
+
+(*s Computes all head linear beta-reductions possible in [(t a)].
+  Non-linear head beta-redex become let-in. *)
+
+let rec linear_beta_red a t = match a,t with  
+  | [], _ -> t 
+  | a0::a, MLlam (id,t) ->
+      (match nb_occur_match t with
+	 | 0 -> linear_beta_red a (ast_pop t)
+	 | 1 -> linear_beta_red a (ast_subst a0 t)
+	 | _ -> 
+	     let a = List.map (ast_lift 1) a in 
+	     MLletin (id, a0, linear_beta_red a t))
+  | _ -> MLapp (t, a)
+
+(*s Applies a substitution [s] of constants by their body, plus 
+  linear beta reductions at modified positions. *)  
+
+let rec ast_glob_subst s t = match t with 
+  | MLapp ((MLglob (ConstRef kn)) as f, a) -> 
+      let a = List.map (ast_glob_subst s) a in 
+      (try linear_beta_red a (KNmap.find kn s) 
+       with Not_found -> MLapp (f, a))
+  | MLglob (ConstRef kn) -> (try KNmap.find kn s with Not_found -> t)
+  | _ -> ast_map (ast_glob_subst s) t
+
+
+(*S Auxiliary functions used in simplification of ML cases. *)
+
+(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1]
+  and raises [Impossible] if any variable in [l] occurs outside such a 
+  [MLcons] *)
+
+let check_and_generalize (r0,l,c) = 
+  let nargs = List.length l in 
+  let rec genrec n = function 
+    | MLrel i as c -> 
+	let i' = i-n in 
+	if i'<1 then c 
+	else if i'>nargs then MLrel (i-nargs+1) 
+	else raise Impossible
+    | MLcons(r,args) when r=r0 && (test_eta_args_lift n nargs args) -> 
+	MLrel (n+1) 
+    | a -> ast_map_lift genrec n a
+  in genrec 0 c  
+
+(*s [check_generalizable_case] checks if all branches can be seen as the 
+  same function [f] applied to the term matched. It is a generalized version 
+  of the identity case optimization. *)
+
+(* CAVEAT: this optimization breaks typing in some special case. example: 
+   [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a],
+   which is incompatible with the type of [let f x = x].
+   By default, we brutally disable this optim except for some known types: 
+   [bool], [sumbool], [sumor] *)
+
+let generalizable_list = 
+  let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes")
+  and specif = MPfile (dirpath_of_string "Coq.Init.Specif")
+  in 
+  [ make_kn datatypes empty_dirpath (mk_label "bool"); 
+    make_kn specif empty_dirpath (mk_label "sumbool");
+    make_kn specif empty_dirpath (mk_label "sumor") ]
+
+let check_generalizable_case unsafe br = 
+  if not unsafe then 
+    (match br.(0) with 
+     | ConstructRef ((kn,_),_), _, _ ->
+	 if not (List.mem kn generalizable_list) then raise Impossible
+     | _ -> assert false); 
+  let f = check_and_generalize br.(0) in 
+  for i = 1 to Array.length br - 1 do 
+    if check_and_generalize br.(i) <> f then raise Impossible 
+  done; f
+
+(*s Do all branches correspond to the same thing? *)
+
+let check_constant_case br = 
+  if br = [||] 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; 
+  let cst = ast_lift (-n) t in 
+  for i = 1 to Array.length br - 1 do 
+    let (r,l,t) = br.(i) in
+    let n = List.length l in
+    if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t)) 
+    then raise Impossible
+  done; cst
+
+(*s If all branches are functions, try to permut the case and the functions. *)
+
+let rec merge_ids ids ids' = match ids,ids' with 
+  | [],l -> l 
+  | l,[] -> l
+  | i::ids, i'::ids' -> 
+      (if i = dummy_name then i' else i) :: (merge_ids ids ids')
+
+let is_exn = function MLexn _ -> true | _ -> false
+
+let rec permut_case_fun br acc = 
+  let nb = ref max_int in 
+  Array.iter (fun (_,_,t) -> 
+		let ids, c = collect_lams t in 
+		let n = List.length ids in 
+		if (n < !nb) && (not (is_exn c)) then nb := n) br; 
+  if !nb = max_int || !nb = 0 then ([],br) 
+  else begin
+    let br = Array.copy br in 
+    let ids = ref [] in  
+    for i = 0 to Array.length br - 1 do 
+      let (r,l,t) = br.(i) in 
+      let local_nb = nb_lams t in 
+      if local_nb < !nb then (* t = MLexn ... *)
+	br.(i) <- (r,l,remove_n_lams local_nb t)
+      else begin
+	let local_ids,t = collect_n_lams !nb t in 
+	ids := merge_ids !ids local_ids; 
+	br.(i) <- (r,l,permut_rels !nb (List.length l) t)
+      end
+    done; 
+    (!ids,br)
+  end
+  
+(*S Generalized iota-reduction. *)
+
+(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] 
+   with [(is_iota_gen e)=true]. Any generalized iota-redex is 
+   transformed into beta-redexes. *)
+
+let rec is_iota_gen = function 
+  | MLcons _ -> true
+  | MLcase(_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
+  | _ -> false
+
+let constructor_index = function
+  | ConstructRef (_,j) -> pred j
+  | _ -> assert false
+
+let iota_gen br = 
+  let rec iota k = function 
+    | MLcons (r,a) ->
+	let (_,ids,c) = br.(constructor_index r) in
+	let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in
+	let c = ast_lift k c in 
+	MLapp (c,a)
+    | MLcase(e,br') -> 
+	let new_br = 
+	  Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br'
+	in MLcase(e, new_br)
+    | _ -> assert false
+  in iota 0 
+
+let is_atomic = function 
+  | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
+  | _ -> false
+
+(*S The main simplification function. *)
+
+(* Some beta-iota reductions + simplifications. *)
+
+let rec simpl o = function
+  | MLapp (f, []) ->
+      simpl o f
+  | MLapp (f, a) -> 
+      simpl_app o (List.map (simpl o) a) (simpl o f)
+  | MLcase (e,br) ->
+      let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in 
+      simpl_case o br (simpl o e) 
+  | MLletin(id,c,e) when 
+      (id = dummy_name) || (is_atomic c) || (is_atomic e) ||
+      (let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let)) -> 
+	simpl o (ast_subst c e)
+  | MLfix(i,ids,c) -> 
+      let n = Array.length ids in 
+      if ast_occurs_itvl 1 n c.(i) then 
+	MLfix (i, ids, Array.map (simpl o) c)
+      else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *)
+  | a -> ast_map (simpl o) a 
+
+and simpl_app o a = function  
+  | MLapp (f',a') -> simpl_app o (a'@a) f'
+  | MLlam (id,t) when id = dummy_name -> 
+      simpl o (MLapp (ast_pop t, List.tl a))
+  | MLlam (id,t) -> (* Beta redex *)
+      (match nb_occur_match t with
+	 | 0 -> simpl o (MLapp (ast_pop t, List.tl a))
+	 | 1 when o.opt_lin_beta -> 
+	     simpl o (MLapp (ast_subst (List.hd a) t, List.tl a))
+	 | _ -> 
+	     let a' = List.map (ast_lift 1) (List.tl a) in
+	     simpl o (MLletin (id, List.hd a, MLapp (t, a'))))
+  | MLletin (id,e1,e2) when o.opt_let_app -> 
+      (* Application of a letin: we push arguments inside *)
+      MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a)))
+  | MLcase (e,br) when o.opt_case_app -> 
+      (* Application of a case: we push arguments inside *)
+      let br' = 
+	Array.map 
+      	  (fun (n,l,t) -> 
+	     let k = List.length l in
+	     let a' = List.map (ast_lift k) a in
+      	     (n, l, simpl o (MLapp (t,a')))) br 
+      in simpl o (MLcase (e,br')) 
+  | (MLdummy | MLexn _) as e -> e 
+	(* We just discard arguments in those cases. *)
+  | f -> MLapp (f,a)
+
+and simpl_case o br e = 
+  if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *)
+    simpl o (iota_gen br e)
+  else 
+    try (* Does a term [f] exist such as each branch is [(f e)] ? *)
+      if not o.opt_case_idr then raise Impossible;
+      let f = check_generalizable_case o.opt_case_idg br in 
+      simpl o (MLapp (MLlam (anonymous,f),[e]))
+    with Impossible -> 
+      try (* Is each branch independant of [e] ? *) 
+	if not o.opt_case_cst then raise Impossible;
+	check_constant_case br 
+      with Impossible ->
+	(* Swap the case and the lam if possible *)
+	if o.opt_case_fun 
+	then 
+	  let ids,br = permut_case_fun br [] in 
+	  let n = List.length ids in 
+	  if n <> 0 then named_lams ids (MLcase (ast_lift n e, br))
+	  else MLcase (e, br) 
+	else MLcase (e,br)
+
+let rec post_simpl = function 
+  | MLletin(_,c,e) when (is_atomic (eta_red c)) -> 
+      post_simpl (ast_subst (eta_red c) e)
+  | a -> ast_map post_simpl a 
+
+(*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] 
+   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
+  | _ -> assert false 
+
+(*s [kill_some_lams] removes some head lambdas according to the bool list [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". 
+   [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 
+  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
+    in parse_ids 0 1 bl ; 
+    select_via_bl bl ids, gen_subst v (n'-n) c
+  end
+
+(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding 
+  to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or 
+  if there is no lambda left at all. *)
+
+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 ids',c = kill_some_lams bl (ids,c) in 
+    ids, named_lams ids' c
+  else raise Impossible
+
+(*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 :
+   [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)]  with [c' = lift 4 c] *)
+
+let eta_expansion_sign s (ids,c) =
+  let rec abs ids rels i = function
+    | [] -> 
+	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
+  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]. *)
+
+let case_expunge s e = 
+  let m = List.length s in 
+  let n = nb_lams e in 
+  let p = if m <= n then collect_n_lams m e 
+  else eta_expansion_sign (list_skipn n s) (collect_lams e) in 
+  kill_some_lams (List.rev s) p
+
+(*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. *)
+
+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)
+    else named_lams ids c
+
+(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and 
+  purge the args of [t0] corresponding to a [dummy_name]. 
+  It makes eta-expansion if needed. *) 
+
+let kill_dummy_args ids t0 t =
+  let m = List.length ids in 
+  let bl = List.rev_map ((<>) dummy_name) 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 
+	let a = List.map (killrec n) a in  
+	let a = List.map (ast_lift k) a in 
+	let a = select_via_bl bl (a @ (eta_args k)) in 
+	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) 
+    | e when e = ast_lift n t0 -> 
+	let a = select_via_bl bl (eta_args m) in 
+	named_lams ids (MLapp (ast_lift m e, a))
+    | e -> ast_map_lift killrec n e 
+  in killrec 0 t 
+
+(*s The main function for local [dummy] elimination. *)
+
+let rec kill_dummy = function 
+  | MLfix(i,fi,c) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in 
+	 ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1))
+       with Impossible -> MLfix (i,fi,Array.map kill_dummy c))
+  | MLapp (MLfix (i,fi,c),a) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in 
+	 let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in 
+	 let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in
+	 ast_subst (MLfix (i,fi,c)) e  
+       with Impossible -> 
+	 MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a))
+  | MLletin(id, MLfix (i,fi,c),e) -> 
+      (try 
+	 let ids,c = kill_dummy_fix i fi c in
+	 let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in 
+	 MLletin(id, MLfix(i,fi,c),e)
+      with Impossible -> 
+	MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e))
+  | MLletin(id,c,e) -> 
+      (try 
+	 let ids,c = kill_dummy_lams c in 
+	 let e = kill_dummy_args ids (MLrel 1) e in 
+	 MLletin (id, kill_dummy c,kill_dummy e) 
+       with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
+  | a -> ast_map kill_dummy a
+
+and kill_dummy_fix i fi c = 
+  let n = Array.length fi in 
+  let ids,ci = kill_dummy_lams c.(i) in 
+  let c = Array.copy c in c.(i) <- ci; 
+  for j = 0 to (n-1) do 
+    c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) 
+  done;
+  ids,c
+
+(*s Putting things together. *)
+
+let normalize a = 
+  let o = optims () in 
+  let a = simpl o a in 
+  if o.opt_kill_dum then post_simpl (kill_dummy a) else a
+
+(*S Special treatment of fixpoint for pretty-printing purpose. *)
+
+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)
+    | _ -> 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
+  let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in  
+  let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
+  MLfix(0,[|f|],[|new_c|])
+
+let optimize_fix a = 
+  if not (optims()).opt_fix_fun then a 
+  else
+    let ids,a' = collect_lams a in 
+    let n = List.length ids in 
+    if n = 0 then a 
+    else match a' with 
+      | MLfix(_,[|f|],[|c|]) ->
+	  let new_f = MLapp (MLrel (n+1),eta_args n) in 
+	  let new_c = named_lams ids (normalize (ast_subst new_f c))
+	  in MLfix(0,[|f|],[|new_c|])
+      | MLapp(a',args) ->
+	  let m = List.length args in 
+	  (match a' with 
+	     | MLfix(_,_,_) when 
+		 (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m 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))) 
+	     | _ -> a)
+      | _ -> a
+
+(*S Inlining. *)
+
+(* Utility functions used in the decision of inlining. *)
+
+let rec ml_size = function
+  | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l
+  | MLlam(_,t) -> 1 + ml_size t
+  | MLcons(_,l) -> ml_size_list l
+  | MLcase(t,pv) -> 
+      1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
+  | MLfix(_,_,f) -> ml_size_array f
+  | MLletin (_,_,t) -> ml_size t
+  | MLmagic t -> ml_size t
+  | _ -> 0
+
+and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l
+
+and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l
+
+let is_fix = function MLfix _ -> true | _ -> false
+
+let rec is_constr = function
+  | MLcons _   -> true
+  | MLlam(_,t) -> is_constr t
+  | _          -> false
+
+(*s Strictness *)
+
+(* A variable is strict if the evaluation of the whole term implies
+   the evaluation of this variable. Non-strict variables can be found 
+   behind Match, for example. Expanding a term [t] is a good idea when 
+   it begins by at least one non-strict lambda, since the corresponding 
+   argument to [t] might be unevaluated in the expanded code. *)
+
+exception Toplevel
+
+let lift n l = List.map ((+) n) l
+
+let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l 
+
+(* This function returns a list of de Bruijn indices of non-strict variables,
+   or raises [Toplevel] if it has an internal non-strict variable. 
+   In fact, not all variables are checked for strictness, only the ones which 
+   de Bruijn index is in the candidates list [cand]. The flag [add] controls 
+   the behaviour when going through a lambda: should we add the corresponding 
+   variable to the candidates?  We use this flag to check only the external 
+   lambdas, those that will correspond to arguments. *)
+
+let rec non_stricts add cand = function 
+  | MLlam (id,t) -> 
+      let cand = lift 1 cand in
+      let cand = if add then 1::cand else cand in
+      pop 1 (non_stricts add cand t)
+  | MLrel n -> 
+      List.filter ((<>) n) cand  
+  | MLapp (MLrel n, _) -> 
+      List.filter ((<>) n) cand
+	(* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *)
+	(* gain something if x is replaced by a function like a projection *)
+  | MLapp (t,l)-> 
+      let cand = non_stricts false cand t in 
+      List.fold_left (non_stricts false) cand l 
+  | MLcons (_,l) -> 
+      List.fold_left (non_stricts false) cand l
+  | MLletin (_,t1,t2) -> 
+      let cand = non_stricts false cand t1 in 
+      pop 1 (non_stricts add (lift 1 cand) t2)
+  | MLfix (_,i,f)-> 
+      let n = Array.length i in
+      let cand = lift n cand in 
+      let cand = Array.fold_left (non_stricts false) cand f in 
+      pop n cand
+  | MLcase (t,v) -> 
+      (* The only interesting case: for a variable to be non-strict, *)
+      (* it is sufficient that it appears non-strict in at least one branch, *)
+      (* so we make an union (in fact a merge). *)
+      let cand = non_stricts false cand t in 
+      Array.fold_left 
+	(fun c (_,i,t)-> 
+	   let n = List.length i in 
+	   let cand = lift n cand in 
+	   let cand = pop n (non_stricts add cand t) in
+	   Sort.merge (<=) cand c) [] v
+	(* [merge] may duplicates some indices, but I don't mind. *)
+  | MLmagic t -> 
+      non_stricts add cand t
+  | _ -> 
+      cand
+
+(* The real test: we are looking for internal non-strict variables, so we start
+   with no candidates, and the only positive answer is via the [Toplevel] 
+   exception. *)
+
+let is_not_strict t = 
+  try let _ = non_stricts true [] t in false
+  with Toplevel -> true
+
+(*s Inlining decision *)
+
+(* [inline_test] answers the following question: 
+   If we could inline [t] (the user said nothing special), 
+   should we inline ? 
+   
+   We expand small terms with at least one non-strict 
+   variable (i.e. a variable that may not be evaluated).
+   
+   Futhermore we don't expand fixpoints. *)
+
+let inline_test t = 
+  not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict 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)))
+    [ "well_founded_induction_type"; "well_founded_induction"; 
+      "Acc_rect"; "Acc_rec" ; "Acc_iter" ]
+
+let manual_inline = function 
+  | ConstRef c -> List.mem c manual_inline_list
+  | _ -> false 
+
+(* If the user doesn't say he wants to keep [t], we inline in two cases:
+   \begin{itemize}
+   \item the user explicitly requests it 
+   \item [expansion_test] answers that the inlining is a good idea, and 
+   we are free to act (AutoInline is set)
+   \end{itemize} *)
+
+let inline r t = 
+  not (to_keep r) (* The user DOES want to keep it *)
+  && not (is_inline_custom r) 
+  && (to_inline r (* The user DOES want to inline it *) 
+     || (auto_inline () && lang () <> Haskell && not (is_projection r)
+         && (is_recursor r || manual_inline r || inline_test t)))
+
diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli
new file mode 100644
index 00000000..eaf38778
--- /dev/null
+++ b/contrib/extraction/mlutil.mli
@@ -0,0 +1,111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: mlutil.mli,v 1.47.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Util
+open Names
+open Term
+open Libnames
+open Miniml
+
+(*s Utility functions over ML types with meta. *)
+
+val reset_meta_count : unit -> unit
+val new_meta : 'a -> ml_type
+
+val type_subst : int -> ml_type -> ml_type -> ml_type
+val type_subst_list : ml_type list -> ml_type -> ml_type
+val type_subst_vect : ml_type array -> ml_type -> ml_type
+
+val instantiation : ml_schema -> ml_type
+
+val needs_magic : ml_type * ml_type -> bool
+val put_magic_if : bool -> ml_ast -> ml_ast
+val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
+
+(*s ML type environment. *)
+
+module Mlenv : sig 
+  type t 
+  val empty : t
+    
+  (* get the n-th more recently entered schema and instantiate it. *) 
+  val get : t -> int -> ml_type
+
+  (* Adding a type in an environment, after generalizing free meta *)
+  val push_gen : t -> ml_type -> t
+
+  (* Adding a type with no [Tvar] *)
+  val push_type : t -> ml_type -> t
+     
+  (* Adding a type with no [Tvar] nor [Tmeta] *)
+  val push_std_type : t -> ml_type -> t
+end
+
+(*s Utility functions over ML types without meta *)
+
+val type_mem_kn : kernel_name -> ml_type -> bool
+
+val type_maxvar : ml_type -> int
+
+val type_decomp : ml_type -> ml_type list * ml_type
+val type_recomp : ml_type list * ml_type -> ml_type
+
+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_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
+
+
+(*s Special identifiers. [dummy_name] is to be used for dead code
+    and will be printed as [_] in concrete (Caml) code. *)
+
+val anonymous : identifier
+val dummy_name : identifier
+val id_of_name : name -> identifier
+
+(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
+    the list [idn;...;id1] and the term [t]. *)
+
+val collect_lams : ml_ast -> identifier list * ml_ast
+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 eta_args_sign : int -> bool list -> ml_ast list 
+
+(*s Utility functions over ML terms. *)
+
+val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast
+val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast
+val ast_iter : (ml_ast -> unit) -> ml_ast -> unit
+val ast_occurs : int -> ml_ast -> bool
+val ast_occurs_itvl : int -> int -> ml_ast -> bool
+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 normalize : ml_ast -> ml_ast 
+val optimize_fix : ml_ast -> ml_ast
+val inline : global_reference -> ml_ast -> bool
+
+
+
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
new file mode 100644
index 00000000..feb9e54e
--- /dev/null
+++ b/contrib/extraction/modutil.ml
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: modutil.ml,v 1.7.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Util
+open Miniml
+open Table
+open Mlutil
+
+(*S Functions upon modules missing in [Modops]. *) 
+
+(*s Add _all_ direct subobjects of a module, not only those exported. 
+   Build on the [Modops.add_signature] model. *)
+
+let add_structure mp msb env = 
+  let add_one env (l,elem) = 
+    let kn = make_kn mp empty_dirpath l in 
+    match elem with 
+      | SEBconst cb -> Environ.add_constant kn 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  
+  in List.fold_left add_one env msb
+
+(*s Apply a module path substitution on a module.
+   Build on the [Modops.subst_modtype] model. *)
+
+let rec subst_module sub mb =
+  let mtb' = Modops.subst_modtype sub mb.mod_type
+  and meb' = option_smartmap (subst_meb sub) mb.mod_expr
+  and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type
+  and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in
+  if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) && 
+    (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv)
+  then mb
+  else { mod_expr= meb'; 
+	 mod_type=mtb'; 
+	 mod_user_type=mtb''; 
+	 mod_equiv=mpo'; 
+	 mod_constraints=mb.mod_constraints }
+
+and subst_meb sub = function 
+  | MEBident mp -> MEBident (subst_mp sub mp) 
+  | MEBfunctor (mbid, mtb, meb) -> 
+      assert (not (occur_mbid mbid sub)); 
+      MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb)
+  | MEBstruct (msid, msb) -> 
+      assert (not (occur_msid msid sub));
+      MEBstruct (msid, subst_msb sub msb)
+  | MEBapply (meb, meb', c) -> 
+      MEBapply (subst_meb sub meb, subst_meb sub meb', c)
+
+and subst_msb sub msb = 
+  let subst_body = function
+    | SEBconst cb -> SEBconst (subst_const_body sub cb)
+    | SEBmind mib -> SEBmind (subst_mind sub mib)
+    | SEBmodule mb -> SEBmodule (subst_module sub mb)
+    | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb)
+  in List.map (fun (l,b) -> (l,subst_body b)) msb
+
+(*s Change a msid in a module type, to follow a module expr. 
+  Because of the "with" construct, the module type of a module can be a 
+  [MTBsig] with a msid different from the one of the module. *)
+
+let rec replicate_msid meb mtb = match meb,mtb with 
+  | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) -> 
+      let mtb' = replicate_msid meb mtb2 in 
+      if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb')
+  | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 -> 
+      let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in
+      if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig')
+  | _ -> mtb
+
+
+(*S More functions concerning [module_path]. *)
+
+let rec mp_length = function
+  | MPdot (mp, _) -> 1 + (mp_length mp)
+  | _ -> 1
+
+let rec prefixes_mp mp = match mp with 
+  | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
+  | _ -> MPset.singleton mp 
+
+let rec common_prefix prefixes_mp1 mp2 = 
+  if MPset.mem mp2 prefixes_mp1 then mp2 
+  else match mp2 with 
+    | MPdot (mp,_) -> common_prefix prefixes_mp1 mp 
+    | _ -> raise Not_found
+
+let common_prefix_from_list mp0 mpl = 
+  let prefixes_mp0 = prefixes_mp mp0 in 
+  let rec f = function 
+    | [] -> raise Not_found
+    | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l
+  in f mpl
+
+let rec modfile_of_mp mp = match mp with 
+  | MPfile _ -> mp
+  | MPdot (mp,_) -> modfile_of_mp mp 
+  | _ -> raise Not_found
+
+let rec parse_labels ll = function 
+  | MPdot (mp,l) -> parse_labels (l::ll) mp 
+  | mp -> mp,ll
+
+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 rec add_labels_mp mp = function 
+  | [] -> mp 
+  | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
+
+
+(*S Functions upon ML modules. *)
+
+(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a 
+   [ml_structure]. *) 
+
+let struct_iter do_decl do_spec s = 
+  let rec mt_iter = function 
+    | MTident _ -> () 
+    | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
+    | MTsig (_, sign) -> List.iter spec_iter sign
+  and spec_iter = function 
+    | (_,Spec s) -> do_spec s
+    | (_,Smodule mt) -> mt_iter mt
+    | (_,Smodtype mt) -> mt_iter mt
+  in
+  let rec se_iter = function 
+    | (_,SEdecl d) -> do_decl d
+    | (_,SEmodule m) -> 
+	me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
+    | (_,SEmodtype m) -> mt_iter m
+  and me_iter = function 
+    | MEident _ -> () 
+    | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
+    | MEapply (me,me') -> me_iter me; me_iter me'
+    | MEstruct (msid, sel) -> List.iter se_iter sel
+  in 
+  List.iter (function (_,sel) -> List.iter se_iter sel) s
+
+(*s Apply some fonctions upon all references in [ml_type], [ml_ast], 
+  [ml_decl], [ml_spec] and [ml_structure]. *)
+
+type do_ref = global_reference -> unit
+
+let type_iter_references do_type t = 
+  let rec iter = function 
+    | Tglob (r,l) -> do_type r; List.iter iter l 
+    | Tarr (a,b) -> iter a; iter b 
+    | _ -> () 
+  in iter t
+
+let ast_iter_references do_term do_cons do_type a = 
+  let rec iter a = 
+    ast_iter iter a;
+    match a with 
+      | MLglob r -> do_term r
+      | MLcons (r,_) -> do_cons r
+      | MLcase (_,v) as a -> Array.iter (fun (r,_,_) -> do_cons r) v
+      | _ -> ()
+  in iter a
+
+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 
+  in
+  if ind.ind_info = Record then List.iter do_term (find_projections kn); 
+  Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
+  
+let decl_iter_references do_term do_cons do_type = 
+  let type_iter = type_iter_references do_type 
+  and ast_iter = ast_iter_references do_term do_cons do_type in
+  function 
+    | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind 
+    | Dtype (r,_,t) -> do_type r; type_iter t 
+    | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t
+    | Dfix(rv,c,t) -> 	
+	Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t
+
+let spec_iter_references do_term do_cons do_type = function 
+  | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind
+  | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot
+  | Sval (r,t) -> do_term r; type_iter_references do_type t
+
+let struct_iter_references do_term do_cons do_type = 
+  struct_iter 
+    (decl_iter_references do_term do_cons do_type) 
+    (spec_iter_references do_term do_cons do_type) 
+
+(*s Get all references used in one [ml_structure], either in [list] or [set]. *)
+
+type 'a updown = { mutable up : 'a ; mutable down : 'a }
+
+let struct_get_references empty add struc = 
+  let o = { up = empty ; down = empty } in 
+  let do_term r = o.down <- add r o.down in
+  let do_cons r = o.up <- add r o.up in 
+  let do_type = if lang () = Haskell then do_cons else do_term in 
+  struct_iter_references do_term do_cons do_type struc; o
+
+let struct_get_references_set = struct_get_references Refset.empty Refset.add
+
+module Orefset = struct 
+  type t = { set : Refset.t ; list : global_reference list }
+  let empty = { set = Refset.empty ; list = [] }
+  let add r o = 
+    if Refset.mem r o.set then o 
+    else { set = Refset.add r o.set ; list = r :: o.list }
+  let set o = o.set
+  let list o = o.list
+end
+
+let struct_get_references_list struc = 
+  let o = struct_get_references Orefset.empty Orefset.add struc in 
+  { up = Orefset.list o.up; down = Orefset.list o.down }
+
+
+(*s Searching occurrences of a particular term (no lifting done). *)
+
+exception Found
+
+let rec ast_search t a = 
+  if t = a then raise Found else ast_iter (ast_search t) a
+
+let decl_ast_search t = function 
+  | Dterm (_,a,_) -> ast_search t a
+  | Dfix (_,c,_) -> Array.iter (ast_search t) c
+  | _ -> () 
+
+let struct_ast_search t s = 
+  try struct_iter (decl_ast_search t) (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 decl_type_search t = 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
+
+let spec_type_search t = 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
+
+let struct_type_search t s = 
+  try struct_iter (decl_type_search t) (spec_type_search t) s; false
+  with Found -> true
+
+
+(*s Generating the signature. *)
+
+let rec msig_of_ms = function 
+  | [] -> [] 
+  | (l,SEdecl (Dind (kn,i))) :: ms -> 
+      (l,Spec (Sind (kn,i))) :: (msig_of_ms ms)
+  | (l,SEdecl (Dterm (r,_,t))) :: ms -> 
+      (l,Spec (Sval (r,t))) :: (msig_of_ms ms)
+  | (l,SEdecl (Dtype (r,v,t))) :: ms -> 
+      (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) 
+  | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> 
+      let msig = ref (msig_of_ms ms) in 
+      for i = Array.length rv - 1 downto 0 do 
+	msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig
+      done; 
+      !msig
+  | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms)
+  | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms)
+
+let signature_of_structure s = 
+  List.map (fun (mp,ms) -> mp,msig_of_ms ms) s 
+
+
+(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
+
+let get_decl_in_structure r struc = 
+  try 
+    let kn = kn_of_r r in 
+    let base_mp,ll = labels_of_kn kn 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 
+      | [] -> assert false
+      | l :: ll -> 
+	  match List.assoc l sel with 
+	    | SEdecl d -> d 
+	    | SEmodtype m -> assert false
+	    | SEmodule m ->
+		match m.ml_mod_expr with 
+		  | MEstruct (_,sel) -> go ll sel 
+		  | _ -> error_not_visible r 
+    in go ll sel
+  with Not_found -> assert false
+
+
+(*s Optimization of a [ml_structure]. *)
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+   all beta redexes (when the argument does not occur, it is just
+   thrown away; when it occurs exactly once it is substituted; otherwise
+   a let-in redex is created for clarity) and iota redexes, plus some other
+   optimizations. *)
+
+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)
+  in 
+  let s = make_subst (Array.length rv - 1) KNmap.empty 
+  in 
+  let rec subst n t = match t with 
+    | MLglob (ConstRef kn) -> 
+	(try MLrel (n + (KNmap.find kn 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 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 ->
+      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 not i || prm.modular || List.mem r prm.to_appear 
+      then 
+	let d = match optimize_fix t with 
+	  | MLfix (0, _, [|c|]) -> 
+	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|])
+	  | t -> Dterm (r, t, typ)
+	in d :: (optim prm s l)
+      else optim prm s l
+  | d :: l -> d :: (optim prm s l)
+
+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 top && i && not prm.modular && not (List.mem r prm.to_appear)
+      then optim_se top prm s lse
+      else 
+	let d = match optimize_fix a with 
+	  | MLfix (0, _, [|c|]) -> 
+	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
+	  | a -> Dterm (r, a, t)
+	in (l,SEdecl d) :: (optim_se top prm s lse)
+  | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> 
+      let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in 
+      let all = ref true in 
+      (* This fake body ensures that no fixpoint will be auto-inlined. *)
+      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
+	else all := false
+      done; 
+      if !all && top && not prm.modular 
+	&& (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv)  
+      then optim_se top prm s lse
+      else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse)
+  | (l,SEmodule m) :: lse -> 
+      let m = { m with ml_mod_expr = optim_me prm s m.ml_mod_expr}
+      in (l,SEmodule m) :: (optim_se top prm s lse)
+  | se :: lse -> se :: (optim_se top prm s lse) 
+
+and optim_me prm s = function 
+  | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm s lse)
+  | MEident mp as me -> me
+  | MEapply (me, me') -> MEapply (optim_me prm s me, optim_me prm s me')
+  | 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 
+  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
new file mode 100644
index 00000000..f73e18f7
--- /dev/null
+++ b/contrib/extraction/modutil.mli
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: modutil.mli,v 1.2.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Miniml
+
+(*s Functions upon modules missing in [Modops]. *) 
+
+(* Add _all_ direct subobjects of a module, not only those exported. 
+   Build on the [Modops.add_signature] model. *)
+
+val add_structure : module_path -> module_structure_body -> env -> env 
+
+(* Apply a module path substitution on a module.
+   Build on the [Modops.subst_modtype] model. *)
+
+val subst_module : substitution -> module_body -> module_body 
+val subst_meb : substitution -> module_expr_body -> module_expr_body
+val subst_msb : substitution -> module_structure_body -> module_structure_body
+
+(* Change a msid in a module type, to follow a module expr. *)
+
+val replicate_msid : module_expr_body -> module_type_body -> module_type_body
+
+(*s More utilities concerning [module_path]. *)
+
+val mp_length : module_path -> int
+val prefixes_mp : module_path -> MPset.t
+val modfile_of_mp : module_path -> module_path
+val common_prefix_from_list : module_path -> module_path list -> module_path
+val add_labels_mp : module_path -> label list -> module_path
+
+(*s Functions upon ML modules. *)
+
+val struct_ast_search : ml_ast -> ml_structure -> bool
+val struct_type_search : ml_type -> ml_structure -> bool
+
+type do_ref = global_reference -> unit 
+
+val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
+val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
+val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit
+
+type 'a updown = { mutable up : 'a ; mutable down : 'a }
+
+val struct_get_references_set : ml_structure -> Refset.t updown
+val struct_get_references_list : ml_structure -> global_reference list updown
+
+val signature_of_structure : ml_structure -> ml_signature
+
+val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+   all beta redexes (when the argument does not occur, it is just
+   thrown away; when it occurs exactly once it is substituted; otherwise
+   a let-in redex is created for clarity) and iota redexes, plus some other
+   optimizations. *)
+
+val optimize_struct : 
+  extraction_params -> ml_decl list option -> ml_structure -> ml_structure
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
new file mode 100644
index 00000000..707ef94f
--- /dev/null
+++ b/contrib/extraction/ocaml.ml
@@ -0,0 +1,627 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ocaml.ml,v 1.100.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Ocaml syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Modutil
+
+let cons_cofix = ref Refset.empty
+
+(*s Some utility functions. *)
+
+let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+
+let pp_tvar id = 
+  let s = string_of_id id in 
+  if String.length s < 2 || s.[1]<>'\'' 
+  then str ("'"^s)
+  else str ("' "^s)
+
+let pp_tuple_light f = function
+  | [] -> mt ()
+  | [x] -> f true x
+  | l -> 
+      pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
+
+let pp_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
+
+let pp_boxed_tuple f = function
+  | [] -> mt ()
+  | [x] -> f x
+  | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
+
+let pp_abst = function
+  | [] -> mt ()
+  | l  -> 
+      str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ 
+      str " ->" ++ spc ()
+
+let pp_apply st par args = match args with
+  | [] -> st
+  | _  -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
+
+let pr_binding = function
+  | [] -> mt ()
+  | l  -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
+
+let space_if = function true -> str " " | false -> mt ()
+
+let sec_space_if = function true -> spc () | false -> mt ()
+
+let fnl2 () = fnl () ++ fnl () 
+
+(*s Generic renaming issues. *)
+
+let rec rename_id id avoid = 
+  if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
+
+let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let uppercase_id id = id_of_string (String.capitalize (string_of_id id))
+
+(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
+let pr_upper_id id = str (String.capitalize (string_of_id id))
+
+(*s de Bruijn environments for programs *)
+
+type env = identifier list * Idset.t
+
+let rec rename_vars avoid = function
+  | [] -> 
+      [], avoid
+  | id :: idl when id == dummy_name ->
+      (* we don't rename dummy binders *)
+      let (idl', avoid') = rename_vars avoid idl in
+      (id :: idl', avoid')
+  | id :: idl ->
+      let (idl, avoid) = rename_vars avoid idl in
+      let id = rename_id (lowercase_id id) avoid in
+      (id :: idl, Idset.add id avoid)
+
+let rename_tvars avoid l = 
+  let rec rename avoid = function 
+    | [] -> [],avoid 
+    | id :: idl -> 
+	let id = rename_id (lowercase_id id) avoid in 
+	let idl, avoid = rename (Idset.add id avoid) idl in 
+	(id :: idl, avoid) in
+  fst (rename avoid l)
+
+let push_vars ids (db,avoid) =
+  let ids',avoid' = rename_vars avoid ids in
+  ids', (ids' @ db, avoid')
+
+let get_db_name n (db,_) = 
+  let id = List.nth db (pred n) in 
+  if id = dummy_name then id_of_string "__" else id
+
+(*s Ocaml renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+  [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
+    "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
+    "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
+    "inherit"; "initializer"; "lazy"; "let"; "match"; "method";
+    "module"; "mutable"; "new"; "object"; "of"; "open"; "or";
+    "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
+    "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
+    "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] 
+  Idset.empty
+
+let preamble _ used_modules (mldummy,tdummy,tunknown) = 
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in 
+  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ 
+  (if used_modules = [] then mt () else fnl ())
+  ++
+  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt()) 
+  ++
+  (if mldummy then 
+     str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl ()
+   else mt ()) 
+  ++ 
+  (if tdummy || tunknown || mldummy then fnl () else mt ())
+
+let preamble_sig _ used_modules (_,tdummy,tunknown) = 
+  let pp_mp = function 
+    | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
+    | _ -> assert false 
+  in 
+  prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
+  ++ 
+  (if used_modules = [] then mt () else fnl ())
+  ++
+  (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl () 
+   else mt()) 
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let local_mpl = ref ([] : module_path list)
+
+let pp_global r = 
+  if is_inline_custom r then str (find_custom r) 
+  else P.pp_global !local_mpl  r
+
+let empty_env () = [], P.globals ()
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+    are needed or not. *)
+
+let rec pp_type par vl t =
+  let rec pp_rec par = function
+    | Tmeta _ | Tvar' _ | Taxiom -> assert false
+    | Tvar i -> (try pp_tvar (List.nth vl (pred i)) 
+		 with _ -> (str "'a" ++ int i))
+    | Tglob (r,[]) -> pp_global r
+    | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global r
+    | Tarr (t1,t2) ->
+	pp_par par 
+	  (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+    | Tdummy -> str "__"
+    | Tunknown -> str "__"
+    | Tcustom s -> str s
+  in 
+  hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+    parentheses are needed or not. [env] is the list of names for the
+    de Bruijn variables. [args] is the list of collected arguments
+    (already pretty-printed). *)
+
+let expr_needs_par = function
+  | MLlam _  -> true
+  | MLcase (_,[|_|]) -> false 
+  | MLcase _ -> true
+  | _        -> false 
+
+
+let rec pp_expr par env args = 
+  let par' = args <> [] || par
+  and apply st = pp_apply st par args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr true env []) args' in
+        pp_expr par env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in
+	apply (pp_par par' st)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	let pp_id = pr_id (List.hd i)
+	and pp_a1 = pp_expr false env [] a1
+	and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in 
+	hv 0 
+	  (apply 
+	     (pp_par par' 
+		(hv 0 
+		   (hov 2 
+		      (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ 
+		    spc () ++ str "in") ++ 
+		 spc () ++ hov 0 pp_a2)))
+    | MLglob r -> 
+	(try 
+	   let args = list_skipn (projection_arity r) args in 
+	   let record = List.hd args in 
+	   pp_apply (record ++ str "." ++ pp_global r) par (List.tl args)
+	 with _ -> apply (pp_global r))
+    | MLcons (r,[]) ->
+	assert (args=[]);
+	if Refset.mem r !cons_cofix then 
+	  pp_par par (str "lazy " ++ pp_global r)
+	else pp_global r
+    | MLcons (r,args') -> 
+	(try 
+	   let projs = find_projections (kn_of_r r) in 
+	   pp_record_pat (projs, List.map (pp_expr true env []) args')
+	 with Not_found ->
+	   assert (args=[]);
+	   let tuple = pp_tuple (pp_expr true env []) args' in 
+	   if Refset.mem r !cons_cofix then 
+	     pp_par par (str "lazy (" ++ pp_global r ++ spc() ++ tuple ++str ")")
+	   else pp_par par (pp_global r ++ spc () ++ tuple))
+    | MLcase (t, pv) ->
+	let r,_,_ = pv.(0) in 
+	let expr = if Refset.mem r !cons_cofix then 
+	  (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
+	else 
+	  (pp_expr false env [] t) 
+	in 
+	(try 
+	   let projs = find_projections (kn_of_r r) in 
+	   let (_, ids, c) = pv.(0) in 
+	   let n = List.length ids in 
+	   match c with 
+	     | MLrel i when i <= n -> 
+		 apply (pp_par par' (pp_expr true env [] t ++ str "." ++ 
+				     pp_global (List.nth projs (n-i)))) 
+	     | MLapp (MLrel i, a) when i <= n -> 
+		 if List.exists (ast_occurs_itvl 1 n) a 
+		 then raise Not_found
+		 else
+		   let ids,env' = push_vars (List.rev ids) env in
+		   (pp_apply 
+		      (pp_expr true env [] t ++ str "." ++ 
+		       pp_global (List.nth projs (n-i)))
+		      par ((List.map (pp_expr true env' []) a) @ args))
+	     | _ -> raise Not_found
+	 with Not_found -> 
+	   if Array.length pv = 1 then 
+	     let s1,s2 = pp_one_pat env pv.(0) in 
+	     apply 
+	       (hv 0 
+		  (pp_par par' 
+		     (hv 0 
+			(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) 
+			 ++ spc () ++ str "in") ++ 
+		      spc () ++ hov 0 s2)))
+	   else
+	     apply
+      	       (pp_par par' 
+      		  (v 0 (str "match " ++ expr ++ str " with" ++
+			fnl () ++ str "  | " ++ pp_pat env pv))))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->
+	pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
+    | MLaxiom -> 
+	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
+
+	  
+and pp_record_pat (projs, args) =
+   str "{ " ++
+   prlist_with_sep (fun () -> str ";" ++ spc ()) 
+     (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a)
+     (List.combine projs args) ++
+   str " }"
+
+and pp_one_pat env (r,ids,t) = 
+  let ids,env' = push_vars (List.rev ids) env in
+  let expr = pp_expr (expr_needs_par t) env' [] t in 
+  try 
+    let projs = find_projections (kn_of_r r) in 
+    pp_record_pat (projs, List.rev_map pr_id ids), expr
+  with Not_found -> 
+    let args = 
+      if ids = [] then (mt ()) 
+      else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in 
+    pp_global r ++ args, expr
+  
+and pp_pat env pv = 
+  prvect_with_sep (fun () -> (fnl () ++ str "  | ")) 
+    (fun x -> let s1,s2 = pp_one_pat env x in 
+     hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) 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
+  let is_not_cofix pv = 
+    let (r,_,_) = pv.(0) in not (Refset.mem r !cons_cofix) 
+  in					  
+  match t' with 
+    | MLcase(MLrel 1,pv) when is_not_cofix pv ->
+	if is_function pv then
+	  (f ++ pr_binding (List.rev (List.tl bl)) ++
+       	     str " = function" ++ fnl () ++
+	     v 0 (str "  | " ++ pp_pat env' pv))
+	else
+          (f ++ pr_binding (List.rev bl) ++ 
+             str " = match " ++
+	     pr_id (List.hd bl) ++ str " with" ++ fnl () ++
+	     v 0 (str "  | " ++ pp_pat env' pv))
+	  
+    | _ -> (f ++ pr_binding (List.rev bl) ++
+	      str " =" ++ fnl () ++ str "  " ++
+	      hov 2 (pp_expr false env' [] t'))
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+  pp_par par 
+    (v 0 (str "let rec " ++
+	  prvect_with_sep
+      	    (fun () -> fnl () ++ str "and ")
+	    (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+	    (array_map2 (fun id b -> (id,b)) ids bl) ++
+	  fnl () ++
+	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+let pp_val e typ = 
+  str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++ 
+  str " **)"  ++ fnl2 ()
+
+(*s Pretty-printing of [Dfix] *)
+
+let rec pp_Dfix init i ((rv,c,t) as fix) = 
+  if i >= Array.length rv then mt () 
+  else 
+    if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix
+    else 
+      let e = pp_global rv.(i) in
+      (if init then mt () else fnl2 ()) ++
+      pp_val e t.(i) ++
+      str (if init then "let rec " else "and ") ++
+      (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i))
+       else pp_function (empty_env ()) e c.(i)) ++
+      pp_Dfix false (i+1) fix 
+	
+(*s Pretty-printing of inductive types declaration. *)
+
+let pp_parameters l = 
+  (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
+
+let pp_string_parameters l = 
+  (pp_boxed_tuple str l ++ space_if (l<>[])) 
+
+let pp_one_ind prefix ip pl cv =
+  let pl = rename_tvars keywords pl in
+  let pp_constructor (r,l) =
+    hov 2 (str "  | " ++ pp_global r ++
+	   match l with
+	     | [] -> mt () 
+	     | _  -> (str " of " ++ 
+		      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 *)" 
+  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 : " ++ 
+			prvect_with_sep spc pr_id packet.ip_consnames)
+
+let pp_singleton kn packet = 
+  let l = rename_tvars keywords packet.ip_vars in 
+  hov 2 (str "type " ++ pp_parameters l ++
+	 pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++
+	 pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++
+	 pp_comment (str "singleton inductive, whose constructor was " ++ 
+		     pr_id packet.ip_consnames.(0)))
+
+let pp_record kn packet = 
+  let l = List.combine (find_projections kn) packet.ip_types.(0) in 
+  let projs = find_projections kn in
+  let pl = rename_tvars keywords packet.ip_vars in 
+  str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++
+  hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) 
+	   (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) 
+  ++ str " }"
+
+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"
+
+let pp_ind co kn ind =
+  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 p = ind.ind_packets.(i) in 
+      if is_custom (IndRef (kn,i)) then pp (i+1)
+      else begin 
+	some := true; 
+	if p.ip_logical then pp_logical_ind p ++ pp (i+1)
+	else 
+	  let s = !init in 
+	  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 ++
+	    pp (i+1)
+	  end
+      end
+  in 
+  let st = pp 0 in if !some then st else failwith "empty phrase"
+	     
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_mind kn i = 
+  match i.ind_info with 
+    | Singleton -> pp_singleton kn i.ind_packets.(0)
+    | Coinductive -> 
+	let nop _ = () 
+	and add r = cons_cofix := Refset.add r !cons_cofix in 
+	decl_iter_references nop add nop (Dind (kn,i)); 
+	pp_ind true kn i
+    | Record -> pp_record kn i.ind_packets.(0)
+    | _ -> pp_ind false kn i
+
+let pp_decl mpl = 
+  local_mpl := mpl; 
+  function
+    | Dind (kn,i) as d -> pp_mind kn i
+    | Dtype (r, l, t) ->
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let l = rename_tvars keywords l in 
+	  let ids, def = try 
+	    let ids,s = find_type_custom r in 
+	    pp_string_parameters ids, str "=" ++ spc () ++ str s 
+	  with not_found -> 
+	    pp_parameters l, 
+	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
+	    else str "=" ++ spc () ++ pp_type false l t
+	  in 
+	  hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ 
+		 spc () ++ def)
+    | Dterm (r, a, t) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let e = pp_global r in 
+	  pp_val e t ++
+	  hov 0 
+	    (str "let " ++ 
+	     if is_custom r then 
+	       e ++ str " = " ++ str (find_custom r)
+	     else if is_projection r then 
+	       let s = prvecti (fun _ -> str) 
+			 (Array.make (projection_arity r) " _") in 
+	       e ++ s ++ str " x = x." ++ e
+	     else pp_function (empty_env ()) e a)
+    | Dfix (rv,defs,typs) ->
+	pp_Dfix true 0 (rv,defs,typs)
+
+let pp_spec mpl = 
+  local_mpl := mpl; 
+  function 
+    | Sind (kn,i) -> pp_mind kn i
+    | Sval (r,t) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++
+		 pp_type false [] t)
+    | Stype (r,vl,ot) -> 
+	if is_inline_custom r then failwith "empty phrase"
+	else 
+	  let l = rename_tvars keywords vl in 
+	  let ids, def = 
+	    try 
+	      let ids, s = find_type_custom r in 
+	      pp_string_parameters ids,  str "= " ++ str s 
+	    with not_found -> 
+	      let ids = pp_parameters l in 
+	      match ot with 
+		| None -> ids, mt ()
+		| Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" 
+		| Some t -> ids, str "=" ++ spc () ++ pp_type false l t 
+	  in 
+	  hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def)
+
+let rec pp_specif mpl = function 
+  | (_,Spec s) -> pp_spec mpl s 
+  | (l,Smodule mt) -> 
+      hov 1 
+	(str "module " ++ 
+	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt)
+  | (l,Smodtype mt) -> 
+      hov 1
+	(str "module type " ++
+	 P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " = " ++ fnl () ++ pp_module_type mpl None mt)
+
+and pp_module_type mpl ol = function 
+  | MTident kn -> 
+      let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l)) 
+  | MTfunsig (mbid, mt, mt') -> 
+      str "functor (" ++ 
+      P.pp_module mpl (MPbound mbid) ++
+      str ":" ++
+      pp_module_type mpl None mt ++
+      str ") ->" ++ fnl () ++
+      pp_module_type mpl None mt'
+  | MTsig (msid, sign) ->
+      let mpl = match ol, mpl with 
+	| None, _ -> (MPself msid) :: mpl
+	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
+	| _ -> assert false 
+      in
+      let l = map_succeed (pp_specif mpl) sign in 
+      str "sig " ++ fnl () ++ 
+      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
+      fnl () ++ str "end"
+
+let is_short = function MEident _ | MEapply _ -> true | _ -> false
+
+let rec pp_structure_elem mpl = function 
+  | (_,SEdecl d) -> pp_decl mpl d
+  | (l,SEmodule m) ->
+      hov 1 
+	(str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ 
+	 (* if you want signatures everywhere: *)
+	 (*i str " :" ++ fnl () ++ i*)
+	 (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
+	 str " = " ++
+	 (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++
+	 pp_module_expr mpl (Some l) m.ml_mod_expr)
+  | (l,SEmodtype m) -> 
+      hov 1 
+	(str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++
+	 str " = " ++ fnl () ++ pp_module_type mpl None m)
+
+and pp_module_expr mpl ol = function 
+  | MEident mp' -> P.pp_module mpl mp'
+  | MEfunctor (mbid, mt, me) -> 
+      str "functor (" ++ 
+      P.pp_module mpl (MPbound mbid) ++
+      str ":" ++
+      pp_module_type mpl None mt ++
+      str ") ->" ++ fnl () ++
+      pp_module_expr mpl None me
+  | MEapply (me, me') -> 
+      pp_module_expr mpl None me ++ str "(" ++ 
+      pp_module_expr mpl None me' ++ str ")"
+  | MEstruct (msid, sel) -> 
+      let mpl = match ol, mpl with 
+	| None, _ -> (MPself msid) :: mpl
+	| Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
+	| _ -> assert false
+      in
+      let l = map_succeed (pp_structure_elem mpl) sel in 
+      str "struct " ++ fnl () ++
+      v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ 
+      fnl () ++ str "end" 
+
+let pp_struct s =
+  let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in 
+  prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s
+
+let pp_signature s = 
+  let pp mp s = pp_specif [mp] s ++ fnl2 () in 
+  prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s
+
+let pp_decl mpl d = 
+  try pp_decl mpl d with Failure "empty phrase" -> mt () 
+
+end
+
+
+
diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli
new file mode 100644
index 00000000..711c15da
--- /dev/null
+++ b/contrib/extraction/ocaml.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: ocaml.mli,v 1.26.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Some utility functions to be reused in module [Haskell]. *)
+
+open Pp
+open Names
+open Libnames
+open Miniml
+
+val cons_cofix : Refset.t ref
+
+val pp_par : bool -> std_ppcmds -> std_ppcmds
+val pp_abst : identifier list -> std_ppcmds
+val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds 
+val pr_binding : identifier list -> std_ppcmds
+
+val rename_id : identifier -> Idset.t -> identifier
+
+val lowercase_id : identifier -> identifier
+val uppercase_id : identifier -> identifier
+
+val pr_upper_id : identifier -> std_ppcmds
+
+type env = identifier list * Idset.t
+
+val rename_vars: Idset.t -> identifier list -> env
+val rename_tvars: Idset.t -> identifier list -> identifier list 
+val push_vars : identifier list -> env -> identifier list * env
+val get_db_name : int -> env -> identifier
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+val preamble_sig : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+(*s Production of Ocaml syntax. We export both a functor to be used for 
+    extraction in the Coq toplevel and a function to extract some 
+    declarations to a file. *)
+
+module Make : functor(P : Mlpp_param) -> Mlpp
+
+
+
+
+
diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml
new file mode 100644
index 00000000..61045304
--- /dev/null
+++ b/contrib/extraction/scheme.ml
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: scheme.ml,v 1.9.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Production of Scheme syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Miniml
+open Mlutil
+open Table
+open Ocaml
+
+(*s Scheme renaming issues. *)
+
+let keywords =     
+  List.fold_right (fun s -> Idset.add (id_of_string s))
+    [ "define"; "let"; "lambda"; "lambdas"; "match-case"; 
+      "apply"; "car"; "cdr"; 
+      "error"; "delay"; "force"; "_"; "__"] 
+    Idset.empty
+
+let preamble _ _ (mldummy,_,_) = 
+  (if mldummy then 
+     str "(define __ (lambda (_) __))" 
+     ++ fnl () ++ fnl()
+   else mt ())
+
+let paren = pp_par true
+
+let pp_abst st = function 
+  | [] -> assert false
+  | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st)
+  | l -> paren 
+	(str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st)
+
+(*s The pretty-printing functor. *)
+
+module Make = functor(P : Mlpp_param) -> struct
+
+let pp_global r = P.pp_global [initial_path] r
+let empty_env () = [], P.globals()
+
+(*s Pretty-printing of expressions.  *)
+
+let rec pp_expr env args = 
+  let apply st = pp_apply st true args in 
+  function
+    | MLrel n -> 
+	let id = get_db_name n env in apply (pr_id id)
+    | MLapp (f,args') ->
+	let stl = List.map (pp_expr env []) args' in
+        pp_expr env (stl @ args) f
+    | MLlam _ as a -> 
+      	let fl,a' = collect_lams a in
+	let fl,env' = push_vars fl env in
+	pp_abst (pp_expr env' [] a') (List.rev fl)
+    | MLletin (id,a1,a2) ->
+	let i,env' = push_vars [id] env in
+	apply 
+	  (hv 0 
+	     (hov 2 
+		(paren 
+		   (str "let " ++ 
+		    paren 
+		      (paren 
+			 (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) 
+		    ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
+    | MLglob r -> 
+	apply (pp_global r)
+    | MLcons (r,args') ->
+	assert (args=[]);
+	let st = 
+	  str "`" ++ 
+	  paren (pp_global r ++ 
+		 (if args' = [] then mt () else (spc () ++ str ",")) ++
+		 prlist_with_sep 
+		   (fun () -> spc () ++ str ",") 
+		   (pp_expr env []) args')
+	in 
+	if Refset.mem r !cons_cofix then 
+	  paren (str "delay " ++ st)
+        else st 
+    | MLcase (t, pv) ->
+	let r,_,_ = pv.(0) in 
+	let e = if Refset.mem r !cons_cofix then 
+	  paren (str "force" ++ spc () ++ pp_expr env [] t)
+	else 
+	  pp_expr env [] t 	
+	in apply (v 3 (paren 
+			 (str "match-case " ++ e ++ fnl () ++ pp_pat env pv)))
+    | MLfix (i,ids,defs) ->
+	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+      	pp_fix env' i (Array.of_list (List.rev ids'),defs) args
+    | MLexn s -> 
+	(* An [MLexn] may be applied, but I don't really care. *)
+	paren (str "absurd")
+    | MLdummy ->
+	str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+    | MLmagic a ->
+	pp_expr env args a
+    | MLaxiom -> paren (str "absurd ;;AXIOM TO BE REALIZED\n")
+	
+
+and pp_one_pat env (r,ids,t) = 
+  let pp_arg id = str "?" ++ pr_id id in 
+  let ids,env' = push_vars (List.rev ids) env in
+  let args = 
+    if ids = [] then mt () 
+    else (str " " ++ prlist_with_sep spc pp_arg (List.rev ids))
+  in 
+  (pp_global r ++ args), (pp_expr env' [] t)
+  
+and pp_pat env pv = 
+  prvect_with_sep fnl  
+    (fun x -> let s1,s2 = pp_one_pat env x in 
+     hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv
+
+(*s names of the functions ([ids]) are already pushed in [env],
+    and passed here just for convenience. *)
+
+and pp_fix env j (ids,bl) args =
+    paren 
+      (str "letrec " ++
+       (v 0 (paren 
+	       (prvect_with_sep fnl
+		  (fun (fi,ti) -> paren ((pr_id fi) ++ (pp_expr env [] ti)))
+		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
+	     fnl () ++
+      	     hov 2 (pp_apply (pr_id (ids.(j))) true args))))
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_decl _ = function
+  | Dind _ -> mt ()
+  | Dtype _ -> mt () 
+  | Dfix (rv, defs,_) ->
+      let ppv = Array.map pp_global rv in 
+      prvect_with_sep fnl 
+	(fun (pi,ti) -> 
+	   hov 2 
+	     (paren (str "define " ++ pi ++ spc () ++ 
+		     (pp_expr (empty_env ()) [] ti)) 
+	      ++ fnl ()))
+	(array_map2 (fun p b -> (p,b)) ppv defs) ++
+      fnl ()
+  | Dterm (r, a, _) ->
+      if is_inline_custom r then mt () 
+      else 
+	hov 2 (paren (str "define " ++ pp_global r ++ spc () ++
+		      pp_expr (empty_env ()) [] a)) ++ fnl ()  ++ fnl ()
+
+let pp_structure_elem mp = function 
+  | (l,SEdecl d) -> pp_decl mp d
+  | (l,SEmodule m) -> 
+      failwith "TODO: Scheme extraction of modules not implemented yet"
+  | (l,SEmodtype m) -> 
+      failwith "TODO: Scheme extraction of modules not implemented yet"
+
+let pp_struct = 
+  prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel)
+
+let pp_signature s = assert false
+
+end
+
diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli
new file mode 100644
index 00000000..6e689a47
--- /dev/null
+++ b/contrib/extraction/scheme.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: scheme.mli,v 1.6.6.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+(*s Some utility functions to be reused in module [Haskell]. *)
+
+open Pp
+open Miniml
+open Names
+
+val keywords : Idset.t
+
+val preamble : 
+  extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds
+
+module Make : functor(P : Mlpp_param) -> Mlpp
+
+
+
+
+
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
new file mode 100644
index 00000000..a65c51a4
--- /dev/null
+++ b/contrib/extraction/table.ml
@@ -0,0 +1,446 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: table.ml,v 1.35.2.1 2004/07/16 19:30:08 herbelin Exp $ i*)
+
+open Names
+open Term
+open Declarations
+open Nameops
+open Summary
+open Libobject
+open Goptions
+open Libnames
+open Util
+open Pp
+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
+    | VarRef _ -> assert false
+
+let current_toplevel () = fst (Lib.current_prefix ())
+
+let rec base_mp = function 
+  | MPdot (mp,l) -> base_mp mp 
+  | mp -> mp 
+
+let is_modfile = function 
+  | MPfile _ -> true 
+  | _ -> false
+
+let is_toplevel mp = 
+  mp = initial_path || mp = current_toplevel ()
+
+let at_toplevel mp = 
+  is_modfile mp || is_toplevel mp
+
+let visible_kn kn = at_toplevel (base_mp (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 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 
+
+(*s Inductives table. *)
+
+let inductives = ref (KNmap.empty : ml_ind KNmap.t)
+let init_inductives () = inductives := KNmap.empty
+let add_ind kn m = inductives := KNmap.add kn m !inductives
+let lookup_ind kn = KNmap.find kn !inductives
+
+(*s Recursors table. *)
+
+let recursors = ref KNset.empty
+let init_recursors () = recursors := KNset.empty
+
+let add_recursors env kn = 
+  let make_kn id = make_kn (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))
+    mib.mind_packets
+
+let is_recursor = function 
+  | ConstRef kn -> KNset.mem kn !recursors
+  | _ -> false
+
+(*s Record tables. *)
+
+let records = ref (KNmap.empty : global_reference list KNmap.t)
+let init_records () = records := KNmap.empty
+
+let projs = ref (Refmap.empty : int Refmap.t)
+let init_projs () = projs := Refmap.empty
+
+let add_record kn n (l1,l2) = 
+  records := KNmap.add kn l1 !records; 
+  projs := List.fold_right (fun r -> Refmap.add r n) l2 !projs
+
+let find_projections kn = KNmap.find kn !records
+let is_projection r = Refmap.mem r !projs
+let projection_arity r = Refmap.find r !projs
+
+(*s Tables synchronization. *)
+
+let reset_tables () = 
+  init_terms (); init_types (); init_inductives (); init_recursors (); 
+  init_records (); init_projs ()
+
+(*s Printing. *)
+
+(* The following functions work even on objects not in [Global.env ()].
+   WARNING: for inductive objects, an extract_inductive must have been 
+   done before. *)
+
+let id_of_global = function 
+  | ConstRef kn -> let _,_,l = repr_kn 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
+
+let pr_global r = pr_id (id_of_global r)
+
+(*S Warning and Error messages. *)
+
+let err s = errorlabstrm "Extraction" s
+
+let error_axiom_scheme r i = 
+  err (str "The type scheme axiom " ++ spc () ++
+       pr_global r ++ spc () ++ str "needs " ++ pr_int 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.")
+
+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.")
+
+let check_inside_module () = 
+  try 
+    ignore (Lib.what_is_opened ()); 
+    Options.if_verbose warning
+      ("Extraction inside an opened module is experimental.\n"^
+       "In case of problem, close it first.\n"); 
+    Pp.flush_all ()
+  with Not_found -> ()
+
+let check_inside_section () = 
+  if Lib.sections_are_opened () then 
+    err (str "You can't do that within a section." ++ fnl () ++
+	 str "Close it and try again.")
+
+let error_constant r = 
+  err (Printer.pr_global r ++ str " is not a constant.") 
+
+let error_inductive r = 
+  err (Printer.pr_global r ++ spc () ++ str "is not an inductive type.")
+
+let error_nb_cons () = 
+  err (str "Not the right number of constructors.")
+
+let error_module_clash s = 
+  err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ 
+       str "This is not allowed in ML. Please do some renaming first.")
+
+let error_unknown_module m = 
+  err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") 
+
+let error_toplevel () = 
+  err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++
+       str "You should use Extraction Language Ocaml or Haskell before.") 
+
+let error_scheme () = 
+  err (str "No Scheme modular extraction available yet.")
+
+let error_not_visible r = 
+  err (Printer.pr_global r ++ str " is not directly visible.\n" ++
+       str "For example, it may be inside an applied functor." ++
+       str "Use Recursive Extraction to get the whole environment.")
+
+let error_unqualified_name s1 s2 = 
+  err (str (s1 ^ " is used in " ^ s2 ^ " where it cannot be disambiguated\n" ^
+	    "in ML from another name sharing the same basename.\n"  ^
+	    "Please do some renaming.\n"))
+
+let error_MPfile_as_mod d = 
+  err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^
+	    "Extraction cannot currently deal with this situation.\n"))
+
+(*S The Extraction auxiliary commands *)
+
+(*s Extraction AutoInline *)
+
+let auto_inline_ref = ref true
+
+let auto_inline () = !auto_inline_ref
+
+let _ = declare_bool_option 
+	  {optsync = true;
+	   optname = "Extraction AutoInline";
+	   optkey = SecondaryTable ("Extraction", "AutoInline");
+	   optread = auto_inline; 
+	   optwrite = (:=) auto_inline_ref}
+
+
+(*s Extraction Optimize *)
+
+type opt_flag = 
+    { opt_kill_dum : bool; (* 1 *) 
+      opt_fix_fun : bool;   (* 2 *)
+      opt_case_iot : bool;  (* 4 *)
+      opt_case_idr : bool;  (* 8 *)
+      opt_case_idg : bool;  (* 16 *)
+      opt_case_cst : bool;  (* 32 *)
+      opt_case_fun : bool;  (* 64 *)
+      opt_case_app : bool;  (* 128 *)
+      opt_let_app : bool;   (* 256 *)
+      opt_lin_let : bool;   (* 512 *)
+      opt_lin_beta : bool } (* 1024 *)
+
+let kth_digit n k = (n land (1 lsl k) <> 0)
+
+let flag_of_int n = 
+    { opt_kill_dum = kth_digit n 0;
+      opt_fix_fun = kth_digit n 1;
+      opt_case_iot = kth_digit n 2;
+      opt_case_idr = kth_digit n 3;
+      opt_case_idg = kth_digit n 4; 
+      opt_case_cst = kth_digit n 5;
+      opt_case_fun = kth_digit n 6;
+      opt_case_app = kth_digit n 7;
+      opt_let_app = kth_digit n 8;
+      opt_lin_let = kth_digit n 9;
+      opt_lin_beta = kth_digit n 10 }
+
+(* For the moment, we allow by default everything except the type-unsafe 
+   optimization [opt_case_idg]. *)
+
+let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024
+
+let int_flag_ref = ref int_flag_init
+let opt_flag_ref = ref (flag_of_int int_flag_init)
+
+let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n
+
+let optims () = !opt_flag_ref
+
+let _ = declare_bool_option 
+	  {optsync = true; 
+	   optname = "Extraction Optimize";
+	   optkey = SecondaryTable ("Extraction", "Optimize");
+	   optread = (fun () -> !int_flag_ref <> 0); 
+	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
+
+let _ = declare_int_option
+          { optsync = true;
+            optname = "Extraction Flag";
+            optkey = SecondaryTable("Extraction","Flag"); 
+            optread = (fun _ -> Some !int_flag_ref); 
+            optwrite = (function 
+                          | None -> chg_flag 0
+                          | Some i -> chg_flag (max i 0))}
+
+
+(*s Extraction Lang *)
+
+type lang = Ocaml | Haskell | Scheme | Toplevel
+
+let lang_ref = ref Ocaml
+
+let lang () = !lang_ref
+
+let (extr_lang,_) = 
+  declare_object 
+    {(default_object "Extraction Lang") with  
+       cache_function = (fun (_,l) -> lang_ref := l);
+       load_function = (fun _ (_,l) -> lang_ref := l);
+       export_function = (fun x -> Some x)}
+
+let _ = declare_summary "Extraction Lang" 
+	  { freeze_function = (fun () -> !lang_ref);
+	    unfreeze_function = ((:=) lang_ref);
+	    init_function = (fun () -> lang_ref := Ocaml);
+	    survive_module = false;
+	    survive_section = true }  
+	  
+let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
+
+
+(*s Extraction Inline/NoInline *)
+
+let empty_inline_table = (Refset.empty,Refset.empty)
+
+let inline_table = ref empty_inline_table
+
+let to_inline r = Refset.mem r (fst !inline_table)
+
+let to_keep r = Refset.mem r (snd !inline_table)
+
+let add_inline_entries b l = 
+  let f b = if b then Refset.add else Refset.remove in 
+  let i,k = !inline_table in 
+  inline_table := 
+  (List.fold_right (f b) l i), 
+  (List.fold_right (f (not b)) l k)
+
+(* Registration of operations for rollback. *)
+
+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))) }
+
+let _ = declare_summary "Extraction Inline"
+	  { freeze_function = (fun () -> !inline_table);
+	    unfreeze_function = ((:=) inline_table);
+	    init_function = (fun () -> inline_table := empty_inline_table);
+	    survive_module = false;
+	    survive_section = true }
+
+(* Grammar entries. *)
+
+let extraction_inline b l =
+  check_inside_section (); 
+  check_inside_module ();
+  let refs = List.map Nametab.global l in 
+  List.iter 
+    (fun r -> match r with 
+       | ConstRef _ -> ()
+       | _ -> error_constant r) refs; 
+  Lib.add_anonymous_leaf (inline_extraction (b,refs))
+
+(* Printing part *)
+
+let print_extraction_inline () = 
+  let (i,n)= !inline_table in 
+  let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in 
+  msg 
+    (str "Extraction Inline:" ++ fnl () ++ 
+     Refset.fold
+       (fun r p -> 
+	  (p ++ str "   " ++ Printer.pr_global r ++ fnl ())) i' (mt ()) ++
+     str "Extraction NoInline:" ++ fnl () ++ 
+     Refset.fold
+       (fun r p -> 
+	  (p ++ str "   " ++ Printer.pr_global r ++ fnl ())) n (mt ()))
+
+(* Reset part *)
+
+let (reset_inline,_) = 
+  declare_object
+    {(default_object "Reset Extraction Inline") with  
+       cache_function = (fun (_,_)-> inline_table :=  empty_inline_table);
+       load_function = (fun _ (_,_)-> inline_table :=  empty_inline_table); 
+       export_function = (fun x -> Some x)}
+
+let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
+
+
+(*s Extract Constant/Inductive. *)
+
+(* UGLY HACK: to be defined in [extraction.ml] *)
+let use_type_scheme_nb_args, register_type_scheme_nb_args = 
+  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r 
+
+let customs = ref Refmap.empty
+
+let add_custom r ids s = customs := Refmap.add r (ids,s) !customs
+
+let is_custom r = Refmap.mem r !customs
+
+let is_inline_custom r = (is_custom r) && (to_inline r) 
+
+let find_custom r = snd (Refmap.find r !customs)
+
+let find_type_custom r = Refmap.find r !customs
+
+(* Registration of operations for rollback. *)
+
+let (in_customs,_) = 
+  declare_object 
+    {(default_object "ML extractions") with 
+       cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
+       load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s);
+       export_function = (fun x -> Some x)}
+
+let _ = declare_summary "ML extractions"
+	  { freeze_function = (fun () -> !customs);
+	    unfreeze_function = ((:=) customs);
+	    init_function = (fun () -> customs := Refmap.empty);
+	    survive_module = false;
+	    survive_section = true }
+
+(* Grammar entries. *)
+
+let extract_constant_inline inline r ids s =
+  check_inside_section ();
+  check_inside_module ();
+  let g = Nametab.global r in 
+  match g with 
+    | ConstRef kn -> 
+	let env = Global.env () in 
+	let typ = Environ.constant_type env kn in 
+	let typ = Reduction.whd_betadeltaiota env typ in
+	if Reduction.is_arity env typ 
+	  then begin 
+	    let nargs = use_type_scheme_nb_args env typ in 
+	    if List.length ids <> nargs then error_axiom_scheme g nargs
+	  end; 
+	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
+	Lib.add_anonymous_leaf (in_customs (g,ids,s))
+    | _ -> error_constant g
+
+
+let extract_inductive r (s,l) =
+  check_inside_section ();
+  check_inside_module ();
+  let g = Nametab.global r in 
+  match g with
+    | IndRef ((kn,i) as ip) ->
+	let mib = Global.lookup_mind kn in
+	let n = Array.length mib.mind_packets.(i).mind_consnames in
+	if n <> List.length l then error_nb_cons (); 
+	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+	Lib.add_anonymous_leaf (in_customs (g,[],s));
+	list_iter_i
+	  (fun j s -> 
+	     let g = ConstructRef (ip,succ j) in 
+	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+	     Lib.add_anonymous_leaf (in_customs (g,[],s))) l
+    | _ -> error_inductive g 
+
+
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
new file mode 100644
index 00000000..680638e5
--- /dev/null
+++ b/contrib/extraction/table.mli
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: table.mli,v 1.25.2.1 2004/07/16 19:30:09 herbelin Exp $ i*)
+
+open Names
+open Libnames
+open Miniml
+
+val id_of_global : global_reference -> identifier
+
+(*s Warning and Error messages. *)
+
+val error_axiom_scheme : global_reference -> int -> 'a
+val warning_info_ax : global_reference -> unit
+val warning_log_ax : global_reference -> unit
+val error_constant : global_reference -> 'a
+val error_inductive : global_reference -> 'a
+val error_nb_cons : unit -> 'a
+val error_module_clash : string -> 'a 
+val error_unknown_module : qualid -> 'a
+val error_toplevel : unit -> 'a
+val error_scheme : unit -> 'a
+val error_not_visible : global_reference -> 'a
+val error_unqualified_name : string -> string -> 'a 
+val error_MPfile_as_mod : dir_path -> 'a
+
+val check_inside_module : unit -> unit
+val check_inside_section : unit -> unit
+
+(*s utilities concerning [module_path]. *)
+
+val kn_of_r : global_reference -> kernel_name
+
+val current_toplevel : unit -> module_path
+val base_mp : module_path -> module_path
+val is_modfile : module_path -> bool 
+val is_toplevel : module_path -> bool
+val at_toplevel : module_path -> bool 
+val visible_kn : kernel_name -> bool
+
+(*s Some table-related operations *)
+
+val add_term : kernel_name -> ml_decl -> unit
+val lookup_term : kernel_name -> ml_decl
+
+val add_type : kernel_name -> ml_schema -> unit
+val lookup_type : kernel_name -> ml_schema
+
+val add_ind : kernel_name -> ml_ind -> unit
+val lookup_ind : kernel_name -> ml_ind
+
+val add_recursors : Environ.env -> kernel_name -> unit
+val is_recursor : global_reference -> bool 
+
+val add_record : 
+  kernel_name -> int -> global_reference list * global_reference list -> unit
+val find_projections : kernel_name -> global_reference list
+val is_projection : global_reference -> bool 
+val projection_arity : global_reference -> int
+
+val reset_tables : unit -> unit
+
+(*s AutoInline parameter *) 
+
+val auto_inline : unit -> bool
+
+(*s Optimize parameter *) 
+
+type opt_flag = 
+    { opt_kill_dum : bool; (* 1 *) 
+      opt_fix_fun : bool;   (* 2 *)
+      opt_case_iot : bool;  (* 4 *)
+      opt_case_idr : bool;  (* 8 *)
+      opt_case_idg : bool;  (* 16 *)
+      opt_case_cst : bool;  (* 32 *)
+      opt_case_fun : bool;  (* 64 *)
+      opt_case_app : bool;  (* 128 *)
+      opt_let_app : bool;   (* 256 *)
+      opt_lin_let : bool;   (* 512 *)
+      opt_lin_beta : bool } (* 1024 *)
+
+val optims :  unit -> opt_flag
+
+(*s Target language. *)
+
+type lang = Ocaml | Haskell | Scheme | Toplevel
+val lang : unit -> lang 
+
+(*s Table for custom inlining *) 
+
+val to_inline : global_reference -> bool
+val to_keep : global_reference -> bool
+
+(*s Table for user-given custom ML extractions. *)
+
+(* UGLY HACK: registration of a function defined in [extraction.ml] *)
+val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
+
+val is_custom : global_reference -> bool
+val is_inline_custom : global_reference -> bool
+val find_custom : global_reference -> string
+val find_type_custom : global_reference -> string list * string
+
+(*s Extraction commands. *)
+
+val extraction_language : lang -> unit
+val extraction_inline : bool -> reference list -> unit
+val print_extraction_inline : unit -> unit
+val reset_extraction_inline : unit -> unit
+val extract_constant_inline : 
+  bool -> reference -> string list -> string -> unit
+val extract_inductive : reference -> string * string list -> unit
+
+
+
+
diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend
new file mode 100644
index 00000000..641b50a7
--- /dev/null
+++ b/contrib/extraction/test/.depend
@@ -0,0 +1,713 @@
+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.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.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.cmi 
+theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.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/euclid.cmi 
+theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/euclid.cmi 
+theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/even.cmi 
+theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.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/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.cmi 
+theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \
+    theories/Arith/max.cmi 
+theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Arith/min.cmi 
+theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.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.cmi 
+theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.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/plus.cmi 
+theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.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/bool.cmi 
+theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.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/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/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi 
+theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.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/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 
+theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi 
+theories/Init/prelude.cmo: theories/Init/prelude.cmi 
+theories/Init/prelude.cmx: theories/Init/prelude.cmi 
+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/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/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/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/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/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.cmi 
+theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \
+    theories/Lists/list.cmi 
+theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.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/monoList.cmo: theories/Init/datatypes.cmi \
+    theories/Lists/monoList.cmi 
+theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/monoList.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.cmi 
+theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \
+    theories/Lists/list.cmx theories/Init/specif.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/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/classicalFacts.cmo: theories/Logic/classicalFacts.cmi 
+theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi 
+theories/Logic/classical.cmo: theories/Logic/classical.cmi 
+theories/Logic/classical.cmx: theories/Logic/classical.cmi 
+theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi 
+theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi 
+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_Type.cmo: theories/Logic/classical_Type.cmi 
+theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.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/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/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/nArith.cmo: theories/NArith/nArith.cmi 
+theories/NArith/nArith.cmx: theories/NArith/nArith.cmi 
+theories/NArith/pnat.cmo: theories/NArith/pnat.cmi 
+theories/NArith/pnat.cmx: theories/NArith/pnat.cmi 
+theories/Relations/newman.cmo: theories/Relations/newman.cmi 
+theories/Relations/newman.cmx: theories/Relations/newman.cmi 
+theories/Relations/operators_Properties.cmo: \
+    theories/Relations/operators_Properties.cmi 
+theories/Relations/operators_Properties.cmx: \
+    theories/Relations/operators_Properties.cmi 
+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/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/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 
+theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi 
+theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi 
+theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi 
+theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi 
+theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi 
+theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi 
+theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi 
+theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi 
+theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi 
+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/permut.cmo: theories/Sets/permut.cmi 
+theories/Sets/permut.cmx: theories/Sets/permut.cmi 
+theories/Sets/powerset_Classical_facts.cmo: \
+    theories/Sets/powerset_Classical_facts.cmi 
+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/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 
+theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi 
+theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi 
+theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi 
+theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi 
+theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi 
+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/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.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/Wellfounded/disjoint_Union.cmo: \
+    theories/Wellfounded/disjoint_Union.cmi 
+theories/Wellfounded/disjoint_Union.cmx: \
+    theories/Wellfounded/disjoint_Union.cmi 
+theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi 
+theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi 
+theories/Wellfounded/inverse_Image.cmo: \
+    theories/Wellfounded/inverse_Image.cmi 
+theories/Wellfounded/inverse_Image.cmx: \
+    theories/Wellfounded/inverse_Image.cmi 
+theories/Wellfounded/lexicographic_Exponentiation.cmo: \
+    theories/Wellfounded/lexicographic_Exponentiation.cmi 
+theories/Wellfounded/lexicographic_Exponentiation.cmx: \
+    theories/Wellfounded/lexicographic_Exponentiation.cmi 
+theories/Wellfounded/lexicographic_Product.cmo: \
+    theories/Wellfounded/lexicographic_Product.cmi 
+theories/Wellfounded/lexicographic_Product.cmx: \
+    theories/Wellfounded/lexicographic_Product.cmi 
+theories/Wellfounded/transitive_Closure.cmo: \
+    theories/Wellfounded/transitive_Closure.cmi 
+theories/Wellfounded/transitive_Closure.cmx: \
+    theories/Wellfounded/transitive_Closure.cmi 
+theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi 
+theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi 
+theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi 
+theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi 
+theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \
+    theories/Wellfounded/well_Ordering.cmi 
+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.cmi 
+theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.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/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.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.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.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/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/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/zmisc.cmi 
+theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \
+    theories/NArith/binPos.cmx theories/Init/datatypes.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/zorder.cmi 
+theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \
+    theories/Init/datatypes.cmx theories/Init/specif.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/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/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/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/zerob.cmi: theories/Init/datatypes.cmi 
+theories/Init/logic_Type.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/Lists/monoList.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/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/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/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 
diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile
new file mode 100644
index 00000000..c9bb5623
--- /dev/null
+++ b/contrib/extraction/test/Makefile
@@ -0,0 +1,109 @@
+# 
+#	General variables
+#
+
+TOPDIR=../../..
+
+# Files with axioms to be realized: can't be extracted directly
+
+AXIOMSVO:= \
+theories/Reals/% \
+theories/Num/%
+
+DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
+
+INCL:= $(patsubst %,-I %,$(DIRS))
+
+VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
+
+VO:= $(filter-out $(AXIOMSVO),$(VO))
+
+ML:= $(shell test -x v2ml && ./v2ml $(VO))
+
+MLI:= $(patsubst %.ml,%.mli,$(ML))
+
+CMO:= $(patsubst %.ml,%.cmo,$(ML))
+
+OSTDLIB:=$(shell (ocamlc -where))
+
+#
+#	General rules 
+#
+
+all: v2ml ml $(MLI) $(CMO)
+
+ml: $(ML)
+
+depend: $(ML)
+	rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend
+
+tree:
+	mkdir -p $(DIRS)
+	cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories
+
+#%.mli:%.ml
+#	./make_mli $< > $@
+
+%.cmi:%.mli
+	ocamlc -c $(INCL) -nostdlib $<
+
+%.cmo:%.ml
+	ocamlc -c $(INCL) -nostdlib $<
+
+$(ML): ml2v
+	./extract $@
+
+clean: 
+	rm -f theories/*/*.ml* theories/*/*.cm*
+
+
+#
+#	Utilities
+#
+
+open: 
+	find theories -name "*".ml -exec ./qualify2open \{\} \;
+
+undo_open: 
+	find theories -name "*".ml -exec mv \{\}.orig \{\} \;
+
+ml2v: ml2v.ml
+	ocamlopt -o $@ $<
+
+v2ml: v2ml.ml
+	ocamlopt -o $@ $< 
+	$(MAKE)
+
+#
+#	Extraction of Reals
+#
+
+
+REALSAXIOMSVO:=theories/Reals/Rsyntax.vo
+
+REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo)
+REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO))
+REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO))
+REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML))
+
+reals: all realsml theories/Reals/addReals.cmo $(REALSCMO)
+
+realsml: $(REALSML)
+
+theories/Reals/addReals.ml: 
+	cp -f addReals theories/Reals/addReals.ml
+
+$(REALSML): 
+	./extract $@
+
+
+#
+#	The End
+#
+
+.PHONY: all tree clean reals realsml depend
+
+include .depend
+
+
+
diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell
new file mode 100644
index 00000000..6e1e15d1
--- /dev/null
+++ b/contrib/extraction/test/Makefile.haskell
@@ -0,0 +1,416 @@
+# 
+#	General variables
+#
+
+TOPDIR=../../..
+
+# Files with axioms to be realized: can't be extracted directly
+
+AXIOMSVO:= \
+theories/Init/Prelude.vo \
+theories/Reals/% \
+theories/Num/%
+
+DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
+
+INCL:= $(patsubst %,-i%,$(DIRS))
+
+VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
+
+VO:= $(filter-out $(AXIOMSVO),$(VO))
+
+HS:= $(shell test -x v2hs && ./v2hs $(VO))
+
+O:= $(patsubst %.hs,%.o,$(HS))
+
+#
+#	General rules 
+#
+
+all: v2hs hs $(O)
+
+hs: $(HS)
+
+tree:
+	mkdir -p $(DIRS)
+
+%.o:%.hs
+	ghc $(INCL) -c $<
+
+$(HS): hs2v
+	./extract.haskell $@
+
+clean: 
+	rm -f theories/*/*.h* theories/*/*.o
+
+
+#
+#	Utilities
+#
+
+hs2v: hs2v.ml
+	ocamlc -o $@ $<
+
+v2hs: v2hs.ml
+	ocamlc -o $@ $< 
+	$(MAKE) -f Makefile.haskell
+
+
+#
+#	The End
+#
+
+.PHONY: all tree clean depend
+
+# DO NOT DELETE: Beginning of Haskell dependencies
+theories/Arith/Between.o : theories/Arith/Between.hs
+theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs
+theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o
+theories/Arith/Bool_nat.o : theories/Init/Specif.o
+theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o
+theories/Arith/Bool_nat.o : theories/Init/Datatypes.o
+theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o
+theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs
+theories/Arith/Compare_dec.o : theories/Init/Specif.o
+theories/Arith/Compare_dec.o : theories/Init/Logic.o
+theories/Arith/Compare_dec.o : theories/Init/Datatypes.o
+theories/Arith/Compare.o : theories/Arith/Compare.hs
+theories/Arith/Compare.o : theories/Init/Specif.o
+theories/Arith/Compare.o : theories/Init/Datatypes.o
+theories/Arith/Compare.o : theories/Arith/Compare_dec.o
+theories/Arith/Div2.o : theories/Arith/Div2.hs
+theories/Arith/Div2.o : theories/Init/Specif.o
+theories/Arith/Div2.o : theories/Init/Peano.o
+theories/Arith/Div2.o : theories/Init/Datatypes.o
+theories/Arith/EqNat.o : theories/Arith/EqNat.hs
+theories/Arith/EqNat.o : theories/Init/Specif.o
+theories/Arith/EqNat.o : theories/Init/Datatypes.o
+theories/Arith/Euclid.o : theories/Arith/Euclid.hs
+theories/Arith/Euclid.o : theories/Arith/Wf_nat.o
+theories/Arith/Euclid.o : theories/Init/Specif.o
+theories/Arith/Euclid.o : theories/Arith/Minus.o
+theories/Arith/Euclid.o : theories/Init/Datatypes.o
+theories/Arith/Euclid.o : theories/Arith/Compare_dec.o
+theories/Arith/Even.o : theories/Arith/Even.hs
+theories/Arith/Even.o : theories/Init/Specif.o
+theories/Arith/Even.o : theories/Init/Datatypes.o
+theories/Arith/Gt.o : theories/Arith/Gt.hs
+theories/Arith/Le.o : theories/Arith/Le.hs
+theories/Arith/Lt.o : theories/Arith/Lt.hs
+theories/Arith/Max.o : theories/Arith/Max.hs
+theories/Arith/Max.o : theories/Init/Specif.o
+theories/Arith/Max.o : theories/Init/Logic.o
+theories/Arith/Max.o : theories/Init/Datatypes.o
+theories/Arith/Min.o : theories/Arith/Min.hs
+theories/Arith/Min.o : theories/Init/Specif.o
+theories/Arith/Min.o : theories/Init/Logic.o
+theories/Arith/Min.o : theories/Init/Datatypes.o
+theories/Arith/Minus.o : theories/Arith/Minus.hs
+theories/Arith/Minus.o : theories/Init/Datatypes.o
+theories/Arith/Mult.o : theories/Arith/Mult.hs
+theories/Arith/Mult.o : theories/Arith/Plus.o
+theories/Arith/Mult.o : theories/Init/Datatypes.o
+theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs
+theories/Arith/Peano_dec.o : theories/Init/Specif.o
+theories/Arith/Peano_dec.o : theories/Init/Datatypes.o
+theories/Arith/Plus.o : theories/Arith/Plus.hs
+theories/Arith/Plus.o : theories/Init/Specif.o
+theories/Arith/Plus.o : theories/Init/Logic.o
+theories/Arith/Plus.o : theories/Init/Datatypes.o
+theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs
+theories/Arith/Wf_nat.o : theories/Init/Wf.o
+theories/Arith/Wf_nat.o : theories/Init/Logic.o
+theories/Arith/Wf_nat.o : theories/Init/Datatypes.o
+theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs
+theories/Bool/BoolEq.o : theories/Init/Specif.o
+theories/Bool/BoolEq.o : theories/Init/Datatypes.o
+theories/Bool/Bool.o : theories/Bool/Bool.hs
+theories/Bool/Bool.o : theories/Init/Specif.o
+theories/Bool/Bool.o : theories/Init/Datatypes.o
+theories/Bool/DecBool.o : theories/Bool/DecBool.hs
+theories/Bool/DecBool.o : theories/Init/Specif.o
+theories/Bool/IfProp.o : theories/Bool/IfProp.hs
+theories/Bool/IfProp.o : theories/Init/Specif.o
+theories/Bool/IfProp.o : theories/Init/Datatypes.o
+theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs
+theories/Bool/Sumbool.o : theories/Init/Specif.o
+theories/Bool/Sumbool.o : theories/Init/Datatypes.o
+theories/Bool/Zerob.o : theories/Bool/Zerob.hs
+theories/Bool/Zerob.o : theories/Init/Datatypes.o
+theories/Init/Datatypes.o : theories/Init/Datatypes.hs
+theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs
+theories/Init/Logic.o : theories/Init/Logic.hs
+theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs
+theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs
+theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs
+theories/Init/Peano.o : theories/Init/Peano.hs
+theories/Init/Peano.o : theories/Init/Datatypes.o
+theories/Init/Specif.o : theories/Init/Specif.hs
+theories/Init/Specif.o : theories/Init/Logic.o
+theories/Init/Specif.o : theories/Init/Datatypes.o
+theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs
+theories/Init/Wf.o : theories/Init/Wf.hs
+theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs
+theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o
+theories/IntMap/Adalloc.o : theories/Init/Specif.o
+theories/IntMap/Adalloc.o : theories/IntMap/Map.o
+theories/IntMap/Adalloc.o : theories/Init/Logic.o
+theories/IntMap/Adalloc.o : theories/Init/Datatypes.o
+theories/IntMap/Adalloc.o : theories/IntMap/Addr.o
+theories/IntMap/Adalloc.o : theories/IntMap/Addec.o
+theories/IntMap/Addec.o : theories/IntMap/Addec.hs
+theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Addec.o : theories/Bool/Sumbool.o
+theories/IntMap/Addec.o : theories/Init/Specif.o
+theories/IntMap/Addec.o : theories/Init/Datatypes.o
+theories/IntMap/Addec.o : theories/IntMap/Addr.o
+theories/IntMap/Addr.o : theories/IntMap/Addr.hs
+theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Addr.o : theories/Init/Specif.o
+theories/IntMap/Addr.o : theories/Init/Datatypes.o
+theories/IntMap/Addr.o : theories/Bool/Bool.o
+theories/IntMap/Adist.o : theories/IntMap/Adist.hs
+theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Adist.o : theories/Arith/Min.o
+theories/IntMap/Adist.o : theories/Init/Datatypes.o
+theories/IntMap/Adist.o : theories/IntMap/Addr.o
+theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs
+theories/IntMap/Fset.o : theories/IntMap/Fset.hs
+theories/IntMap/Fset.o : theories/Init/Specif.o
+theories/IntMap/Fset.o : theories/IntMap/Map.o
+theories/IntMap/Fset.o : theories/Init/Logic.o
+theories/IntMap/Fset.o : theories/Init/Datatypes.o
+theories/IntMap/Fset.o : theories/IntMap/Addr.o
+theories/IntMap/Fset.o : theories/IntMap/Addec.o
+theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs
+theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Lsort.o : theories/Bool/Sumbool.o
+theories/IntMap/Lsort.o : theories/Init/Specif.o
+theories/IntMap/Lsort.o : theories/Lists/PolyList.o
+theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o
+theories/IntMap/Lsort.o : theories/IntMap/Map.o
+theories/IntMap/Lsort.o : theories/Init/Logic.o
+theories/IntMap/Lsort.o : theories/Init/Datatypes.o
+theories/IntMap/Lsort.o : theories/Bool/Bool.o
+theories/IntMap/Lsort.o : theories/IntMap/Addr.o
+theories/IntMap/Lsort.o : theories/IntMap/Addec.o
+theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs
+theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs
+theories/IntMap/Mapcanon.o : theories/Init/Specif.o
+theories/IntMap/Mapcanon.o : theories/IntMap/Map.o
+theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs
+theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o
+theories/IntMap/Mapcard.o : theories/Init/Specif.o
+theories/IntMap/Mapcard.o : theories/Arith/Plus.o
+theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o
+theories/IntMap/Mapcard.o : theories/Init/Peano.o
+theories/IntMap/Mapcard.o : theories/IntMap/Map.o
+theories/IntMap/Mapcard.o : theories/Init/Logic.o
+theories/IntMap/Mapcard.o : theories/Init/Datatypes.o
+theories/IntMap/Mapcard.o : theories/IntMap/Addr.o
+theories/IntMap/Mapcard.o : theories/IntMap/Addec.o
+theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs
+theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs
+theories/IntMap/Mapfold.o : theories/Init/Specif.o
+theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o
+theories/IntMap/Mapfold.o : theories/IntMap/Map.o
+theories/IntMap/Mapfold.o : theories/Init/Logic.o
+theories/IntMap/Mapfold.o : theories/IntMap/Fset.o
+theories/IntMap/Mapfold.o : theories/Init/Datatypes.o
+theories/IntMap/Mapfold.o : theories/IntMap/Addr.o
+theories/IntMap/Map.o : theories/IntMap/Map.hs
+theories/IntMap/Map.o : theories/ZArith/Fast_integer.o
+theories/IntMap/Map.o : theories/Init/Specif.o
+theories/IntMap/Map.o : theories/Init/Peano.o
+theories/IntMap/Map.o : theories/Init/Datatypes.o
+theories/IntMap/Map.o : theories/IntMap/Addr.o
+theories/IntMap/Map.o : theories/IntMap/Addec.o
+theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs
+theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o
+theories/IntMap/Mapiter.o : theories/Init/Specif.o
+theories/IntMap/Mapiter.o : theories/Lists/PolyList.o
+theories/IntMap/Mapiter.o : theories/IntMap/Map.o
+theories/IntMap/Mapiter.o : theories/Init/Logic.o
+theories/IntMap/Mapiter.o : theories/Init/Datatypes.o
+theories/IntMap/Mapiter.o : theories/IntMap/Addr.o
+theories/IntMap/Mapiter.o : theories/IntMap/Addec.o
+theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs
+theories/IntMap/Maplists.o : theories/Bool/Sumbool.o
+theories/IntMap/Maplists.o : theories/Init/Specif.o
+theories/IntMap/Maplists.o : theories/Lists/PolyList.o
+theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o
+theories/IntMap/Maplists.o : theories/IntMap/Map.o
+theories/IntMap/Maplists.o : theories/Init/Logic.o
+theories/IntMap/Maplists.o : theories/IntMap/Fset.o
+theories/IntMap/Maplists.o : theories/Init/Datatypes.o
+theories/IntMap/Maplists.o : theories/Bool/Bool.o
+theories/IntMap/Maplists.o : theories/IntMap/Addr.o
+theories/IntMap/Maplists.o : theories/IntMap/Addec.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs
+theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Map.o
+theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o
+theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o
+theories/IntMap/Mapsubset.o : theories/Bool/Bool.o
+theories/Lists/ListSet.o : theories/Lists/ListSet.hs
+theories/Lists/ListSet.o : theories/Init/Specif.o
+theories/Lists/ListSet.o : theories/Lists/PolyList.o
+theories/Lists/ListSet.o : theories/Init/Logic.o
+theories/Lists/ListSet.o : theories/Init/Datatypes.o
+theories/Lists/PolyList.o : theories/Lists/PolyList.hs
+theories/Lists/PolyList.o : theories/Init/Specif.o
+theories/Lists/PolyList.o : theories/Init/Datatypes.o
+theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs
+theories/Lists/Streams.o : theories/Lists/Streams.hs
+theories/Lists/Streams.o : theories/Init/Datatypes.o
+theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs
+theories/Lists/TheoryList.o : theories/Init/Specif.o
+theories/Lists/TheoryList.o : theories/Lists/PolyList.o
+theories/Lists/TheoryList.o : theories/Bool/DecBool.o
+theories/Lists/TheoryList.o : theories/Init/Datatypes.o
+theories/Logic/Berardi.o : theories/Logic/Berardi.hs
+theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs
+theories/Logic/Classical.o : theories/Logic/Classical.hs
+theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs
+theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs
+theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs
+theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs
+theories/Logic/Decidable.o : theories/Logic/Decidable.hs
+theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs
+theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs
+theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs
+theories/Logic/JMeq.o : theories/Logic/JMeq.hs
+theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs
+theories/Relations/Newman.o : theories/Relations/Newman.hs
+theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs
+theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs
+theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs
+theories/Relations/Relation_Operators.o : theories/Init/Specif.o
+theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o
+theories/Relations/Relations.o : theories/Relations/Relations.hs
+theories/Relations/Rstar.o : theories/Relations/Rstar.hs
+theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs
+theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs
+theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs
+theories/Sets/Cpo.o : theories/Sets/Cpo.hs
+theories/Sets/Cpo.o : theories/Sets/Partial_Order.o
+theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs
+theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs
+theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs
+theories/Sets/Image.o : theories/Sets/Image.hs
+theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs
+theories/Sets/Integers.o : theories/Sets/Integers.hs
+theories/Sets/Integers.o : theories/Sets/Partial_Order.o
+theories/Sets/Integers.o : theories/Init/Datatypes.o
+theories/Sets/Multiset.o : theories/Sets/Multiset.hs
+theories/Sets/Multiset.o : theories/Init/Specif.o
+theories/Sets/Multiset.o : theories/Init/Peano.o
+theories/Sets/Multiset.o : theories/Init/Datatypes.o
+theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs
+theories/Sets/Permut.o : theories/Sets/Permut.hs
+theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs
+theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs
+theories/Sets/Powerset.o : theories/Sets/Powerset.hs
+theories/Sets/Powerset.o : theories/Sets/Partial_Order.o
+theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs
+theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs
+theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs
+theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs
+theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs
+theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs
+theories/Sets/Uniset.o : theories/Sets/Uniset.hs
+theories/Sets/Uniset.o : theories/Init/Specif.o
+theories/Sets/Uniset.o : theories/Init/Datatypes.o
+theories/Sets/Uniset.o : theories/Bool/Bool.o
+theories/Sorting/Heap.o : theories/Sorting/Heap.hs
+theories/Sorting/Heap.o : theories/Init/Specif.o
+theories/Sorting/Heap.o : theories/Sorting/Sorting.o
+theories/Sorting/Heap.o : theories/Lists/PolyList.o
+theories/Sorting/Heap.o : theories/Sets/Multiset.o
+theories/Sorting/Heap.o : theories/Init/Logic.o
+theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs
+theories/Sorting/Permutation.o : theories/Init/Specif.o
+theories/Sorting/Permutation.o : theories/Lists/PolyList.o
+theories/Sorting/Permutation.o : theories/Sets/Multiset.o
+theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs
+theories/Sorting/Sorting.o : theories/Init/Specif.o
+theories/Sorting/Sorting.o : theories/Lists/PolyList.o
+theories/Sorting/Sorting.o : theories/Init/Logic.o
+theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs
+theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs
+theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs
+theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs
+theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs
+theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs
+theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs
+theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs
+theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs
+theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o
+theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o
+theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs
+theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs
+theories/ZArith/Fast_integer.o : theories/Init/Peano.o
+theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o
+theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs
+theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Wf_Z.o : theories/Init/Specif.o
+theories/ZArith/Wf_Z.o : theories/Init/Peano.o
+theories/ZArith/Wf_Z.o : theories/Init/Logic.o
+theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o
+theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs
+theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zarith_aux.o : theories/Init/Specif.o
+theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o
+theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs
+theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs
+theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o
+theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o
+theories/ZArith/ZArith_dec.o : theories/Init/Specif.o
+theories/ZArith/ZArith_dec.o : theories/Init/Logic.o
+theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs
+theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs
+theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zbool.o : theories/Bool/Sumbool.o
+theories/ZArith/Zbool.o : theories/Init/Specif.o
+theories/ZArith/Zbool.o : theories/Init/Datatypes.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs
+theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o
+theories/ZArith/Zcomplements.o : theories/Init/Specif.o
+theories/ZArith/Zcomplements.o : theories/Init/Logic.o
+theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o
+theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs
+theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zdiv.o : theories/Init/Specif.o
+theories/ZArith/Zdiv.o : theories/Init/Logic.o
+theories/ZArith/Zdiv.o : theories/Init/Datatypes.o
+theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs
+theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs
+theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs
+theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zmisc.o : theories/Init/Specif.o
+theories/ZArith/Zmisc.o : theories/Init/Datatypes.o
+theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs
+theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o
+theories/ZArith/Zpower.o : theories/Init/Logic.o
+theories/ZArith/Zpower.o : theories/Init/Datatypes.o
+theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs
+theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o
+theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o
+theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o
+theories/ZArith/Zsqrt.o : theories/Init/Specif.o
+theories/ZArith/Zsqrt.o : theories/Init/Logic.o
+theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs
+# DO NOT DELETE: End of Haskell dependencies
diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals
new file mode 100644
index 00000000..fb73d47b
--- /dev/null
+++ b/contrib/extraction/test/addReals
@@ -0,0 +1,21 @@
+open TypeSyntax
+open Fast_integer
+
+
+let total_order_T x y = 
+if x = y then InleftT RightT
+else if x < y then InleftT LeftT
+else InrightT 
+
+let rec int_to_positive i = 
+	if i = 1 then XH
+	else
+	  if (i mod 2) = 0 then XO (int_to_positive (i/2))
+	  else XI (int_to_positive (i/2))
+
+let rec int_to_Z i = 
+	if i = 0 then ZERO
+	else if i > 0 then POS (int_to_positive i)
+	else NEG (int_to_positive (-i))
+
+let my_ceil x = int_to_Z (succ (int_of_float (floor x)))
diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc
new file mode 100644
index 00000000..0fb556aa
--- /dev/null
+++ b/contrib/extraction/test/custom/Adalloc
@@ -0,0 +1,2 @@
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid
new file mode 100644
index 00000000..a58e3940
--- /dev/null
+++ b/contrib/extraction/test/custom/Euclid
@@ -0,0 +1 @@
+Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec.
diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List
new file mode 100644
index 00000000..ffee7dc9
--- /dev/null
+++ b/contrib/extraction/test/custom/List
@@ -0,0 +1 @@
+Extraction NoInline map.
diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet
new file mode 100644
index 00000000..c9bea52a
--- /dev/null
+++ b/contrib/extraction/test/custom/ListSet
@@ -0,0 +1 @@
+Extraction NoInline set_add set_mem.
diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort
new file mode 100644
index 00000000..6a185683
--- /dev/null
+++ b/contrib/extraction/test/custom/Lsort
@@ -0,0 +1,2 @@
+Require Import Addr. 
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map
new file mode 100644
index 00000000..3e464e39
--- /dev/null
+++ b/contrib/extraction/test/custom/Map
@@ -0,0 +1,3 @@
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
+
diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard
new file mode 100644
index 00000000..ca555aa3
--- /dev/null
+++ b/contrib/extraction/test/custom/Mapcard
@@ -0,0 +1,4 @@
+Require Import Plus.
+Extraction NoInline plus_is_one.
+Require Import Addr.
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter
new file mode 100644
index 00000000..6a185683
--- /dev/null
+++ b/contrib/extraction/test/custom/Mapiter
@@ -0,0 +1,2 @@
+Require Import Addr. 
+Extraction NoInline ad_double ad_double_plus_un.
diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/R_Ifp
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/R_sqr
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Ranalysis
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Raxioms
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rbase
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rbasic_fun
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rdefinitions
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v
new file mode 100644
index 00000000..45d0a224
--- /dev/null
+++ b/contrib/extraction/test/custom/Reals.v
@@ -0,0 +1,17 @@
+Require Import Reals. 
+Extract Inlined Constant R => float.
+Extract Inlined Constant R0 => "0.0".
+Extract Inlined Constant R1 => "1.0".
+Extract Inlined Constant Rplus => "(+.)".
+Extract Inlined Constant Rmult => "( *.)".
+Extract Inlined Constant Ropp => "(~-.)".
+Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)".
+Extract Inlined Constant Rlt => "(<)".
+Extract Inlined Constant up => "AddReals.my_ceil".
+Extract Inlined Constant total_order_T => "AddReals.total_order_T".
+Extract Inlined Constant sqrt => "sqrt".
+Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))".
+Extract Inlined Constant PI => "3.141593".
+Extract Inlined Constant cos => cos.
+Extract Inlined Constant sin => sin.
+Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)".
diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rfunctions
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rgeom
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rlimit
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rseries
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rsigma
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo
new file mode 100644
index 00000000..d8f1b3e7
--- /dev/null
+++ b/contrib/extraction/test/custom/Rtrigo
@@ -0,0 +1,2 @@
+Load "custom/Reals".
+
diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec
new file mode 100644
index 00000000..2201419e
--- /dev/null
+++ b/contrib/extraction/test/custom/ZArith_dec
@@ -0,0 +1 @@
+Extraction Inline Dcompare_inf Zcompare_rec.
diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer
new file mode 100644
index 00000000..e2b24953
--- /dev/null
+++ b/contrib/extraction/test/custom/fast_integer
@@ -0,0 +1 @@
+Extraction NoInline Zero_suivi_de Un_suivi_de.
diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e
new file mode 100644
index 00000000..88b6c90b
--- /dev/null
+++ b/contrib/extraction/test/e
@@ -0,0 +1,17 @@
+
+(* To trace Extraction, you can use this file via:  *)
+(*               Drop. #use "e";;                   *) 
+(*                                                  *)
+
+#use "include";;
+open Extraction;;
+open Miniml;;
+#trace extract_declaration;;
+go();;
+
+
+
+
+
+
+
diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract
new file mode 100755
index 00000000..83444be3
--- /dev/null
+++ b/contrib/extraction/test/extract
@@ -0,0 +1,12 @@
+#!/bin/sh
+rm -f /tmp/extr$$.v 
+vfile=`./ml2v $1`
+d=`dirname $vfile`
+n=`basename $vfile .v`
+if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
+echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v
+../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
+out=$?
+rm -f /tmp/extr$$.v
+exit $out
+
diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell
new file mode 100755
index 00000000..d11bc706
--- /dev/null
+++ b/contrib/extraction/test/extract.haskell
@@ -0,0 +1,12 @@
+#!/bin/sh
+rm -f /tmp/extr$$.v 
+vfile=`./hs2v $1`
+d=`dirname $vfile`
+n=`basename $vfile .v`
+if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi  
+echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v
+../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v 
+out=$?
+rm -f /tmp/extr$$.v
+exit $out
+
diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml
new file mode 100644
index 00000000..fd8b9b26
--- /dev/null
+++ b/contrib/extraction/test/hs2v.ml
@@ -0,0 +1,14 @@
+let _ =
+  for j = 1 to ((Array.length Sys.argv)-1) do
+    let fml = Sys.argv.(j) in
+    let f = Filename.chop_extension fml in 
+    let fv = f ^ ".v" in
+    if Sys.file_exists ("../../../" ^ fv) then
+      print_string (fv^" ") 
+    else
+      let d = Filename.dirname f in
+      let b = String.uncapitalize (Filename.basename f) in
+      let fv = Filename.concat d (b ^ ".v ") in
+      print_string fv
+  done;
+  print_newline()
diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli
new file mode 100755
index 00000000..40ee496e
--- /dev/null
+++ b/contrib/extraction/test/make_mli
@@ -0,0 +1,17 @@
+#!/usr/bin/awk -We $0
+
+{ match($0,"^open") 
+  if (RLENGTH>0) state=1
+  match($0,"^type") 
+  if (RLENGTH>0) state=1 
+  match($0,"^\(\*\* ")
+  if (RLENGTH>0) state=2
+  match($0,"^let")
+  if (RLENGTH>0) state=0
+  match($0,"^and")
+  if ((RLENGTH>0) && (state==2)) state=0
+  if ((RLENGTH>0) && (state==1)) state=1		     
+  gsub("\(\*\* ","")
+  gsub("\*\*\)","")
+  if (state>0) print
+}  
diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml
new file mode 100644
index 00000000..363ea642
--- /dev/null
+++ b/contrib/extraction/test/ml2v.ml
@@ -0,0 +1,14 @@
+let _ =
+  for j = 1 to ((Array.length Sys.argv)-1) do
+    let fml = Sys.argv.(j) in
+    let f = Filename.chop_extension fml in 
+    let fv = f ^ ".v" in
+    if Sys.file_exists ("../../../" ^ fv) then
+      print_string (fv^" ") 
+    else
+      let d = Filename.dirname f in
+      let b = String.capitalize (Filename.basename f) in
+      let fv = Filename.concat d (b ^ ".v ") in
+      print_string fv
+  done;
+  print_newline()
diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml
new file mode 100644
index 00000000..88632875
--- /dev/null
+++ b/contrib/extraction/test/v2hs.ml
@@ -0,0 +1,9 @@
+let _ = 
+  for j = 1 to ((Array.length Sys.argv) -1) do 
+    let s = Sys.argv.(j) in
+    let b = Filename.chop_extension (Filename.basename s) in 
+    let b = String.capitalize b in
+    let d = Filename.dirname s in 
+    print_string (Filename.concat d (b ^ ".hs "))
+  done;	
+  print_newline()
diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml
new file mode 100644
index 00000000..245a1b1e
--- /dev/null
+++ b/contrib/extraction/test/v2ml.ml
@@ -0,0 +1,9 @@
+let _ = 
+  for j = 1 to ((Array.length Sys.argv) -1) do 
+    let s = Sys.argv.(j) in
+    let b = Filename.chop_extension (Filename.basename s) in 
+    let b = String.uncapitalize b in
+    let d = Filename.dirname s in 
+    print_string (Filename.concat d (b ^ ".ml "))
+  done;	
+  print_newline()
diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v
new file mode 100644
index 00000000..0745f62d
--- /dev/null
+++ b/contrib/extraction/test_extraction.v
@@ -0,0 +1,552 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Arith.
+Require Import List.
+
+(*** 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) (_:x <= 0) := S x.
+Extraction NoInline cf.
+Definition test6 := cf 0 (le_n 0).
+Extraction test6.  
+(* let test6 = cf O *)
+
+Definition test7 := (fun (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) := 0.
+Extraction d3. (* let d3 _ = O *)
+Definition d4 := d nat. 
+Extraction d4. (* type d4 = nat d *)
+Definition d5 := (fun x:d Type => 0) Type.  
+Extraction d5.  (* let d5 = O *)
+Definition d6 (x:d Type) := x.
+Extraction d6.  (* type 'x d6 = 'x *)
+
+Definition test8 := (fun (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 := (fun (X:Type) (x:X) => 0) Type Type.
+Extraction test10. (* let test10 = O *)
+
+Definition test11 := let n := 0 in let p := S n in S p.
+Extraction test11. (* let test11 = S (S O) *)
+
+Definition test12 := forall x:forall X:Type, X -> X, x Type Type.
+Extraction test12. 
+(* type test12 = (__ -> __ -> __) -> __ *)
+
+
+Definition test13 := match left True I with
+                     | left x => 1
+                     | right x => 0
+                     end.
+Extraction test13. (* let test13 = S O *)
+
+
+(** example with more arguments that given by the type *)
+
+Definition test19 :=
+  nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0)
+    (fun (n:nat) (f:nat -> nat) => f) 0 0.
+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 : forall y z:nat, c x y -> 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 y:U) := A y \/ x = y.
+
+Inductive Finite (U:Type) : Ensemble U -> Set :=
+  | Empty_is_finite : Finite U (Empty_set U)
+  | Union_is_finite :
+      forall A:Ensemble U,
+        Finite U A -> forall 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 :=
+  match t with
+  | Node a f => S (forest_size f)
+  end
+ 
+ with forest_size (f:forest) : nat :=
+  match f with
+  | Leaf b => 1
+  | Cons t f' => 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 0.
+Extraction test14.
+(* let test14 x x0 x1 = Tata (O, x, x0, x1) *)
+Definition test15 := tata 0 1.
+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 0.
+Extraction test16.
+(* let test16 x = Eta_c (O, x) *)
+Definition test17 := eta_c 0 True.
+Extraction test17.
+(* let test17 x = Eta_c (O, x) *)
+Definition test18 := eta_c 0 True 0.
+Extraction test18. 
+(* let test18 _ = Eta_c (O, O) *)
+
+
+(** Example of singleton inductive type *)
+
+Inductive bidon (A:Prop) (B:Type) : Set :=
+    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.
+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 : forall (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 : forall (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 : forall A:Set, Truc A
+  | machin : forall 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 (fun a:Set => option a).
+Extraction test24.
+(* type test24 = (__, __ option) sigT *)
+
+
+(** Coq term non strongly-normalizable after extraction *)
+
+Require Import Gt.
+Definition loop (Ax:Acc gt 0) :=
+  (fix F (a:nat) (b:Acc gt a) {struct b} : nat :=
+     F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 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 : forall 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) :=
+  if b as b return (if b then Type else nat) then Set else 0.
+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) := if b as x return natbool x then 0 else true.
+Extraction zerotrue. 
+(* 
+let zerotrue = function
+  | True -> Obj.magic O
+  | False -> Obj.magic True
+*)
+
+Definition natProp (b:bool) := if b return Type then nat else Prop.
+
+Definition natTrue (b:bool) := if b return Type then nat else True.
+
+Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True.
+Extraction zeroTrue.
+(* 
+let zeroTrue = function
+  | True -> Obj.magic O
+  | False -> Obj.magic __
+*)
+
+Definition natTrue2 (b:bool) := if b return Type then nat else True.
+
+Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I.
+Extraction zeroprop.
+(* 
+let zeroprop = function
+  | True -> Obj.magic O
+  | False -> Obj.magic __
+*)
+
+(** polymorphic f applied several times *)
+
+Definition test21 := (id nat 0, id bool true).
+Extraction test21.
+(* let test21 = Pair ((id O), (id True)) *)
+
+(** ok *)
+
+Definition test22 :=
+  (fun f:forall X:Type, X -> X => (f nat 0, f bool true))
+    (fun (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:forall X:Type, X -> X) := (f nat 0, 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) (x:nat -> X) (y:X -> bool) : bool := y (x 0).
+Extraction f.
+(* let f x y =
+  y (x O)
+*)
+
+Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true).
+Extraction NoInline f.
+Extraction f_prop.
+(* let f_prop =
+  f (Obj.magic __) (fun _ -> True)
+*)
+
+Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true).
+Extraction f_arity.
+(* let f_arity =
+  f (Obj.magic __) (fun _ -> True)
+*)
+
+Definition f_normal :=
+  f nat (fun x => x) (fun x => match x with
+                               | 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 : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. 
+Extraction Boite. 
+(*
+type boite =
+  | Boite of bool * __
+*)
+
+
+Definition boite1 := boite true 0.
+Extraction boite1.
+(* let boite1 = Boite (True, (Obj.magic O)) *)
+
+Definition boite2 := boite false (0, 0).
+Extraction boite2.
+(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *)
+
+Definition test_boite (B:Boite) :=
+  match B return nat with
+  | boite true n => n
+  | boite false n => 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 : forall A:Set, A -> Box. 
+Extraction Box.
+(* type box = __ *)
+
+Definition box1 := box nat 0. 
+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 0.
+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 :=
+  match n with
+  | O => nat
+  | S n => nat -> Fun n
+  end.
+
+Fixpoint Const (k n:nat) {struct n} : Fun n :=
+  match n as x return Fun x with
+  | O => k
+  | S n => fun p:nat => Const k n
+  end.
+
+Fixpoint proj (k n:nat) {struct n} : Fun n :=
+  match n as x return Fun x with
+  | O => 0 (* ou assert false ....*)
+  | S n =>
+      match k with
+      | O => fun x => Const x n
+      | S k => fun 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/contrib/field/Field.v b/contrib/field/Field.v
new file mode 100644
index 00000000..7b48e275
--- /dev/null
+++ b/contrib/field/Field.v
@@ -0,0 +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        *)
+(************************************************************************)
+
+(* $Id: Field.v,v 1.6.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+
+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
diff --git a/contrib/field/Field_Compl.v b/contrib/field/Field_Compl.v
new file mode 100644
index 00000000..cba921f7
--- /dev/null
+++ b/contrib/field/Field_Compl.v
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+
+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.
+
+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} : 
+   B -> A -> A :=
+     fun (key:B) (default:A) =>
+       match lst with
+       | nilT => default
+       | consT (pairT 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 :=
+     match l with
+     | nilT => false
+     | consT 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/Field_Tactic.v
new file mode 100644
index 00000000..c5c06547
--- /dev/null
+++ b/contrib/field/Field_Tactic.v
@@ -0,0 +1,432 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.20.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+
+Require Import Ring.
+Require Export Field_Compl.
+Require Export Field_Theory.
+
+(**** Interpretation A --> ExprA ****)
+
+Ltac mem_assoc var lvar :=
+  match constr:lvar with
+  | (nilT _) => constr:false
+  | (consT _ ?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 assoc elt lst :=
+  match constr:lst with
+  | (nilT _) => fail
+  | (consT (prodT _ nat) (pairT _ nat ?X1 ?X2) ?X3) =>
+      match constr:(elt = X1) with
+      | (?X1 = ?X1) => constr:X2
+      | _ => assoc elt X3
+      end
+  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
+  match constr:trm with
+  | AzeroT => constr:EAzero
+  | AoneT => constr:EAone
+  | (AplusT ?X1 ?X2) =>
+      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
+      constr:(EAplus e1 e2)
+  | (AmultT ?X1 ?X2) =>
+      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
+      constr:(EAmult e1 e2)
+  | (AoppT ?X1) =>
+      let e := interp_A FT lvar X1 in
+      constr:(EAopp e)
+  | (AinvT ?X1) => let e := interp_A FT lvar X1 in
+                   constr:(EAinv e)
+  | ?X1 => let idx := assoc X1 lvar in
+           constr:(EAvar idx)
+  end.
+
+(************************)
+(*    Simplification    *)
+(************************)
+
+(**** Generation of the multiplier ****)
+
+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)
+  end.
+
+Ltac union l1 l2 :=
+  match constr:l1 with
+  | (nilT _) => l2
+  | (consT ?X1 ?X2 ?X3) =>
+      let nl2 := remove X2 l2 in
+      let nl := union X3 nl2 in
+      constr:(consT X1 X2 nl)
+  end.
+
+Ltac raw_give_mult trm :=
+  match constr:trm with
+  | (EAinv ?X1) => constr:(consT ExprA X1 (nilT ExprA))
+  | (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)
+  end.
+
+Ltac give_mult trm :=
+  let ltrm := raw_give_mult trm in
+  constr:(mult_of_list ltrm).
+
+(**** Associativity ****)
+
+Ltac apply_assoc FT lvar trm :=
+  let t := eval compute in (assoc trm) in
+  match constr:(t = trm) with
+  | (?X1 = ?X1) => idtac
+  | _ =>
+      rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- *
+  end.
+
+(**** Distribution *****)
+
+Ltac apply_distrib FT lvar trm :=
+  let t := eval compute in (distrib trm) in
+  match constr:(t = trm) with
+  | (?X1 = ?X1) => idtac
+  | _ =>
+      rewrite <- (distrib_correct FT trm);
+       change (distrib trm) with t in |- *
+  end.
+
+(**** Multiplication by the inverse product ****)
+
+Ltac grep_mult := match goal with
+                  | id:(interp_ExprA _ _ _ <> _) |- _ => id
+                  end.
+
+Ltac weak_reduce :=
+  match goal with
+  |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
+      cbv beta iota zeta
+       delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
+             Aone Aplus Amult Aopp Ainv] in |- *
+  end.
+
+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
+             match goal with
+             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r X1)
+             end; clear X1 X2) ])
+  end.
+
+Ltac apply_multiply FT lvar trm :=
+  let t := eval compute in (multiply trm) in
+  match constr:(t = trm) with
+  | (?X1 = ?X1) => idtac
+  | _ =>
+      rewrite <- (multiply_correct FT trm);
+       change (multiply trm) with t in |- *
+  end.
+
+(**** Permutations and simplification ****)
+
+Ltac apply_inverse mul FT lvar trm :=
+  let t := eval compute in (inverse_simplif mul trm) in
+  match constr:(t = trm) with
+  | (?X1 = ?X1) => idtac
+  | _ =>
+      rewrite <- (inverse_correct FT trm mul);
+       [ change (inverse_simplif mul trm) with t in |- * | assumption ]
+  end.
+(**** Inverse test ****)
+
+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
+  match constr:trm with
+  | (AinvT _) => fail 1
+  | (AoppT ?X1) =>
+      strong_fail ltac:(inverse_test_aux FT X1; idtac)
+  | (AplusT ?X1 ?X2) =>
+      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
+  | (AmultT ?X1 ?X2) =>
+      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
+  | _ => idtac
+  end.
+
+Ltac inverse_test FT :=
+  let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) in
+  match goal with
+  |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
+  end.
+
+(**** Field itself ****)
+
+Ltac apply_simplif sfun :=
+  match goal with
+  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => 
+  sfun X1 X2 X3
+  end;
+   match goal with
+   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => 
+   sfun X1 X2 X3
+   end.
+
+Ltac unfolds FT :=
+  match eval cbv beta iota delta [Aminus] in (Aminus FT) with
+  | (Field_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.
+
+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
+  (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
+  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
+        (let ft := FT in
+         let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
+        [ compute in |- *; auto
+        | intros ft vm; apply_simplif apply_distrib;
+           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 ] ])
+  end.
+
+Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT.
+
+(*****************************)
+(*    Term Simplification    *)
+(*****************************)
+
+(**** Minus and division expansions ****)
+
+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
+    | _ => trm
+    end) in
+  match eval cbv beta iota delta [Adiv] in (Adiv FT) with
+  | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e
+  | _ => e
+  end.
+
+(**** Inverses simplification ****)
+
+Ltac simpl_inv trm :=
+  match constr:trm with
+  | (EAplus ?X1 ?X2) =>
+      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
+      constr:(EAplus e1 e2)
+  | (EAmult ?X1 ?X2) =>
+      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
+      constr:(EAmult e1 e2)
+  | (EAopp ?X1) => let e := simpl_inv X1 in
+                   constr:(EAopp e)
+  | (EAinv ?X1) => SimplInvAux X1
+  | ?X1 => constr:X1
+  end
+ with SimplInvAux trm :=
+  match constr:trm with
+  | (EAinv ?X1) => simpl_inv X1
+  | (EAmult ?X1 ?X2) =>
+      let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
+      constr:(EAmult e1 e2)
+  | ?X1 => let e := simpl_inv X1 in
+           constr:(EAinv e)
+  end.
+
+(**** Monom simplification ****)
+
+Ltac map_tactic fcn lst :=
+  match constr:lst with
+  | (nilT _) => lst
+  | (consT ?X1 ?X2 ?X3) =>
+      let r := fcn X2 with t := map_tactic fcn X3 in
+      constr:(consT X1 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)
+  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 trm := build_monom_aux ltot EAone in
+  match constr:trm with
+  | (EAmult _ ?X1) => constr:X1
+  | ?X1 => constr:X1
+  end.
+
+Ltac simpl_monom_aux lnum lden trm :=
+  match constr:trm with
+  | (EAmult (EAinv ?X1) ?X2) =>
+      let mma := mem_assoc X1 lnum in
+      match constr:mma with
+      | true =>
+          let newlnum := remove X1 lnum in
+          simpl_monom_aux newlnum lden X2
+      | false => simpl_monom_aux lnum (consT ExprA X1 lden) X2
+      end
+  | (EAmult ?X1 ?X2) =>
+      let mma := mem_assoc X1 lden in
+      match constr:mma with
+      | true =>
+          let newlden := remove X1 lden in
+          simpl_monom_aux lnum newlden X2
+      | false => simpl_monom_aux (consT ExprA X1 lnum) lden X2
+      end
+  | (EAinv ?X1) =>
+      let mma := mem_assoc X1 lnum in
+      match constr:mma with
+      | true =>
+          let newlnum := remove X1 lnum in
+          build_monom newlnum lden
+      | false => build_monom lnum (consT ExprA X1 lden)
+      end
+  | ?X1 =>
+      let mma := mem_assoc X1 lden in
+      match constr:mma with
+      | true =>
+          let newlden := remove X1 lden in
+          build_monom lnum newlden
+      | false => build_monom (consT ExprA X1 lnum) lden
+      end
+  end.
+
+Ltac simpl_monom trm := simpl_monom_aux (nilT ExprA) (nilT ExprA) trm.
+
+Ltac simpl_all_monomials trm :=
+  match constr:trm with
+  | (EAplus ?X1 ?X2) =>
+      let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
+      constr:(EAplus e1 e2)
+  | ?X1 => simpl_monom X1
+  end.
+
+(**** Associativity and distribution ****)
+
+Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).
+
+(**** The tactic Field_Term ****)
+
+Ltac eval_weak_reduce trm :=
+  eval
+   cbv beta iota zeta
+    delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
+          Amult Aopp Ainv] in trm.
+
+Ltac field_term FT exp :=
+  let newexp := init_exp FT exp in
+  let lvar := build_varlist FT newexp in
+  let trm := interp_A FT lvar newexp in
+  let tma := eval compute in (assoc trm) in
+  let tsmp :=
+   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
diff --git a/contrib/field/Field_Theory.v b/contrib/field/Field_Theory.v
new file mode 100644
index 00000000..8737fd79
--- /dev/null
+++ b/contrib/field/Field_Theory.v
@@ -0,0 +1,645 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+
+Require Import Peano_dec.
+Require Import Ring.
+Require Import 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 : forall 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 : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
+Proof.
+  double induction e1 e2; try intros;
+   try (left; reflexivity) || (try (right; discriminate)).
+  elim (H1 e0); intro y; elim (H2 e); intro y0;
+   try
+    (left; rewrite y; rewrite y0; auto) ||
+      (right; red in |- *; intro; inversion H3; auto).
+  elim (H1 e0); intro y; elim (H2 e); intro y0;
+   try
+    (left; rewrite y; rewrite y0; auto) ||
+      (right; red in |- *; intro; inversion H3; auto).
+  elim (H0 e); intro y.
+  left; rewrite y; auto.
+  right; red in |- *; intro; inversion H1; auto.
+  elim (H0 e); intro y.
+  left; rewrite y; auto.
+  right; red in |- *; intro; inversion H1; auto.
+  elim (eq_nat_dec n n0); intro y.
+  left; rewrite y; auto.
+  right; red in |- *; intro; inversion H; auto. 
+Defined.
+
+Definition eq_nat_dec := Eval compute in eq_nat_dec.
+Definition eqExprA := Eval compute in eqExprA_O.
+
+(**** Generation of the multiplier ****)
+
+Fixpoint mult_of_list (e:listT ExprA) : ExprA :=
+  match e with
+  | nilT => EAone
+  | consT e1 l1 => EAmult e1 (mult_of_list l1)
+  end.
+
+Section Theory_of_fields.
+
+Variable T : Field_Theory.
+
+Let AT := A T.
+Let AplusT := Aplus T.
+Let AmultT := Amult T.
+Let AoneT := Aone T.
+Let AzeroT := Azero T.
+Let AoppT := Aopp T.
+Let AeqT := Aeq T.
+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) (
+ 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 : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AplusT_assoc :
+ forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AmultT_assoc :
+ forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
+Proof.
+  intros; ring.
+Qed.
+
+Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
+Proof.
+  intros; 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.
+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.
+  transitivity (AplusT (AplusT (AoppT r) r) r2).
+  repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
+  ring.
+Qed.
+ 
+Lemma r_AmultT_mult :
+ forall 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  in |- *; 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 ].
+Qed.
+
+Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
+Proof.
+  intro; ring.
+Qed.
+ 
+Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
+Proof.
+  intro; ring.
+Qed.
+ 
+Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
+Proof.
+  intro; 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.
+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.
+Qed.
+
+(************************)
+(*    Interpretation    *)
+(************************)
+
+(**** ExprA --> A ****)
+
+Fixpoint interp_ExprA (lvar:listT (prodT AT nat)) (e:ExprA) {struct e} :
+ AT :=
+  match e with
+  | 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 (e1:ExprA) : ExprA -> ExprA :=
+     fun e2:ExprA =>
+       match e1 with
+       | EAmult t1 t2 =>
+           match t2 with
+           | 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 :=
+  match e with
+  | EAmult e1 e3 =>
+      match e1 with
+      | 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 (e1:ExprA) : ExprA -> ExprA :=
+     fun e2:ExprA =>
+       match e1 with
+       | EAplus t1 t2 =>
+           match t2 with
+           | 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 :=
+  match e with
+  | EAplus e1 e3 =>
+      match e1 with
+      | 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 :
+ forall (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.
+simple induction e2; auto; intros.
+unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
+ unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
+ fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
+ fold interp_ExprA in |- *; auto.
+Qed.
+
+Lemma merge_mult_correct :
+ forall (e1 e2:ExprA) (lvar:listT (prodT 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).
+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 in |- *; ring.
+ring.
+Qed.
+
+Lemma assoc_mult_correct1 :
+ forall (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.
+simple induction e1; auto; intros.
+rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
+ simpl in |- *; rewrite merge_mult_correct; simpl in |- *; 
+ auto.
+Qed.
+
+Lemma assoc_mult_correct :
+ forall (e:ExprA) (lvar:listT (prodT 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.
+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.
+simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
+ rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc;
+ 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_assoc; rewrite H1; rewrite AmultT_assoc; 
+ 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)),
+   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.
+simple induction e2; auto; intros.
+unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
+ unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
+ fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
+ fold interp_ExprA in |- *; auto.
+Qed.
+
+Lemma merge_plus_correct :
+ forall (e1 e2:ExprA) (lvar:listT (prodT 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).
+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 in |- *; ring.
+ring.
+Qed.
+
+Lemma assoc_plus_correct :
+ forall (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.
+simple induction e1; auto; intros.
+rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
+ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; 
+ auto.
+Qed.
+
+Lemma assoc_correct :
+ forall (e:ExprA) (lvar:listT (prodT AT nat)),
+   interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
+Proof.
+simple induction e; auto; intros.
+elim e0; intros.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
+ rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc;
+ rewrite assoc_plus_correct; rewrite H2; simpl in |- *;
+ 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 in |- *; 
+ 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 in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
+ rewrite (H0 lvar); simpl in |- *; auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct; 
+ simpl in |- *; auto.
+Qed.
+
+(**** Distribution *****)
+
+Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
+  match e with
+  | 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 (e1:ExprA) : ExprA -> ExprA :=
+     fun e2:ExprA =>
+       match e1 with
+       | EAplus t1 t2 =>
+           EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
+       | _ => EAmult e1 e2
+       end).
+
+Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
+  match e1 with
+  | 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 :=
+  match e with
+  | 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 :
+ forall (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.
+simple induction e1; try intros; simpl in |- *; auto.
+rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
+ rewrite (H0 e2 lvar); ring.
+Qed.
+
+Lemma distrib_mult_left_correct :
+ forall (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.
+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
+  (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 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.
+Qed.
+
+Lemma distrib_correct :
+ forall (e:ExprA) (lvar:listT (prodT AT nat)),
+   interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
+Proof.
+simple induction e; intros; auto.
+simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
+ unfold distrib in |- *; simpl in |- *; auto.
+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.
+Qed.
+
+(**** Multiplication by the inverse product ****)
+
+Lemma mult_eq :
+ forall (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 in |- *; intros;
+   apply
+    (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
+       (interp_ExprA lvar e2)); assumption.
+Qed.
+
+Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
+  match e with
+  | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
+  | _ => EAmult a e
+  end.
+
+Definition multiply (e:ExprA) : ExprA :=
+  match e with
+  | EAmult a e1 => multiply_aux a e1
+  | _ => e
+  end.
+
+Lemma multiply_aux_correct :
+ forall (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.
+simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
+ auto.
+  simpl in |- *; rewrite (H0 lvar); ring.
+Qed.
+
+Lemma multiply_correct :
+ forall (e:ExprA) (lvar:listT (prodT AT nat)),
+   interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
+Proof.
+  simple induction e; simpl in |- *; auto.
+  intros; apply multiply_aux_correct.
+Qed.
+
+(**** Permutations and simplification ****)
+
+Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
+  match m with
+  | EAmult m0 m1 =>
+      match eqExprA m0 (EAinv a) with
+      | left _ => m1
+      | right _ => EAmult m0 (monom_remove a m1)
+      end
+  | _ =>
+      match eqExprA m (EAinv a) with
+      | left _ => EAone
+      | right _ => EAmult a m
+      end
+  end.
+
+Definition monom_simplif_rem :=
+  (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
+     fun m:ExprA =>
+       match a with
+       | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
+       | _ => monom_remove a m
+       end).
+
+Definition monom_simplif (a m:ExprA) : ExprA :=
+  match m with
+  | EAmult a' m' =>
+      match eqExprA a a' with
+      | left _ => monom_simplif_rem a m'
+      | right _ => m
+      end
+  | _ => m
+  end.
+
+Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
+  match e with
+  | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
+  | _ => monom_simplif a e
+  end.
+
+Lemma monom_remove_correct :
+ forall (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.
+simple induction e; intros.
+simpl in |- *; case (eqExprA EAzero (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+simpl in |- *; case (eqExprA EAone (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
+ [ inversion e2 | simpl in |- *; trivial ].
+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.
+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.
+case (eqExprA e0 a); intros.
+rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
+inversion e1; simpl in |- *; elimtype False; auto.
+simpl in |- *; trivial.
+unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+Qed.
+
+Lemma monom_simplif_rem_correct :
+ forall (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.
+simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
+ auto.
+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.
+Qed.
+
+Lemma monom_simplif_correct :
+ forall (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.
+simple induction e; intros; auto.
+simpl in |- *; case (eqExprA a e0); intros.
+rewrite <- e2; apply monom_simplif_rem_correct; auto. 
+simpl in |- *; trivial.
+Qed.
+
+Lemma inverse_correct :
+ forall (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.
+simple induction e; intros; auto.
+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
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
new file mode 100644
index 00000000..32adec66
--- /dev/null
+++ b/contrib/field/field.ml4
@@ -0,0 +1,190 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: field.ml4,v 1.33.2.1 2004/07/16 19:30:09 herbelin Exp $ *)
+
+open Names
+open Pp
+open Proof_type
+open Tacinterp
+open Tacmach
+open Term
+open Typing
+open Util
+open Vernacinterp
+open Vernacexpr
+open Tacexpr
+
+(* 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
+
+(* To deal with the optional arguments *)
+let constr_of_opt a opt =
+  let ac = constr_of a in
+  match opt with
+  | None -> mkApp ((constant ["Field_Compl"] "Field_None"),[|ac|])
+  | Some f -> mkApp ((constant ["Field_Compl"] "Field_Some"),[|ac;constr_of f|])
+
+(* Table of theories *)
+let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
+
+let lookup env typ =
+  try Gmap.find typ !th_tab
+  with Not_found -> 
+    errorlabstrm "field"
+      (str "No field is declared for type" ++ spc() ++
+      Printer.prterm_env env typ)
+
+let _ = 
+  let init () = th_tab := Gmap.empty in
+  let freeze () = !th_tab in
+  let unfreeze fs = th_tab := fs in
+  Summary.declare_summary "field"
+    { Summary.freeze_function   = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function     = init;
+      Summary.survive_module = false;
+      Summary.survive_section   = false }
+
+let load_addfield _ = ()
+let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
+let subst_addfield (_,subst,(typ,th as obj)) =
+  let typ' = subst_mps subst typ in
+  let th' = subst_mps subst th in
+    if typ' == typ && th' == th then obj else
+      (typ',th')
+let export_addfield x = Some x
+
+(* Declaration of the Add Field library object *)
+let (in_addfield,out_addfield)=
+  Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
+       Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
+       Libobject.cache_function = cache_addfield;
+       Libobject.subst_function = subst_addfield;
+       Libobject.classify_function = (fun (_,a) -> Libobject.Substitute a);
+       Libobject.export_function = export_addfield }
+
+(* Adds a theory to the table *)
+let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
+  ainv_l =
+  begin
+    (try
+      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"),
+      [|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 ();
+      Lib.add_anonymous_leaf (in_addfield (a,th))
+    end
+  end
+
+(* Vernac command declaration *)
+open Extend
+open Pcoq
+open Genarg
+
+VERNAC ARGUMENT EXTEND divarg
+| [ "div" ":=" constr(adiv) ] -> [ adiv ]
+END
+
+VERNAC ARGUMENT EXTEND minusarg
+| [ "minus" ":=" constr(aminus) ] -> [ aminus ]
+END
+
+(*
+(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*)
+VERNAC ARGUMENT EXTEND minus_div_arg
+| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
+| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
+| [ ] -> [ None, None ]
+END
+*)
+
+(* For the translator, otherwise the code above is OK *)
+open Ppconstrnew
+let pp_minus_div_arg _prc _prt (omin,odiv) = 
+  if omin=None && odiv=None then mt() else
+    spc() ++ str "with" ++
+    pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
+    pr_opt (fun c -> str "div := " ++ _prc c) odiv
+(*
+let () =
+  Pptactic.declare_extra_genarg_pprule true
+    (rawwit_minus_div_arg,pp_minus_div_arg)
+    (globwit_minus_div_arg,pp_minus_div_arg)
+    (wit_minus_div_arg,pp_minus_div_arg)
+*)
+ARGUMENT EXTEND minus_div_arg 
+  TYPED AS constr_opt * constr_opt
+  PRINTED BY pp_minus_div_arg
+| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
+| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
+| [ ] -> [ None, None ]
+END
+
+VERNAC COMMAND EXTEND Field
+  [ "Add" "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) ]
+    -> [ let (aminus_o, adiv_o) = md in
+         add_field
+           (constr_of a) (constr_of aplus) (constr_of amult)
+           (constr_of aone) (constr_of azero) (constr_of aopp)
+           (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o)
+           (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ]
+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
+  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
+      | _ -> error "The statement is not built from Leibniz' equality" in
+  let th = VConstr (lookup (pf_env g) typ) in
+  (interp_tac_gen [(id_of_string "FT",th)] (get_debug ())
+    <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
+
+(* Verifies that all the terms have the same type and gives the right theory *)
+let guess_theory env evc = function
+  | c::tl ->
+    let t = type_of env evc c in
+    if List.exists (fun c1 ->
+      not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then
+      errorlabstrm "Field:" (str" All the terms must have the same type")
+    else
+      lookup env t
+  | [] -> anomaly "Field: must have a non-empty constr list here"
+
+(* Guesses the type and calls Field_Term with the right theory *)
+let field_term l g =
+  Library.check_required_library ["Coq";"field";"Field"];
+  let env = (pf_env g)
+  and evc = (project g) in
+  let th = valueIn (VConstr (guess_theory env evc l))
+  and nl = List.map (fun x -> valueIn (VConstr x)) (Quote.sort_subterm g l) in
+  (List.fold_right
+    (fun c a ->
+     let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
+     Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g
+
+(* Declaration of Field *)
+
+TACTIC EXTEND Field
+| [ "Field" ] -> [ field ]
+| [ "Field" ne_constr_list(l) ] -> [ field_term l ]
+END
diff --git a/contrib/first-order/formula.ml b/contrib/first-order/formula.ml
new file mode 100644
index 00000000..49cb8e25
--- /dev/null
+++ b/contrib/first-order/formula.ml
@@ -0,0 +1,271 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: formula.ml,v 1.18.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Hipattern
+open Names
+open Term
+open Termops
+open Reductionops
+open Tacmach
+open Util
+open Declarations
+open Libnames
+open Inductiveops
+
+let qflag=ref true
+
+let red_flags=ref Closure.betaiotazeta
+
+let (=?) f g i1 i2 j1 j2=
+  let c=f i1 i2 in
+    if c=0 then g j1 j2 else c
+
+let (==?) fg h i1 i2 j1 j2 k1 k2=
+  let c=fg i1 i2 j1 j2 in
+    if c=0 then h k1 k2 else c
+
+type ('a,'b) sum = Left of 'a | Right of 'b
+
+type counter = bool -> metavariable
+
+exception Is_atom of constr
+
+let meta_succ m = m+1
+
+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 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 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 lp=Array.length types in     
+  let myhyps i=
+    let t1=Term.prod_applist types.(i) largs in
+    let t2=snd (Sign.decompose_prod_n_assum nevar t1) in
+      fst (Sign.decompose_prod_assum t2) in
+    Array.init lp myhyps
+
+let special_nf gl=
+  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
+    (fun t -> Closure.norm_val infos (Closure.inject t))
+
+let special_whd gl=
+  let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
+    (fun t -> Closure.whd_val infos (Closure.inject t))
+
+type kind_of_formula=
+    Arrow of constr*constr
+  | False of inductive*constr list
+  | And of inductive*constr list*bool
+  | Or of inductive*constr list*bool
+  | Exists of inductive*constr list
+  | Forall of constr*constr
+  | Atom of constr
+      
+let rec kind_of_formula gl term =
+  let normalize=special_nf gl in
+  let cciterm=special_whd gl term in
+    match match_with_imp_term cciterm with
+	Some (a,b)-> Arrow(a,(pop b))
+      |_->
+	 match match_with_forall_term cciterm with
+	     Some (_,a,b)-> Forall(a,b)
+	   |_-> 
+	      match match_with_nodep_ind cciterm with
+		  Some (i,l,n)->
+		    let ind=destInd i in
+		    let (mib,mip) = Global.lookup_inductive ind in
+		    let nconstr=Array.length mip.mind_consnames in
+		      if nconstr=0 then 
+			False(ind,l)
+		      else
+			let has_realargs=(n>0) in
+			let is_trivial=
+			  let is_constant c =
+			    nb_prod c = mip.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)
+			  then
+			    Atom cciterm 
+			  else
+			    if nconstr=1 then
+			      And(ind,l,is_trivial)
+			    else 
+			      Or(ind,l,is_trivial) 
+		| _ ->  
+		    match match_with_sigma_type cciterm with
+			Some (i,l)-> Exists((destInd i),l)
+		      |_-> Atom (normalize cciterm)
+  
+type atoms = {positive:constr list;negative:constr list}
+
+type side = Hyp | Concl | Hint
+
+let no_atoms = (false,{positive=[];negative=[]})
+
+let dummy_id=VarRef (id_of_string "")
+
+let build_atoms gl metagen side cciterm =
+  let trivial =ref false
+  and positive=ref []
+  and negative=ref [] in
+  let normalize=special_nf gl in 
+  let rec build_rec env polarity cciterm=
+    match kind_of_formula gl cciterm with
+	False(_,_)->if not polarity then trivial:=true
+      | Arrow (a,b)->
+	  build_rec env (not polarity) a;
+	  build_rec env polarity b
+      | And(i,l,b) | Or(i,l,b)->
+	  if b then 
+	    begin
+	      let unsigned=normalize (substnl env 0 cciterm) in
+		if polarity then 
+		  positive:= unsigned :: !positive 
+		else 
+		  negative:= unsigned :: !negative
+	    end;
+	  let v = ind_hyps 0 i l gl in
+	  let g i _ (_,_,t) =
+	    build_rec env polarity (lift i t) in
+	  let f l =
+	    list_fold_left_i g (1-(List.length l)) () l in
+	    if polarity && (* we have a constant constructor *)
+	      array_exists (function []->true|_->false) v 
+	    then trivial:=true;
+	    Array.iter f v 
+      | Exists(i,l)->
+	  let var=mkMeta (metagen true) in
+	  let v =(ind_hyps 1 i l gl).(0) in
+	  let g i _ (_,_,t) =
+	    build_rec (var::env) polarity (lift i t) in
+	    list_fold_left_i g (2-(List.length l)) () v
+      | Forall(_,b)->
+	  let var=mkMeta (metagen true) in
+	    build_rec (var::env) polarity b
+      | Atom t->
+	  let unsigned=substnl env 0 t in
+	    if not (isMeta unsigned) then (* discarding wildcard atoms *)
+	      if polarity then 
+		positive:= unsigned :: !positive 
+	      else 
+		negative:= unsigned :: !negative in
+    begin
+      match side with
+	  Concl    -> build_rec [] true cciterm
+	| Hyp      -> build_rec [] false cciterm
+	| Hint     -> 
+	    let rels,head=decompose_prod cciterm in
+	    let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
+	      build_rec env false head;trivial:=false (* special for hints *)
+    end;
+    (!trivial,
+     {positive= !positive;
+      negative= !negative})
+    
+type right_pattern =
+    Rarrow
+  | Rand
+  | Ror 
+  | Rfalse
+  | Rforall
+  | Rexists of metavariable*constr*bool
+   
+type left_arrow_pattern=
+    LLatom
+  | LLfalse of inductive*constr list
+  | LLand of inductive*constr list
+  | LLor of inductive*constr list
+  | LLforall of constr
+  | LLexists of inductive*constr list
+  | LLarrow of constr*constr*constr
+
+type left_pattern=
+    Lfalse    
+  | Land of inductive
+  | Lor of inductive 
+  | Lforall of metavariable*constr*bool
+  | Lexists of inductive
+  | LA of constr*left_arrow_pattern
+
+type t={id:global_reference;
+	constr:constr;
+	pat:(left_pattern,right_pattern) sum;
+	atoms:atoms}
+    
+let build_formula side nam typ gl metagen=
+  let normalize = special_nf gl in
+    try 
+      let m=meta_succ(metagen false) in
+      let trivial,atoms=
+	if !qflag then 
+	  build_atoms gl metagen side typ 
+	else no_atoms in
+      let pattern=
+	match side with
+	    Concl ->
+	      let pat=
+		match kind_of_formula gl typ with
+		    False(_,_)        -> Rfalse
+		  | Atom a       -> raise (Is_atom a)
+		  | And(_,_,_)        -> Rand
+		  | Or(_,_,_)         -> Ror
+		  | Exists (i,l) -> 
+		      let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
+			Rexists(m,d,trivial)
+		  | Forall (_,a) -> Rforall 
+		  | Arrow (a,b) -> Rarrow in
+		Right pat
+	  | _ ->
+	      let pat=
+		match kind_of_formula gl typ with
+		    False(i,_)        ->  Lfalse
+		  | Atom a       ->  raise (Is_atom a)
+		  | And(i,_,b)         ->  
+		      if b then
+			let nftyp=normalize typ in raise (Is_atom nftyp)
+		      else Land i
+		  | Or(i,_,b)          ->
+		      if b then
+			let nftyp=normalize typ in raise (Is_atom nftyp)
+		      else Lor i
+		  | Exists (ind,_) ->  Lexists ind 
+		  | Forall (d,_) -> 
+		      Lforall(m,d,trivial)
+		  | Arrow (a,b) ->
+		      let nfa=normalize a in
+			LA (nfa, 
+			    match kind_of_formula gl a with
+				False(i,l)-> LLfalse(i,l)
+			      | Atom t->     LLatom
+			      | And(i,l,_)-> LLand(i,l)
+			      | Or(i,l,_)->  LLor(i,l)
+			      | Arrow(a,c)-> LLarrow(a,c,b)
+			      | Exists(i,l)->LLexists(i,l)
+			      | Forall(_,_)->LLforall a) in
+		Left pat
+      in
+	Left {id=nam;
+	      constr=normalize typ;
+	      pat=pattern;
+	      atoms=atoms}
+    with Is_atom a-> Right a (* already in nf *)
+
diff --git a/contrib/first-order/formula.mli b/contrib/first-order/formula.mli
new file mode 100644
index 00000000..db24f20f
--- /dev/null
+++ b/contrib/first-order/formula.mli
@@ -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        *)
+(************************************************************************)
+
+(* $Id: formula.mli,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Term
+open Names
+open Libnames
+
+val qflag : bool ref
+
+val red_flags: Closure.RedFlags.reds ref
+
+val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 
+  'a -> 'a -> 'b -> 'b -> int
+  
+val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 
+  'a -> 'a -> 'b -> 'b -> 'c ->'c -> int
+
+type ('a,'b) sum = Left of 'a | Right of 'b
+
+type counter = bool -> metavariable
+
+val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
+
+val ind_hyps : int -> inductive -> constr list -> 
+  Proof_type.goal Tacmach.sigma -> Sign.rel_context array
+
+type atoms = {positive:constr list;negative:constr list}
+
+type side = Hyp | Concl | Hint
+
+val dummy_id: global_reference
+			
+val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> 
+  side -> constr -> bool * atoms
+
+type right_pattern =
+    Rarrow
+  | Rand
+  | Ror 
+  | Rfalse
+  | Rforall
+  | Rexists of metavariable*constr*bool
+    
+type left_arrow_pattern=
+    LLatom
+  | LLfalse of inductive*constr list
+  | LLand of inductive*constr list
+  | LLor of inductive*constr list
+  | LLforall of constr
+  | LLexists of inductive*constr list
+  | LLarrow of constr*constr*constr
+
+type left_pattern=
+    Lfalse    
+  | Land of inductive
+  | Lor of inductive 
+  | Lforall of metavariable*constr*bool
+  | Lexists of inductive
+  | LA of constr*left_arrow_pattern
+      
+type t={id: global_reference;
+	constr: constr;
+	pat: (left_pattern,right_pattern) sum;
+	atoms: atoms}
+    
+(*exception Is_atom of constr*)
+
+val build_formula : side -> global_reference -> types -> 
+  Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum
+
diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4
new file mode 100644
index 00000000..f85f2171
--- /dev/null
+++ b/contrib/first-order/g_ground.ml4
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma"  i*)
+
+(* $Id: g_ground.ml4,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Formula
+open Sequent
+open Ground
+open Goptions
+open Tactics
+open Tacticals
+open Tacinterp
+open Term
+open Names
+open Util
+open Libnames
+
+(* declaring search depth as a global option *)
+
+let ground_depth=ref 5
+
+let _=
+  let gdopt=
+    { optsync=true;
+      optname="Firstorder Depth";
+      optkey=SecondaryTable("Firstorder","Depth"); 
+      optread=(fun ()->Some !ground_depth); 
+      optwrite=
+   (function 
+	None->ground_depth:=5
+      |	Some i->ground_depth:=(max i 0))}
+  in
+    declare_int_option gdopt
+      
+let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
+    
+let fail_solver=tclFAIL 0 "GTauto failed"
+		      
+type external_env=
+    Ids of global_reference list
+  | Bases of Auto.hint_db_name list
+  | Void
+
+let gen_ground_tac flag taco ext gl=
+  let backup= !qflag in
+    try
+      qflag:=flag;
+      let solver= 
+	match taco with 
+	    Some tac-> tac
+	  | None-> default_solver in
+      let startseq=
+	match ext with
+	    Void -> (fun gl -> empty_seq !ground_depth)
+	  | Ids l-> create_with_ref_list l !ground_depth
+	  | Bases l-> create_with_auto_hints l !ground_depth in
+      let result=ground_tac solver startseq gl in 
+	qflag:=backup;result
+    with e ->qflag:=backup;raise e
+      
+(* special for compatibility with Intuition 
+
+let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
+
+let defined_connectives=lazy
+  [[],EvalConstRef (destConst (constant "not"));
+   [],EvalConstRef (destConst (constant "iff"))]
+
+let normalize_evaluables=
+  onAllClauses
+    (function 
+	 None->unfold_in_concl (Lazy.force defined_connectives)
+       | Some id-> 
+	   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 ]
+END
+
+(* Obsolete since V8.0
+TACTIC EXTEND GTauto   
+  [ "GTauto" ] ->
+     [ gen_ground_tac false (Some fail_solver) Void ]   
+END
+*)
+
+TACTIC EXTEND GIntuition
+  [ "GIntuition" tactic_opt(t) ] ->
+     [ gen_ground_tac false (option_app eval_tactic t) Void ]
+END
diff --git a/contrib/first-order/ground.ml b/contrib/first-order/ground.ml
new file mode 100644
index 00000000..23e27a3c
--- /dev/null
+++ b/contrib/first-order/ground.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: ground.ml,v 1.5.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Formula
+open Sequent
+open Rules
+open Instances
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Libnames
+
+(*
+let old_search=ref !Auto.searchtable 
+
+(* I use this solution as a means to know whether hints have changed, 
+but this prevents the GC from collecting the previous table, 
+resulting in some limited space wasting*)
+
+let update_flags ()=
+  if not ( !Auto.searchtable == !old_search ) then
+    begin
+      old_search:=!Auto.searchtable;
+      let predref=ref Names.KNpred.empty in
+      let f p_a_t = 
+	match p_a_t.Auto.code with
+	    Auto.Unfold_nth (ConstRef kn)->
+	      predref:=Names.KNpred.add kn !predref
+	  | _ ->() in
+      let g _ l=List.iter f l in
+      let h _ hdb=Auto.Hint_db.iter g hdb in
+	Util.Stringmap.iter h !Auto.searchtable;
+	red_flags:=
+	Closure.RedFlags.red_add_transparent 
+	  Closure.betaiotazeta (Names.Idpred.full,!predref)
+    end
+*)
+
+let update_flags ()=
+  let predref=ref Names.KNpred.empty in
+  let f coe=
+    try
+      let kn=destConst (Classops.get_coercion_value coe) in
+	predref:=Names.KNpred.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)
+
+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));
+    tclORELSE (axiom_tac seq.gl seq)
+      begin
+	try      
+	  let (hd,seq1)=take_formula seq  
+	  and re_add s=re_add_formula_list skipped s in
+	  let continue=toptac [] 
+	  and backtrack gl=toptac (hd::skipped) seq1 gl in
+	    match hd.pat with
+		Right rpat->
+		  begin
+		    match rpat with
+			Rand->
+			  and_tac backtrack continue (re_add seq1)
+		      | Rforall->
+			  let backtrack1=
+			    if !qflag then 
+			      tclFAIL 0 "reversible in 1st order mode"
+			    else
+			      backtrack in
+			    forall_tac backtrack continue (re_add seq1)
+		      | Rarrow->
+			  arrow_tac backtrack continue (re_add seq1)
+		      | Ror->
+			  or_tac  backtrack continue (re_add seq1)
+		      | Rfalse->backtrack 
+		      | Rexists(i,dom,triv)->
+			  let (lfp,seq2)=collect_quantified seq in
+			  let backtrack2=toptac (lfp@skipped) seq2 in
+			    if  !qflag && seq.depth>0 then 
+			      quantified_tac lfp backtrack2 
+				continue (re_add seq)
+			    else
+			      backtrack2 (* need special backtracking *)
+		  end
+	      | Left lpat->
+		  begin
+		    match lpat with
+			Lfalse->
+			  left_false_tac hd.id
+		      | Land ind->
+			  left_and_tac ind backtrack 
+			  hd.id continue (re_add seq1)
+		      | Lor ind->
+			  left_or_tac ind backtrack 
+			  hd.id continue (re_add seq1)
+		      | Lforall (_,_,_)->
+			  let (lfp,seq2)=collect_quantified seq in
+			  let backtrack2=toptac (lfp@skipped) seq2 in
+			    if  !qflag && seq.depth>0 then 
+			      quantified_tac lfp backtrack2 
+				continue (re_add seq)
+			    else
+			      backtrack2 (* need special backtracking *)
+  		      | Lexists ind ->
+			  if !qflag then 
+			    left_exists_tac ind hd.id continue (re_add seq1)
+			  else backtrack
+		      | LA (typ,lap)->
+			  let la_tac=
+			    begin
+			      match lap with
+				  LLatom -> backtrack 
+				| LLand (ind,largs) | LLor(ind,largs) 
+				| LLfalse (ind,largs)->
+				    (ll_ind_tac ind largs backtrack 
+				       hd.id continue (re_add seq1)) 
+				| LLforall p ->	      
+				    if seq.depth>0 && !qflag then 
+				      (ll_forall_tac p backtrack 
+					 hd.id continue (re_add seq1))
+				    else backtrack
+				| LLexists (ind,l) ->
+				    if !qflag then
+				      ll_ind_tac ind l backtrack
+					hd.id continue (re_add seq1)
+				    else
+				      backtrack
+				| LLarrow (a,b,c) ->	      
+				    (ll_arrow_tac a b c backtrack
+				       hd.id continue (re_add seq1))
+			    end in			 
+			    ll_atom_tac typ la_tac hd.id continue (re_add seq1)
+		  end
+	    with Heap.EmptyHeap->solver
+      end gl in
+    wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
+      
diff --git a/contrib/first-order/ground.mli b/contrib/first-order/ground.mli
new file mode 100644
index 00000000..cfc17e77
--- /dev/null
+++ b/contrib/first-order/ground.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ground.mli,v 1.1.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+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
new file mode 100644
index 00000000..e2e9e2ef
--- /dev/null
+++ b/contrib/first-order/instances.ml
@@ -0,0 +1,203 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: instances.ml,v 1.9.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+
+open Formula
+open Sequent
+open Unify
+open Rules
+open Util
+open Term
+open Rawterm
+open Tacmach
+open Tactics
+open Tacticals
+open Termops
+open Reductionops
+open Declarations
+open Formula
+open Sequent
+open Names
+open Libnames
+
+let compare_instance inst1 inst2=
+	match inst1,inst2 with
+	    Phantom(d1),Phantom(d2)->
+	      (OrderedConstr.compare d1 d2)
+	  | Real((m1,c1),n1),Real((m2,c2),n2)->
+	      ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2
+	  | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
+	  | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
+
+let compare_gr id1 id2=
+  if id1==id2 then 0 else
+    if id1==dummy_id then 1 
+    else if id2==dummy_id then -1 
+    else Pervasives.compare id1 id2
+
+module OrderedInstance=
+struct
+  type t=instance * Libnames.global_reference
+  let compare (inst1,id1) (inst2,id2)=
+    (compare_instance =? compare_gr) inst2 inst1 id2 id1
+    (* we want a __decreasing__ total order *)
+end
+  
+module IS=Set.Make(OrderedInstance)
+
+let make_simple_atoms seq=
+  let ratoms=
+    match seq.glatom with
+	Some t->[t]
+      | None->[]
+  in {negative=seq.latoms;positive=ratoms}
+
+let do_sequent setref triv id seq i dom atoms=
+  let flag=ref true in
+  let phref=ref triv in
+  let do_atoms a1 a2 =
+    let do_pair t1 t2 = 
+      match unif_atoms i dom t1 t2 with
+	  None->()
+	| Some (Phantom _) ->phref:=true
+	| Some c ->flag:=false;setref:=IS.add (c,id) !setref in
+      List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive;
+      List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in
+    HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes;
+    do_atoms atoms (make_simple_atoms seq);
+    !flag && !phref 
+ 
+let match_one_quantified_hyp setref seq lf=
+  match lf.pat with 
+      Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
+	if do_sequent setref triv lf.id seq i dom lf.atoms then
+	  setref:=IS.add ((Phantom dom),lf.id) !setref 
+    | _ ->anomaly "can't happen" 
+
+let give_instances lf seq=
+  let setref=ref IS.empty in
+    List.iter (match_one_quantified_hyp setref seq) lf;
+    IS.elements !setref
+	  	  
+(* collector for the engine *)
+
+let rec collect_quantified seq=
+  try
+    let hd,seq1=take_formula seq in
+      (match hd.pat with 
+	   Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> 
+	     let (q,seq2)=collect_quantified seq1 in
+	       ((hd::q),seq2)
+	 | _->[],seq)
+  with Heap.EmptyHeap -> [],seq
+
+(* open instances processor *)
+
+let dummy_constr=mkMeta (-1)
+
+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 var_id=
+    if id==dummy_id then dummy_bvid else
+      let typ=pf_type_of gl (constr_of_reference id) in
+	(* since we know we will get a product, 
+	   reduction is not too expensive *)
+      let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
+	match nam with 
+	    Name id -> id
+	  | Anonymous ->  dummy_bvid in
+  let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
+  let rec aux n avoid=
+    if n=0 then [] else
+      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 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)
+	| _-> anomaly "can't happen" in
+  let ntt=Pretyping.understand evmap env (raux m rawt) in
+    Sign.decompose_lam_n_assum m ntt
+
+(* tactics   *)
+
+let left_instance_tac (inst,id) continue seq=
+  match inst with
+      Phantom dom->
+	if lookup (id,None) seq then 
+	  tclFAIL 0 "already done"
+	else
+	  tclTHENS (cut dom) 
+	    [tclTHENLIST
+	       [introf;
+		(fun gls->generalize 
+		   [mkApp(constr_of_reference id,
+			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
+		introf;
+		tclSOLVE [wrap 1 false continue 
+			    (deepen (record (id,None) seq))]];
+	    tclTRY assumption]
+    | Real((m,t) as c,_)->
+	if lookup (id,Some c) seq then 
+	  tclFAIL 0 "already done" 
+	else 
+	  let special_generalize=
+	    if m>0 then 
+	      fun gl-> 
+		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
+		  generalize [gt] gl
+	    else
+	      generalize [mkApp(constr_of_reference id,[|t|])]
+	  in
+	    tclTHENLIST 
+	      [special_generalize;
+	       introf; 
+	       tclSOLVE 
+		 [wrap 1 false continue (deepen (record (id,Some c) seq))]]
+	      
+let right_instance_tac inst continue seq=
+  match inst with
+      Phantom dom ->
+	tclTHENS (cut dom) 
+	[tclTHENLIST
+	   [introf;
+	    (fun gls->
+	       split (Rawterm.ImplicitBindings 
+			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
+	    tclSOLVE [wrap 0 true continue (deepen seq)]];
+	 tclTRY assumption] 
+    | Real ((0,t),_) ->
+	(tclTHEN (split (Rawterm.ImplicitBindings [t]))
+	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
+    | Real ((m,t),_) ->
+	tclFAIL 0 "not implemented ... yet"
+
+let instance_tac inst=
+  if (snd inst)==dummy_id then 
+    right_instance_tac (fst inst)
+  else
+    left_instance_tac inst
+
+let quantified_tac lf backtrack continue seq gl=
+  let insts=give_instances lf seq in
+    tclORELSE
+      (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts))
+      backtrack gl
+
+ 
diff --git a/contrib/first-order/instances.mli b/contrib/first-order/instances.mli
new file mode 100644
index 00000000..509bfc70
--- /dev/null
+++ b/contrib/first-order/instances.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: instances.mli,v 1.3.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+
+open Term
+open Tacmach
+open Names
+open Libnames
+open Rules
+  
+val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
+
+val give_instances : Formula.t list -> Sequent.t -> 
+  (Unify.instance * global_reference) list
+
+val quantified_tac : Formula.t list -> seqtac with_backtracking
+
+
+
+
diff --git a/contrib/first-order/rules.ml b/contrib/first-order/rules.ml
new file mode 100644
index 00000000..7fbefa37
--- /dev/null
+++ b/contrib/first-order/rules.ml
@@ -0,0 +1,214 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rules.ml,v 1.24.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Termops
+open Declarations
+open Formula
+open Sequent
+open Libnames
+
+type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
+
+type lseqtac= global_reference -> seqtac
+
+type 'a with_backtracking = tactic -> 'a
+
+let wrap n b continue seq gls=
+  check_for_interrupt ();
+  let nc=pf_hyps gls in
+  let env=pf_env gls in
+  let rec aux i nc ctx=
+    if i<=0 then seq else 
+      match nc with
+	  []->anomaly "Not the expected number of hyps"
+	| ((id,_,typ) as nd)::q->  
+	    if occur_var env id (pf_concl gls) || 
+	      List.exists (occur_var_in_decl env id) ctx then
+		(aux (i-1) q (nd::ctx))
+	    else
+	      add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in
+  let seq1=aux n nc [] in
+  let seq2=if b then 
+    add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
+    continue seq2 gls
+
+let id_of_global=function
+    VarRef id->id
+  | _->assert false
+
+let clear_global=function
+    VarRef id->clear [id]
+  | _->tclIDTAC
+      
+
+(* 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" 
+
+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)|])];
+	 clear_global id;
+	 intro]
+    with Not_found->tclFAIL 0 "No link") 
+    (wrap 1 false continue seq) backtrack 
+
+(* right connectives rules *)
+
+let and_tac backtrack continue seq=
+  tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
+
+let or_tac backtrack continue seq=
+  tclORELSE 
+    (any_constructor (Some (tclCOMPLETE (wrap 0 true continue seq))))
+    backtrack
+
+let arrow_tac backtrack continue seq=
+  tclIFTHENELSE intro (wrap 1 true continue seq)
+    (tclORELSE
+       (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq)))
+       backtrack)
+(* left connectives rules *)
+
+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);
+       clear_global id; 
+       tclDO n intro])
+     (wrap n false continue seq)
+     backtrack gls
+
+let left_or_tac ind backtrack id continue seq gls=
+  let v=construct_nhyps ind gls in  
+  let f n=
+    tclTHENLIST
+      [clear_global id;
+       tclDO n intro;
+       wrap n false continue seq] in
+    tclIFTHENSVELSE
+      (simplest_elim (constr_of_reference id))
+      (Array.map f v)
+      backtrack gls
+
+let left_false_tac id=
+  simplest_elim (constr_of_reference id)
+
+(* left arrow connective rules *)
+
+(* We use this function for false, and, or, exists *)
+
+let ll_ind_tac ind largs backtrack id continue seq gl= 
+     let rcs=ind_hyps 0 ind largs gl in
+     let vargs=Array.of_list largs in
+	     (* construire le terme  H->B, le generaliser etc *)   
+     let myterm i=
+       let rc=rcs.(i) in
+       let p=List.length rc in
+       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
+	 Sign.it_mkLambda_or_LetIn head rc in
+       let lp=Array.length rcs in
+       let newhyps=list_tabulate myterm lp in
+	 tclIFTHENELSE
+	   (tclTHENLIST 
+	      [generalize newhyps;
+	       clear_global id;
+	       tclDO lp intro])
+	   (wrap lp false continue seq) backtrack 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),
+			 [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
+    tclORELSE
+      (tclTHENS (cut c)
+	 [tclTHENLIST
+	    [introf;
+	     clear_global id;
+	     wrap 1 false continue seq];
+	  tclTHENS (cut cc) 
+            [exact_no_check (constr_of_reference id); 
+	     tclTHENLIST 
+	       [generalize [d];
+		clear_global id;
+		introf;
+		introf;
+		tclCOMPLETE (wrap 2 true continue seq)]]])
+      backtrack
+
+(* quantifier rules (easy side) *)
+
+let forall_tac backtrack continue seq=
+  tclORELSE
+    (tclIFTHENELSE intro (wrap 0 true continue seq)
+       (tclORELSE
+	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
+	  backtrack))
+    (if !qflag then 
+       tclFAIL 0 "reversible in 1st order mode"
+     else
+       backtrack)
+
+let left_exists_tac ind 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
+	
+let ll_forall_tac prod backtrack id continue seq=
+  tclORELSE
+    (tclTHENS (cut prod)
+       [tclTHENLIST
+	  [intro;
+	   (fun gls->
+	      let id0=pf_nth_hyp_id gls 1 in
+	      let term=mkApp((constr_of_reference id),[|mkVar(id0)|]) in
+		tclTHEN (generalize [term]) (clear [id0]) gls);  
+	   clear_global id;
+	   intro;
+	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
+	tclCOMPLETE (wrap 0 true continue (deepen seq))])
+    backtrack
+
+(* rules for instantiation with unification moved to instances.ml *)
+
+(* special for compatibility with old Intuition *)
+
+let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
+
+let defined_connectives=lazy
+  [[],EvalConstRef (destConst (constant "not"));
+   [],EvalConstRef (destConst (constant "iff"))]
+
+let normalize_evaluables=
+  onAllClauses
+    (function 
+	 None->unfold_in_concl (Lazy.force defined_connectives)
+       | Some (id,_,_)-> 
+	   unfold_in_hyp (Lazy.force defined_connectives) 
+	   (id,[],(Tacexpr.InHypTypeOnly,ref None)))
diff --git a/contrib/first-order/rules.mli b/contrib/first-order/rules.mli
new file mode 100644
index 00000000..eb4d81bd
--- /dev/null
+++ b/contrib/first-order/rules.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rules.mli,v 1.11.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Term
+open Tacmach
+open Names
+open Libnames
+
+type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
+
+type lseqtac= global_reference -> seqtac
+
+type 'a with_backtracking = tactic -> 'a
+
+val wrap : int -> bool -> seqtac
+
+val id_of_global: global_reference -> identifier
+
+val clear_global: global_reference -> tactic
+
+val axiom_tac : constr -> Sequent.t -> tactic
+
+val ll_atom_tac : constr -> lseqtac with_backtracking
+
+val and_tac : seqtac with_backtracking
+
+val or_tac : seqtac with_backtracking
+
+val arrow_tac : seqtac with_backtracking
+
+val left_and_tac : inductive -> lseqtac with_backtracking
+
+val left_or_tac : inductive -> lseqtac with_backtracking
+
+val left_false_tac : global_reference -> tactic
+
+val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking
+
+val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
+
+val forall_tac : seqtac with_backtracking
+
+val left_exists_tac : inductive -> lseqtac
+
+val ll_forall_tac : types -> lseqtac with_backtracking 
+
+val normalize_evaluables : tactic
diff --git a/contrib/first-order/sequent.ml b/contrib/first-order/sequent.ml
new file mode 100644
index 00000000..13215348
--- /dev/null
+++ b/contrib/first-order/sequent.ml
@@ -0,0 +1,303 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: sequent.ml,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Term
+open Util
+open Formula
+open Unify
+open Tacmach
+open Names
+open Libnames
+open Pp
+
+let newcnt ()=
+  let cnt=ref (-1) in
+    fun b->if b then incr cnt;!cnt
+
+let priority = (* pure heuristics, <=0 for non reversible *)
+  function
+      Right rf->
+	begin
+	  match rf with
+	      Rarrow               -> 100
+	    | Rand                 ->  40 
+	    | Ror                  -> -15
+	    | Rfalse               -> -50
+	    | Rforall              -> 100
+	    | Rexists (_,_,_)      -> -29
+	end
+    | Left lf ->
+	match lf with
+	    Lfalse                 -> 999
+	  | Land _                 ->  90
+	  | Lor _                  ->  40
+	  | Lforall (_,_,_)        -> -30 
+	  | Lexists _              ->  60
+	  | LA(_,lap) ->
+	      match lap with
+		  LLatom           ->   0
+		| LLfalse (_,_)    -> 100
+		| LLand (_,_)      ->  80
+		| LLor (_,_)       ->  70
+		| LLforall _       -> -20
+		| LLexists (_,_)   ->  50
+		| LLarrow  (_,_,_) -> -10 
+
+let left_reversible lpat=(priority lpat)>0
+
+module OrderedFormula=
+struct
+  type t=Formula.t
+  let compare e1 e2=
+	(priority e1.pat) - (priority e2.pat)
+end
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let rec compare_list f l1 l2=
+  match l1,l2 with
+      [],[]-> 0
+    | [],_ -> -1
+    | _,[] -> 1
+    | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
+
+let compare_array f v1 v2=  
+  let l=Array.length v1 in
+  let c=l - Array.length v2 in
+    if c=0 then
+      let rec comp_aux i=
+	if i<0 then 0 
+	else
+	  let ci=f v1.(i) v2.(i) in
+	    if ci=0 then 
+	      comp_aux (i-1)
+	    else ci
+      in comp_aux (l-1)
+    else c
+
+let compare_constr_int f t1 t2 =
+  match kind_of_term t1, kind_of_term t2 with
+    | Rel n1, Rel n2 -> n1 - n2
+    | 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
+    | Prod (_,t1,c1), Prod (_,t2,c2) 
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+	(f =? f) t1 t2 c1 c2 
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> 
+	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+    | App (_,_), App (_,_) ->
+	let c1,l1=decompose_app t1 
+	and c2,l2=decompose_app t2 in
+	  (f =? (compare_list f)) c1 c2 l1 l2
+    | Evar (e1,l1), Evar (e2,l2) -> 
+	((-) =? (compare_array f)) e1 e2 l1 l2
+    | Const c1, Const c2 -> Pervasives.compare c1 c2
+    | Ind c1, Ind c2 -> Pervasives.compare c1 c2
+    | Construct c1, Construct c2 -> Pervasives.compare c1 c2
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+	((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+	((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
+	ln1 ln2 tl1 tl2 bl1 bl2
+    | _ -> Pervasives.compare t1 t2
+
+let rec compare_constr m n=
+  compare_constr_int compare_constr m n
+    
+module OrderedConstr=
+struct
+  type t=constr
+  let compare=compare_constr
+end
+
+type h_item = global_reference * (int*constr) option
+
+module Hitem=
+struct 
+  type t = h_item
+  let compare (id1,co1) (id2,co2)=
+    (Pervasives.compare 
+     =? (fun oc1 oc2 ->
+	   match oc1,oc2 with 
+	       Some (m1,c1),Some (m2,c2) -> 
+		 ((-) =? OrderedConstr.compare) m1 m2 c1 c2
+	     | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
+end
+
+module CM=Map.Make(OrderedConstr)
+
+module History=Set.Make(Hitem)
+
+let cm_add typ nam cm=
+  try 
+    let l=CM.find typ cm in CM.add typ (nam::l) cm
+  with
+      Not_found->CM.add typ [nam] cm
+	
+let cm_remove typ nam cm=
+  try
+    let l=CM.find typ cm in 
+    let l0=List.filter (fun id->id<>nam) l in
+      match l0 with 
+	  []->CM.remove typ cm
+	| _ ->CM.add typ l0 cm
+      with Not_found ->cm
+
+module HP=Heap.Functional(OrderedFormula)
+
+type t=
+    {redexes:HP.t;
+     context:(global_reference list) CM.t;
+     latoms:constr list;
+     gl:types;
+     glatom:constr option;
+     cnt:counter;
+     history:History.t;
+     depth:int}
+
+let deepen seq={seq with depth=seq.depth-1}
+ 
+let record item seq={seq with history=History.add item seq.history}
+
+let lookup item seq=
+  History.mem item seq.history ||
+  match item with
+      (_,None)->false
+    | (id,Some ((m,t) as c))->
+	let p (id2,o)=
+	  match o with
+	      None -> false
+	    | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in
+	  History.exists p seq.history
+
+let rec add_formula side nam t seq gl=
+  match build_formula side nam t gl seq.cnt with
+      Left f->
+	begin
+	  match side with
+	      Concl ->
+		{seq with 
+		   redexes=HP.add f seq.redexes;
+		   gl=f.constr;
+		   glatom=None}
+	    | _ ->
+		{seq with 
+		   redexes=HP.add f seq.redexes;
+		   context=cm_add f.constr nam seq.context}
+	end
+    | Right t->
+	match side with
+	    Concl ->
+	      {seq with gl=t;glatom=Some t}
+	  | _ ->
+	      {seq with 
+		 context=cm_add t nam seq.context;
+		 latoms=t::seq.latoms}
+	      
+let re_add_formula_list lf seq=
+  let do_one f cm=
+    if f.id == dummy_id then cm
+    else cm_add f.constr f.id cm in
+  {seq with 
+     redexes=List.fold_right HP.add lf seq.redexes;
+     context=List.fold_right do_one lf seq.context}
+
+let find_left t seq=List.hd (CM.find t seq.context)
+
+(*let rev_left seq=
+  try
+    let lpat=(HP.maximum seq.redexes).pat in
+      left_reversible lpat
+  with Heap.EmptyHeap -> false
+*)
+let no_formula seq=
+  seq.redexes=HP.empty
+
+let rec take_formula seq=
+  let hd=HP.maximum seq.redexes
+  and hp=HP.remove seq.redexes in
+    if hd.id == dummy_id then
+      let nseq={seq with redexes=hp} in
+	if seq.gl==hd.constr then 
+	  hd,nseq
+	else
+	  take_formula nseq (* discarding deprecated goal *)
+    else
+      hd,{seq with 
+	    redexes=hp;
+	    context=cm_remove hd.constr hd.id seq.context}
+	
+let empty_seq depth=
+  {redexes=HP.empty;   
+   context=CM.empty;
+   latoms=[];
+   gl=(mkMeta 1);
+   glatom=None;
+   cnt=newcnt ();
+   history=History.empty;
+   depth=depth}
+
+let create_with_ref_list l depth gl=
+  let f gr seq=
+    let c=constr_of_reference 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)
+
+open Auto
+
+let create_with_auto_hints l depth gl=
+  let seqref=ref (empty_seq depth) in
+  let f p_a_t =
+    match p_a_t.code with
+	Res_pf (c,_) | Give_exact c
+      | Res_pf_THEN_trivial_fail (c,_) ->
+	  (try 
+	     let gr=reference_of_constr c in 
+	     let typ=(pf_type_of gl c) in
+	       seqref:=add_formula Hint gr typ !seqref gl
+	   with Not_found->())
+      | _-> () in
+  let g _ l=List.iter f l in
+  let h dbname=
+    let hdb=
+      try
+	Util.Stringmap.find dbname !searchtable 
+      with Not_found-> 
+	error ("Firstorder: "^dbname^" : No such Hint database") in
+      Hint_db.iter g hdb in
+    List.iter h l;
+    !seqref
+
+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 ++ 
+      str " : " ++
+      Ppconstr.pr_constr xc ++ 
+      cut () ++ 
+      s in
+    msgnl (v 0 
+	     (str "-----" ++ 
+	      cut () ++
+	      CM.fold print_entry map (mt ()) ++
+	      str "-----"))
+
+	
diff --git a/contrib/first-order/sequent.mli b/contrib/first-order/sequent.mli
new file mode 100644
index 00000000..df27d2ff
--- /dev/null
+++ b/contrib/first-order/sequent.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: sequent.mli,v 1.8.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Term
+open Util
+open Formula
+open Tacmach
+open Names
+open Libnames
+
+module OrderedConstr: Set.OrderedType with type t=constr
+
+module CM: Map.S with type key=constr
+
+type h_item = global_reference * (int*constr) option
+
+module History: Set.S with type elt = h_item
+
+val cm_add : constr -> global_reference -> global_reference list CM.t ->
+  global_reference list CM.t
+
+val cm_remove : constr -> global_reference -> global_reference list CM.t ->
+  global_reference list CM.t
+
+module HP: Heap.S with type elt=Formula.t
+
+type t = {redexes:HP.t;
+	  context: global_reference list CM.t;
+	  latoms:constr list;
+	  gl:types;
+	  glatom:constr option;
+	  cnt:counter;
+	  history:History.t;
+	  depth:int}
+
+val deepen: t -> t
+
+val record: h_item -> t -> t
+
+val lookup: h_item -> t -> bool
+
+val add_formula : side -> global_reference -> constr -> t -> 
+  Proof_type.goal sigma -> t
+
+val re_add_formula_list : Formula.t list -> t -> t
+
+val find_left : constr -> t -> global_reference
+
+val take_formula : t -> Formula.t * t
+
+val empty_seq : int -> t
+
+val create_with_ref_list : global_reference list ->
+  int -> Proof_type.goal sigma -> t
+
+val create_with_auto_hints : Auto.hint_db_name list -> 
+  int -> Proof_type.goal sigma -> t
+
+val print_cmap: global_reference list CM.t -> unit 
diff --git a/contrib/first-order/unify.ml b/contrib/first-order/unify.ml
new file mode 100644
index 00000000..1186fb90
--- /dev/null
+++ b/contrib/first-order/unify.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: unify.ml,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ i*)
+
+open Util
+open Formula 
+open Tacmach
+open Term
+open Names
+open Termops
+open Reductionops
+
+exception UFAIL of constr*constr
+
+(* 
+   RIGID-only Martelli-Montanari style unification for CLOSED terms 
+   I repeat : t1 and t2 must NOT have ANY free deBruijn                        
+   sigma is kept normal with respect to itself but is lazily applied 
+   to the equation set. Raises UFAIL with a pair of  terms 
+*)
+
+let unif t1 t2= 
+  let bige=Queue.create () 
+  and sigma=ref [] in
+  let bind i t=
+    sigma:=(i,t)::
+      (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in
+  let rec head_reduce t= 
+    (* forbids non-sigma-normal meta in head position*)
+    match kind_of_term t with
+	Meta i->
+	  (try 
+	     head_reduce (List.assoc i !sigma) 
+	   with Not_found->t)
+      | _->t in 
+    Queue.add (t1,t2) bige;
+    try while true do
+      let t1,t2=Queue.take bige in
+      let nt1=head_reduce (whd_betaiotazeta t1) 
+      and nt2=head_reduce (whd_betaiotazeta t2) in
+	match (kind_of_term nt1),(kind_of_term nt2) with
+	    Meta i,Meta j-> 
+	      if i<>j then 
+		if i<j then bind j nt1
+		else bind i nt2
+	  | Meta i,_ ->
+	      let t=subst_meta !sigma nt2 in
+		if Intset.is_empty (free_rels t) && 
+		  not (occur_term (mkMeta i) t) then
+		    bind i t else raise (UFAIL(nt1,nt2))
+	  | _,Meta i -> 
+	      let t=subst_meta !sigma nt1 in
+		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 
+	  | (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)->
+	      Queue.add (pa,pb) bige;
+	      Queue.add (ca,cb) bige;
+	      let l=Array.length va in
+		if l<>(Array.length vb) then 
+		  raise (UFAIL (nt1,nt2))
+		else 
+		  for i=0 to l-1 do
+		    Queue.add (va.(i),vb.(i)) bige
+		  done	  
+	  | App(ha,va),App(hb,vb)->
+	      Queue.add (ha,hb) bige;
+	      let l=Array.length va in
+		if l<>(Array.length vb) then 
+		  raise (UFAIL (nt1,nt2))
+		else 
+		  for i=0 to l-1 do
+		    Queue.add (va.(i),vb.(i)) bige
+		  done
+	  | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
+    done;
+      assert false 
+	(* this place is unreachable but needed for the sake of typing *)
+    with Queue.Empty-> !sigma
+
+let value i t=
+  let add x y=
+    if x<0 then y else if y<0 then x else x+y in
+  let tref=mkMeta i in
+  let rec vaux term=
+    if term=tref then 0 else 
+      let f v t=add v (vaux t) in
+      let vr=fold_constr f (-1) term in
+	if vr<0 then -1 else vr+1 in
+    vaux t
+	  
+type instance=
+    Real of (int*constr)*int 
+  | Phantom of constr 
+
+let mk_rel_inst t=
+  let new_rel=ref 1 in
+  let rel_env=ref [] in
+  let rec renum_rec d t=
+    match kind_of_term t with 
+	Meta n->
+	  (try 
+	     mkRel (d+(List.assoc n !rel_env))
+	   with Not_found->
+	     let m= !new_rel in
+	       incr new_rel;
+	       rel_env:=(n,m) :: !rel_env;
+	       mkRel (m+d))
+      | _ -> map_constr_with_binders succ renum_rec d t
+  in 
+  let nt=renum_rec 0 t in (!new_rel - 1,nt)
+
+let unif_atoms i dom t1 t2=
+  try 
+    let t=List.assoc i (unif t1 t2) in 
+      if isMeta t then Some (Phantom dom)
+      else Some (Real(mk_rel_inst t,value i t1))
+  with
+      UFAIL(_,_) ->None
+    | Not_found ->Some (Phantom dom)
+	   	  
+let renum_metas_from k n t= (* requires n = max (free_rels t) *)
+  let l=list_tabulate (fun i->mkMeta (k+i)) n in
+    substl l t
+
+let more_general (m1,t1) (m2,t2)=
+  let mt1=renum_metas_from 0 m1 t1
+  and mt2=renum_metas_from m1 m2 t2 in
+    try 
+      let sigma=unif mt1 mt2 in
+      let p (n,t)= n<m1 || isMeta t in
+	List.for_all p sigma
+    with UFAIL(_,_)->false
diff --git a/contrib/first-order/unify.mli b/contrib/first-order/unify.mli
new file mode 100644
index 00000000..dd9dbdec
--- /dev/null
+++ b/contrib/first-order/unify.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: unify.mli,v 1.7.2.1 2004/07/16 19:30:10 herbelin Exp $ *)
+
+open Term
+
+exception UFAIL of constr*constr
+
+val unif : constr -> constr -> (int*constr) list
+
+type instance=
+    Real of (int*constr)*int (* nb trous*terme*valeur heuristique *)
+  | Phantom of constr        (* domaine de quantification *)
+
+val unif_atoms : metavariable -> constr -> constr -> constr -> instance option
+
+val more_general : (int*constr) -> (int*constr) -> bool
diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v
new file mode 100644
index 00000000..f6faf94c
--- /dev/null
+++ b/contrib/fourier/Fourier.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Fourier.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *)
+
+(* "Fourier's method to solve linear inequations/equations systems.".*)
+
+Declare ML Module "quote".
+Declare ML Module "ring".
+Declare ML Module "fourier".
+Declare ML Module "fourierR".
+Declare ML Module "field".
+
+Require Export Fourier_util.
+Require Export Field.
+Require Export DiscrR.
+
+Ltac fourier := abstract (fourierz; field; discrR).
+
+Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v
new file mode 100644
index 00000000..abcd4449
--- /dev/null
+++ b/contrib/fourier/Fourier_util.v
@@ -0,0 +1,222 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *)
+
+Require Export Rbase.
+Comments "Lemmas used by the tactic Fourier".
+
+Open Scope R_scope.
+ 
+Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
+intros; apply Rmult_lt_compat_l; assumption.
+Qed.
+ 
+Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
+red in |- *.
+intros.
+case H; auto with real.
+Qed.
+ 
+Lemma Rfourier_lt_lt :
+ forall x1 y1 x2 y2 a:R,
+   x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+apply Rplus_lt_compat.
+try exact H.
+apply Rfourier_lt.
+try exact H0.
+try exact H1.
+Qed.
+ 
+Lemma Rfourier_lt_le :
+ forall x1 y1 x2 y2 a:R,
+   x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+case H0; intros.
+apply Rplus_lt_compat.
+try exact H.
+apply Rfourier_lt; auto with real.
+rewrite H2.
+rewrite (Rplus_comm y1 (a * y2)).
+rewrite (Rplus_comm x1 (a * y2)).
+apply Rplus_lt_compat_l.
+try exact H.
+Qed.
+ 
+Lemma Rfourier_le_lt :
+ forall x1 y1 x2 y2 a:R,
+   x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + 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 Rplus_lt_compat_l.
+apply Rfourier_lt; auto with real.
+Qed.
+ 
+Lemma Rfourier_le_le :
+ forall x1 y1 x2 y2 a:R,
+   x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+case H0; intros.
+red in |- *.
+left; try assumption.
+apply Rfourier_le_lt; auto with real.
+rewrite H2.
+case H; intros.
+red in |- *.
+left; try assumption.
+rewrite (Rplus_comm x1 (a * y2)).
+rewrite (Rplus_comm y1 (a * y2)).
+apply Rplus_lt_compat_l.
+try exact H3.
+rewrite H3.
+red in |- *.
+right; try assumption.
+auto with real.
+Qed.
+ 
+Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
+intros x H; try assumption.
+rewrite Rplus_comm.
+apply Rle_lt_0_plus_1.
+red in |- *; auto with real.
+Qed.
+ 
+Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
+intros x y H H0; try assumption.
+replace 0 with (x * 0).
+apply Rmult_lt_compat_l; auto with real.
+ring.
+Qed.
+ 
+Lemma Rlt_zero_1 : 0 < 1.
+exact Rlt_0_1.
+Qed.
+ 
+Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
+intros x H; try assumption.
+case H; intros.
+red in |- *.
+left; try assumption.
+apply Rlt_zero_pos_plus1; auto with real.
+rewrite <- H0.
+replace (1 + 0) with 1.
+red in |- *; left.
+exact Rlt_zero_1.
+ring.
+Qed.
+ 
+Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
+intros x y H H0; try assumption.
+case H; intros.
+red in |- *; left.
+apply Rlt_mult_inv_pos; auto with real.
+rewrite <- H1.
+red in |- *; right; ring.
+Qed.
+ 
+Lemma Rle_zero_1 : 0 <= 1.
+red in |- *; left.
+exact Rlt_zero_1.
+Qed.
+ 
+Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
+intros n d H; red in |- *; intros H0; try exact H0.
+generalize (Rgt_not_le 0 (n * / d)).
+intros H1; elim H1; try assumption.
+replace (n * / d) with (- - (n * / d)).
+replace 0 with (- -0).
+replace (- (n * / d)) with (- n * / d).
+replace (-0) with 0.
+red in |- *.
+apply Ropp_gt_lt_contravar.
+red in |- *.
+exact H0.
+ring.
+ring.
+ring.
+ring.
+Qed.
+ 
+Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
+intros x; try assumption.
+replace (0 * x) with 0.
+apply Rlt_irrefl.
+ring.
+Qed.
+ 
+Lemma Rlt_not_le : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
+intros n d H; try assumption.
+apply Rgt_not_le.
+replace 0 with (-0).
+replace (- n * / d) with (- (n * / d)).
+apply Ropp_lt_gt_contravar.
+try exact H.
+ring.
+ring.
+Qed.
+ 
+Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
+unfold not in |- *; intros.
+apply H.
+apply Rplus_lt_reg_r with x.
+replace (x + 0) with x.
+replace (x + (y - x)) with y.
+try exact H0.
+ring.
+ring.
+Qed.
+ 
+Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
+unfold not in |- *; intros.
+apply H.
+case H0; intros.
+left.
+apply Rplus_lt_reg_r with x.
+replace (x + 0) with x.
+replace (x + (y - x)) with y.
+try exact H1.
+ring.
+ring.
+right.
+rewrite H1; ring.
+Qed.
+ 
+Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
+unfold Rgt in |- *; intros; assumption.
+Qed.
+ 
+Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
+intros x y; exact (Rge_le y x).
+Qed.
+ 
+Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
+exact Req_le.
+Qed.
+ 
+Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
+exact Req_le_sym.
+Qed.
+ 
+Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
+exact Rnot_ge_lt.
+Qed.
+ 
+Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
+exact Rnot_gt_le.
+Qed.
+ 
+Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
+exact Rnot_le_lt.
+Qed.
+ 
+Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
+exact Rnot_lt_ge.
+Qed.
diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml
new file mode 100644
index 00000000..f5763c34
--- /dev/null
+++ b/contrib/fourier/fourier.ml
@@ -0,0 +1,205 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.ml,v 1.2.16.1 2004/07/16 19:30:11 herbelin Exp $ *)
+
+(* Méthode d'élimination de Fourier *)
+(* Référence:
+Auteur(s) : Fourier, Jean-Baptiste-Joseph
+ 
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+ 
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+ 
+Pages: 326-327
+
+http://gallica.bnf.fr/
+*)
+
+(* Un peu de calcul sur les rationnels... 
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
+*)
+type rational = {num:int;
+                 den:int}
+;;
+let print_rational x =
+        print_int x.num;
+        print_string "/";
+        print_int x.den
+;;
+
+let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
+
+
+let r0 = {num=0;den=1};;
+let r1 = {num=1;den=1};;
+
+let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
+              if x.num=0 then r0
+              else (let d=pgcd x.num x.den in
+		    let d= (if d<0 then -d else d) in
+                    {num=(x.num)/d;den=(x.den)/d});;
+ 
+let rop x = rnorm {num=(-x.num);den=x.den};;
+
+let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
+
+let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
+
+let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
+
+let rinv x = rnorm {num=x.den;den=x.num};;
+
+let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
+
+let rinf x y = x.num*y.den < y.num*x.den;;
+let rinfeq x y = x.num*y.den <= y.num*x.den;;
+
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+c1x1+...+cnxn < d si strict=true, <= sinon,
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+*)
+
+type ineq = {coef:rational list;
+             hist:rational list;
+             strict:bool};;
+
+let pop x l = l:=x::(!l);;
+
+(* sépare la liste d'inéquations s selon que leur premier coefficient est 
+négatif, nul ou positif. *)
+let partitionne s =
+   let lpos=ref [] in
+   let lneg=ref [] in
+   let lnul=ref [] in
+   List.iter (fun ie -> match ie.coef with
+                        [] ->  raise (Failure "empty ineq")
+                       |(c::r) -> if rinf c r0
+           	                  then pop ie lneg
+                                  else if rinf r0 c then pop ie lpos
+                                              else pop ie lnul)
+             s;
+   [!lneg;!lnul;!lpos]
+;;
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
+=
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
+ ...
+ {équation n, [0;0;...;1], sn}]
+*)
+let add_hist le =
+   let n = List.length le in
+   let i=ref 0 in
+   List.map (fun (ie,s) -> 
+              let h =ref [] in
+              for k=1 to (n-(!i)-1) do pop r0 h; done;
+              pop r1 h;
+              for k=1 to !i do pop r0 h; done;
+              i:=!i+1;
+              {coef=ie;hist=(!h);strict=s})
+             le
+;;
+(* additionne deux inéquations *)      
+let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
+                      hist=List.map2 rplus ie1.hist ie2.hist;
+		      strict=ie1.strict || ie2.strict}
+;;
+(* multiplication d'une inéquation par un rationnel (positif) *)
+let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
+                     hist=List.map (fun x -> rmult a x) ie.hist;
+		     strict= ie.strict}
+;;
+(* on enlève le premier coefficient *)
+let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
+;;
+(* le premier coefficient: "tête" de l'inéquation *)
+let hd_coef ie = List.hd ie.coef
+;;
+
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+*)
+let deduce_add lneg lpos =
+   let res=ref [] in
+   List.iter (fun i1 ->
+		 List.iter (fun i2 ->
+				let a = rop (hd_coef i1) in
+				let b = hd_coef i2 in
+				pop (ie_tl (ie_add (ie_emult b i1)
+						   (ie_emult a i2))) res)
+		           lpos)
+             lneg;
+   !res
+;;
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
+*)
+let deduce1 s =
+    match (partitionne s) with 
+      [lneg;lnul;lpos] ->
+    let lnew = deduce_add lneg lpos in
+    (List.map ie_tl lnul)@lnew
+     |_->assert false
+;;
+(* algorithme de Fourier: on élimine successivement toutes les variables.
+*)
+let deduce lie =
+   let n = List.length (fst (List.hd lie)) in
+   let lie=ref (add_hist lie) in
+   for i=1 to n-1 do
+      lie:= deduce1 !lie;
+   done;
+   !lie
+;;
+
+(* donne [] si le système a des solutions,
+sinon donne [c,s,lc]
+où lc est la combinaison linéaire des inéquations de départ
+qui donne 0 < c si s=true
+       ou 0 <= c sinon
+cette inéquation étant absurde.
+*)
+let unsolvable lie =
+   let lr = deduce lie in
+   let res = ref [] in
+   (try (List.iter (fun e ->
+         match e with
+           {coef=[c];hist=lc;strict=s} ->
+		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s) 
+                  then (res := [c,s,lc];
+			raise (Failure "contradiction found"))
+          |_->assert false)
+			     lr)
+   with _ -> ());
+   !res
+;;
+
+(* Exemples:
+
+let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
+deduce test1;;
+unsolvable test1;;
+
+let test2=[
+[r1;r1;r0;r0;r0],false;
+[r0;r1;r1;r0;r0],false;
+[r0;r0;r1;r1;r0],false;
+[r0;r0;r0;r1;r1],false;
+[r1;r0;r0;r0;r1],false;
+[rop r1;rop r1;r0;r0;r0],false;
+[r0;rop r1;rop r1;r0;r0],false;
+[r0;r0;rop r1;rop r1;r0],false;
+[r0;r0;r0;rop r1;rop r1],false;
+[rop r1;r0;r0;r0;rop r1],false
+];;
+deduce test2;;
+unsolvable test2;;
+
+*)
\ No newline at end of file
diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml
new file mode 100644
index 00000000..49fa35da
--- /dev/null
+++ b/contrib/fourier/fourierR.ml
@@ -0,0 +1,630 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: fourierR.ml,v 1.14.2.2 2004/07/19 13:28:28 herbelin Exp $ *)
+
+
+
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients 
+des inéquations et équations sont entiers. En attendant la tactique Field.
+*)
+
+open Term
+open Tactics
+open Clenv
+open Names
+open Libnames
+open Tacticals
+open Tacmach
+open Fourier
+open Contradiction
+
+(******************************************************************************
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash 
+qui donne le coefficient d'un terme du calcul des constructions, 
+qui est zéro si le terme n'y est pas. 
+*)
+
+type flin = {fhom:(constr , rational)Hashtbl.t;
+             fcste:rational};;
+
+let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
+
+let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
+
+let flin_add f x c = 
+    let cx = flin_coef f x in
+    Hashtbl.remove f.fhom x;
+    Hashtbl.add f.fhom x (rplus cx c);
+    f
+;;
+let flin_add_cste f c = 
+    {fhom=f.fhom;
+     fcste=rplus f.fcste c}
+;;
+
+let flin_one () = flin_add_cste (flin_zero()) r1;;
+
+let flin_plus f1 f2 = 
+    let f3 = flin_zero() in
+    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
+    flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
+;;
+
+let flin_minus f1 f2 = 
+    let f3 = flin_zero() in
+    Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+    Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
+    flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
+;;
+let flin_emult a f =
+    let f2 = flin_zero() in
+    Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
+    flin_add_cste f2 (rmult a f.fcste);
+;;
+    
+(*****************************************************************************)
+open Vernacexpr
+
+type ineq = Rlt | Rle | Rgt | Rge
+
+let string_of_R_constant kn = 
+  match Names.repr_kn kn with
+    | MPfile dir, sec_dir, id when 
+	sec_dir = empty_dirpath && 
+	string_of_dirpath dir = "Coq.Reals.Rdefinitions" 
+	-> string_of_label id
+    | _ -> "constant_not_of_R"
+
+let rec string_of_R_constr c =
+ match kind_of_term c with
+   Cast (c,t) -> 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)
+  | App (c,args) ->
+      (match (string_of_R_constr c) with
+	 | "Ropp" -> 
+	     rop (rational_of_constr args.(0))
+	 | "Rinv" -> 
+	     rinv (rational_of_constr args.(0))
+	 | "Rmult" -> 
+	     rmult (rational_of_constr args.(0))
+                   (rational_of_constr args.(1))
+	 | "Rdiv" -> 
+	     rdiv (rational_of_constr args.(0))
+                  (rational_of_constr args.(1))
+	 | "Rplus" -> 
+	     rplus (rational_of_constr args.(0))
+                   (rational_of_constr args.(1))
+	 | "Rminus" -> 
+	     rminus (rational_of_constr args.(0))
+                    (rational_of_constr args.(1))
+	 | _ -> failwith "not a rational")
+  | Const kn ->
+      (match (string_of_R_constant kn) with
+	       "R1" -> r1
+              |"R0" -> r0
+              |  _ -> failwith "not a rational")
+  |  _ -> failwith "not a rational"
+;;
+
+let rec flin_of_constr c =
+  try(
+    match kind_of_term c with
+  | Cast (c,t) -> (flin_of_constr c)
+  | App (c,args) ->
+      (match (string_of_R_constr c) with
+	   "Ropp" -> 
+             flin_emult (rop r1) (flin_of_constr args.(0))
+	 | "Rplus"-> 
+             flin_plus (flin_of_constr args.(0))
+	               (flin_of_constr args.(1))
+	 | "Rminus"->
+             flin_minus (flin_of_constr args.(0))
+	                (flin_of_constr args.(1))
+	 | "Rmult"->
+	     (try (let a=(rational_of_constr args.(0)) in
+                     try (let b = (rational_of_constr args.(1)) in
+			    (flin_add_cste (flin_zero()) (rmult a b)))
+		     with _-> (flin_add (flin_zero())
+				 args.(1) 
+				 a))
+	      with _-> (flin_add (flin_zero())
+			  args.(0) 
+			  (rational_of_constr args.(1))))
+	 | "Rinv"->
+	     let a=(rational_of_constr args.(0)) in
+	       flin_add_cste (flin_zero()) (rinv a)
+	 | "Rdiv"->
+	     (let b=(rational_of_constr args.(1)) in
+		try (let a = (rational_of_constr args.(0)) in
+		       (flin_add_cste (flin_zero()) (rdiv a b)))
+		with _-> (flin_add (flin_zero())
+		            args.(0) 
+                            (rinv b)))
+         |_->assert false)
+  | Const c ->
+        (match (string_of_R_constant c) with
+	       "R1" -> flin_one ()
+              |"R0" -> flin_zero ()
+              |_-> assert false)
+  |_-> assert false)
+  with _ -> flin_add (flin_zero())
+                     c
+	             r1
+;;
+
+let flin_to_alist f =
+    let res=ref [] in
+    Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
+    !res
+;;
+
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
+*)
+type hineq={hname:constr; (* le nom de l'hypothèse *)
+            htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
+            hleft:constr;
+            hright:constr;
+            hflin:flin;
+            hstrict:bool}
+;;
+
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+*)
+let ineq1_of_constr (h,t) =
+    match (kind_of_term t) with
+       App (f,args) ->
+         (match kind_of_term f with
+           Const c when Array.length args = 2 ->
+             let t1= args.(0) in
+             let t2= args.(1) in
+            (match (string_of_R_constant c) with
+		 "Rlt" -> [{hname=h;
+                           htype="Rlt";
+		           hleft=t1;
+			   hright=t2;
+			   hflin= flin_minus (flin_of_constr t1)
+                                             (flin_of_constr t2);
+			   hstrict=true}]
+		|"Rgt" -> [{hname=h;
+                           htype="Rgt";
+		           hleft=t2;
+			   hright=t1;
+			   hflin= flin_minus (flin_of_constr t2)
+                                             (flin_of_constr t1);
+			   hstrict=true}]
+		|"Rle" -> [{hname=h;
+                           htype="Rle";
+		           hleft=t1;
+			   hright=t2;
+			   hflin= flin_minus (flin_of_constr t1)
+                                             (flin_of_constr t2);
+			   hstrict=false}]
+		|"Rge" -> [{hname=h;
+                           htype="Rge";
+		           hleft=t2;
+			   hright=t1;
+			   hflin= flin_minus (flin_of_constr t2)
+                                             (flin_of_constr t1);
+			   hstrict=false}]
+                |_->assert false)
+          | Ind (kn,i) ->
+	      if IndRef(kn,i) = Coqlib.glob_eqT then
+		           let t0= args.(0) in
+                           let t1= args.(1) in
+                           let t2= args.(2) in
+		    (match (kind_of_term t0) with
+                         Const c ->
+			   (match (string_of_R_constant c) with
+			      "R"->
+                         [{hname=h;
+                           htype="eqTLR";
+		           hleft=t1;
+			   hright=t2;
+			   hflin= flin_minus (flin_of_constr t1)
+                                             (flin_of_constr t2);
+			   hstrict=false};
+                          {hname=h;
+                           htype="eqTRL";
+		           hleft=t2;
+			   hright=t1;
+			   hflin= flin_minus (flin_of_constr t2)
+                                             (flin_of_constr t1);
+			   hstrict=false}]
+                           |_-> assert false)
+                         |_-> assert false)
+	      else
+		assert false
+          |_-> assert false)
+        |_-> assert false
+;;
+
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+*)
+
+let fourier_lineq lineq1 = 
+   let nvar=ref (-1) in
+   let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
+   List.iter (fun f ->
+               Hashtbl.iter (fun x c ->
+				 try (Hashtbl.find hvar x;())
+				 with _-> nvar:=(!nvar)+1;
+   				          Hashtbl.add hvar x (!nvar))
+                            f.hflin.fhom)
+             lineq1;
+   let sys= List.map (fun h->
+               let v=Array.create ((!nvar)+1) r0 in
+               Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) 
+                  h.hflin.fhom;
+               ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
+             lineq1 in
+   unsolvable sys
+;;
+
+(*********************************************************************)
+(* Defined constants *)
+
+let get = Lazy.force
+let constant = Coqlib.gen_constant "Fourier"
+
+(* Standard library *)
+open Coqlib
+let coq_sym_eqT = lazy (build_coq_sym_eqT ())
+let coq_False = lazy (build_coq_False ())
+let coq_not = lazy (build_coq_not ())
+let coq_eq = lazy (build_coq_eq ())
+
+(* Rdefinitions *)
+let constant_real = constant ["Reals";"Rdefinitions"]
+
+let coq_Rlt = lazy (constant_real "Rlt")
+let coq_Rgt = lazy (constant_real "Rgt")
+let coq_Rle = lazy (constant_real "Rle")
+let coq_Rge = lazy (constant_real "Rge")
+let coq_R = lazy (constant_real "R")
+let coq_Rminus = lazy (constant_real "Rminus")
+let coq_Rmult = lazy (constant_real "Rmult")
+let coq_Rplus = lazy (constant_real "Rplus")
+let coq_Ropp = lazy (constant_real "Ropp")
+let coq_Rinv = lazy (constant_real "Rinv")
+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")
+
+(* Fourier_util *)
+let constant_fourier = constant ["fourier";"Fourier_util"]
+
+let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1")
+let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1")
+let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1")
+let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos")
+let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero")
+let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1")
+let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos")
+let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0")
+let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt")
+let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt")
+let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le")
+let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le")
+let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le")
+
+let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt")
+let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le")
+let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt")
+let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge")
+let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt")
+let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le")
+let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt")
+let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le")
+let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt")
+let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le")
+let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt")
+let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le")
+let coq_Rlt_not_le = lazy (constant_fourier "Rlt_not_le")
+
+(******************************************************************************
+Construction de la preuve en cas de succès de la méthode de Fourier,
+i.e. on obtient une contradiction.
+*)
+let is_int x = (x.den)=1
+;;
+
+(* fraction = couple (num,den) *)
+let rec rational_to_fraction x= (x.num,x.den)
+;;
+    
+(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
+*)
+let int_to_real n =
+   let nn=abs n in
+   if nn=0
+   then get coq_R0
+   else
+     (let s=ref (get coq_R1) in
+      for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
+      if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s)
+;;
+(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
+*)
+let rational_to_real x =
+   let (n,d)=rational_to_fraction x in
+   mkApp (get coq_Rmult,
+     [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|])
+;;
+
+(* preuve que 0<n*1/d
+*)
+let tac_zero_inf_pos gl (n,d) =
+   let tacn=ref (apply (get coq_Rlt_zero_1)) in
+   let tacd=ref (apply (get coq_Rlt_zero_1)) in
+   for i=1 to n-1 do 
+       tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
+   for i=1 to d-1 do
+       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
+;;
+
+(* preuve que 0<=n*1/d
+*)
+let tac_zero_infeq_pos gl (n,d)=
+   let tacn=ref (if n=0 
+                 then (apply (get coq_Rle_zero_zero))
+                 else (apply (get coq_Rle_zero_1))) in
+   let tacd=ref (apply (get coq_Rlt_zero_1)) in
+   for i=1 to n-1 do 
+       tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
+   for i=1 to d-1 do
+       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
+;;
+  
+(* preuve que 0<(-n)*(1/d) => False 
+*)
+let tac_zero_inf_false gl (n,d) =
+    if n=0 then (apply (get coq_Rnot_lt0))
+    else
+     (tclTHEN (apply (get coq_Rle_not_lt))
+	      (tac_zero_infeq_pos gl (-n,d)))
+;;
+
+(* preuve que 0<=(-n)*(1/d) => False 
+*)
+let tac_zero_infeq_false gl (n,d) =
+     (tclTHEN (apply (get coq_Rlt_not_le))
+	      (tac_zero_inf_pos gl (-n,d)))
+;;
+
+let create_meta () = mkMeta(new_meta());;
+   
+let my_cut c gl=
+     let concl = pf_concl gl in
+       apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl
+;;
+
+let exact = exact_check;;
+
+let tac_use h = match h.htype with
+               "Rlt" -> exact h.hname
+              |"Rle" -> exact h.hname
+              |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt))
+                                (exact h.hname))
+              |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le))
+                                (exact h.hname))
+              |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le))
+                                (exact h.hname))
+              |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le))
+                                (exact h.hname))
+              |_->assert false
+;;
+
+(*
+let is_ineq (h,t) =
+    match (kind_of_term t) with
+	App (f,args) ->
+	  (match (string_of_R_constr f) with
+	       "Rlt" -> true
+	     | "Rgt" -> true
+	     | "Rle" -> true
+	     | "Rge" -> true
+(* Wrong:not in Rdefinitions: *) | "eqT" ->
+                (match (string_of_R_constr args.(0)) with
+			     "R" -> true
+			   | _ -> false)
+             | _ ->false)
+      |_->false
+;;
+*)
+
+let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+
+let mkAppL a =
+   let l = Array.to_list a in
+   mkApp(List.hd l, Array.of_list (List.tl l))
+;;
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec fourier gl=
+    Library.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,
+       et le but à prouver devient False *)
+    try (let tac =
+     match (kind_of_term goal) with
+      App (f,args) ->
+      (match (string_of_R_constr f) with
+	     "Rlt" -> 
+	       (tclTHEN
+	         (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
+			  (intro_using  fhyp))
+		 fourier)
+	    |"Rle" -> 
+	     (tclTHEN
+	      (tclTHEN (apply (get coq_Rfourier_not_gt_le))
+		       (intro_using  fhyp))
+			fourier)
+	    |"Rgt" -> 
+	     (tclTHEN
+	      (tclTHEN (apply (get coq_Rfourier_not_le_gt))
+		       (intro_using  fhyp))
+	      fourier)
+	    |"Rge" -> 
+	     (tclTHEN
+	      (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
+		       (intro_using  fhyp))
+	      fourier)
+	    |_->assert false)
+        |_->assert false
+      in tac gl)
+     with _ -> 
+    (* les hypothèses *)
+    let hyps = List.map (fun (h,t)-> (mkVar h,(body_of_type t)))
+                        (list_of_sign (pf_hyps gl)) in
+    let lineq =ref [] in
+    List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
+		        with _ -> ())
+              hyps;
+    (* lineq = les inéquations découlant des hypothèses *)
+    if !lineq=[] then Util.error "No inequalities";
+    let res=fourier_lineq (!lineq) in
+    let tac=ref tclIDTAC in
+    if res=[]
+    then (print_string "Tactic Fourier fails.\n";
+		       flush stdout)
+    (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
+    else (match res with
+        [(cres,sres,lc)]->
+    (* lc=coefficients multiplicateurs des inéquations
+       qui donnent 0<cres ou 0<=cres selon sres *)
+	(*print_string "Fourier's method can prove the goal...";flush stdout;*)
+          let lutil=ref [] in
+	  List.iter 
+            (fun (h,c) ->
+			  if c<>r0
+        		  then (lutil:=(h,c)::(!lutil)(*;
+				print_rational(c);print_string " "*)))
+                    (List.combine (!lineq) lc); 
+       (* on construit la combinaison linéaire des inéquation *)
+             (match (!lutil) with
+          (h1,c1)::lutil ->
+	  let s=ref (h1.hstrict) in
+	  let t1=ref (mkAppL [|get coq_Rmult;
+	                  rational_to_real c1;
+			  h1.hleft|]) in
+	  let t2=ref (mkAppL [|get coq_Rmult;
+	                  rational_to_real c1;
+			  h1.hright|]) in
+	  List.iter (fun (h,c) ->
+	       s:=(!s)||(h.hstrict);
+	       t1:=(mkAppL [|get coq_Rplus;
+	                     !t1;
+                             mkAppL [|get coq_Rmult;
+                                      rational_to_real c;
+			              h.hleft|] |]);
+	       t2:=(mkAppL [|get coq_Rplus;
+	                     !t2;
+                             mkAppL [|get coq_Rmult;
+                                      rational_to_real c;
+			              h.hright|] |]))
+               lutil;
+          let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle;
+			      !t1;
+			      !t2 |] in
+	   let tc=rational_to_real cres in
+       (* puis sa preuve *)
+           let tac1=ref (if h1.hstrict 
+                         then (tclTHENS (apply (get coq_Rfourier_lt))
+                                 [tac_use h1;
+                                  tac_zero_inf_pos  gl
+                                      (rational_to_fraction c1)])
+                         else (tclTHENS (apply (get coq_Rfourier_le))
+                                 [tac_use h1;
+				  tac_zero_inf_pos  gl
+                                      (rational_to_fraction c1)])) in
+           s:=h1.hstrict;
+           List.iter (fun (h,c)-> 
+             (if (!s)
+	      then (if h.hstrict
+	            then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
+			       [!tac1;tac_use h; 
+			        tac_zero_inf_pos  gl
+                                      (rational_to_fraction c)])
+	            else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
+			       [!tac1;tac_use h; 
+			        tac_zero_inf_pos  gl
+                                      (rational_to_fraction c)]))
+	      else (if h.hstrict
+	            then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
+			       [!tac1;tac_use h; 
+			        tac_zero_inf_pos  gl
+                                      (rational_to_fraction c)])
+	            else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
+			       [!tac1;tac_use h; 
+			        tac_zero_inf_pos  gl
+                                      (rational_to_fraction c)])));
+	     s:=(!s)||(h.hstrict))
+              lutil;
+           let tac2= if sres
+                      then tac_zero_inf_false gl (rational_to_fraction cres)
+                      else tac_zero_infeq_false gl (rational_to_fraction cres)
+           in
+           tac:=(tclTHENS (my_cut ineq) 
+                     [tclTHEN (change_in_concl None
+			       (mkAppL [| get coq_not; ineq|]
+				       ))
+		      (tclTHEN (apply (if sres then get coq_Rnot_lt_lt
+					       else get coq_Rnot_le_le))
+			    (tclTHENS (Equality.replace
+				       (mkAppL [|get coq_Rminus;!t2;!t1|]
+					       )
+				       tc)
+		 	       [tac2;
+                                (tclTHENS
+				  (Equality.replace
+				    (mkApp (get coq_Rinv, 
+				      [|get coq_R1|]))
+				    (get coq_R1))
+(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)	
+
+      			        [tclORELSE
+                                   (Ring.polynom [])
+                                   tclIDTAC;
+					  (tclTHEN (apply (get coq_sym_eqT))
+						(apply (get coq_Rinv_R1)))]
+                               
+					 )
+				]));
+                       !tac1]);
+	   tac:=(tclTHENS (cut (get coq_False))
+				  [tclTHEN intro (contradiction None);
+				   !tac])
+      |_-> assert false) |_-> assert false
+	  );
+(*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
+      (!tac gl) 
+(*      ((tclABSTRACT None !tac) gl) *)
+
+;;
+
+(*
+let fourier_tac x gl =
+     fourier gl
+;;
+
+let v_fourier = add_tactic "Fourier" fourier_tac
+*)
+
diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4
new file mode 100644
index 00000000..05c3adbd
--- /dev/null
+++ b/contrib/fourier/g_fourier.ml4
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: g_fourier.ml4,v 1.1.12.1 2004/07/16 19:30:11 herbelin Exp $ *)
+
+open FourierR
+
+TACTIC EXTEND Fourier
+  [ "FourierZ" (* constr_list(l) *) ] -> [ fourier (* l *) ]
+END
diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4
new file mode 100644
index 00000000..d2ae12d6
--- /dev/null
+++ b/contrib/funind/tacinv.ml4
@@ -0,0 +1,853 @@
+(*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}
+*)
+
+
+(*i*)
+open Termops
+open Equality
+open Names
+open Pp
+open Tacmach
+open Proof_type
+open Tacinterp
+open Tactics
+open Tacticals
+open Term
+open Util
+open Printer
+open Reductionops
+open Inductiveops
+open Coqlib
+open Refine
+open Typing
+open Declare
+open Decl_kinds
+open Safe_typing
+open Vernacinterp
+open Evd
+open Environ
+open Entries
+open Setoid_replace
+open Tacinvutils
+(*i*)
+
+module Smap = Map.Make(struct type t = constr let compare = compare end)
+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 mkthesort = mkProp (* would like to put Type here, but with which index? *)
+
+(*  this is the prefix used to name equality hypothesis generated by
+    case analysis*)
+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 *)
+let id_of_name = function
+    Anonymous -> id_of_string "H"
+  | Name id   -> id;;
+let string_of_name nme = string_of_id (id_of_name nme)
+ (*end debugging *)
+
+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 
+  (function (r,(typofg,g,d)) 
+      -> lift 1 r, (lift 1 typofg, lift 1 g , lift 1 d)) leq
+
+let lift1_relleqs leq= List.map (function (r,x) -> lift 1 r,x) leq
+
+(* WARNING: In the types, we don't lift the rels in the type. This is
+   intentional. Use with care. *)
+let lift1_lvars lvars= List.map 
+ (function x,(nme,c) -> lift 1 x, (nme, (*lift 1*) c)) lvars
+
+let pop1_levar levars = List.map (function ev,tev -> ev, popn 1 tev) levars
+
+
+let rec add_n_dummy_prod t n = 
+ if n<=0 then t
+ else add_n_dummy_prod (mkNamedProd (id_of_string "DUMMY") mkthesort t) (n-1)
+
+(* [add_lambdas t gl [csr1;csr2...]] returns [[x1:type of csr1]
+   [x2:type of csr2] t [csr <- x1 ...]], names of abstracted variables
+   are not specified *)
+let rec add_lambdas t gl lcsr =
+ match lcsr with
+  | [] -> t
+  | csr::lcsr' -> 
+     let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
+     lambda_id hyp_csr hyptyp (add_lambdas t gl lcsr')
+
+(* [add_pis t gl [csr1;csr2...]] returns ([x1] :type of [csr1]
+   [x2]:type of csr2) [t]*)
+let rec add_pis t gl lcsr =
+ match lcsr with
+  | [] -> t
+  | csr::lcsr' -> 
+     let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
+     prod_id hyp_csr hyptyp (add_pis t gl lcsr')
+
+let mkProdEg teq eql eqr concl =
+ mkProd (name_of_string "eg", mkEq teq eql eqr, lift 1 concl)
+
+let eqs_of_beqs x = 
+ List.map (function (_,(a,b,c)) -> (Anonymous, mkEq a b c)) x
+
+
+let rec eqs_of_beqs_named_aux s i l =
+ match l with 
+  | [] -> []
+  | (r,(a,b,c))::l' -> 
+     (Name(id_of_string (s^ string_of_int i)), mkEq a b c)
+     ::eqs_of_beqs_named_aux s (i-1) l'
+
+
+let eqs_of_beqs_named s l = eqs_of_beqs_named_aux s (List.length l) l
+
+let rec patternify ltypes c nme =
+ match ltypes with
+  | [] -> c
+  | (mv,t)::ltypes' -> 
+     let c'= substitterm 0 mv (mkRel 1) c in
+     let tlift = lift (List.length ltypes') t in
+     let res = 
+      patternify ltypes' (mkLambda (newname_append nme "rec", tlift, c')) nme in
+     res
+
+let rec npatternify ltypes c =
+ match ltypes with
+  | [] -> c
+  | (mv,nme,t)::ltypes' -> 
+     let c'= substitterm 0 mv (mkRel 1) c in
+(*      let _ = prconstr c' in *)
+     let tlift = lift (List.length ltypes') t in
+     let res = 
+      npatternify ltypes' (mkLambda (newname_append nme "", tlift, c')) in
+(*      let _ = prconstr res in *)
+     res
+
+let rec apply_levars c lmetav =
+ match lmetav with
+  | [] -> [],c
+  | (i,typ) :: lmetav' -> 
+     let levars,trm = apply_levars c lmetav' in
+     let exkey = mknewexist() in
+     ((exkey,typ)::levars),  applistc trm [mkEvar exkey]
+      (* EXPERIMENT le refine est plus long si on met un cast:
+         ((exkey,typ)::levars), mkCast ((applistc trm [mkEvar exkey]),typ) *)
+
+
+let prod_change_concl c newconcl = 
+ let lv,_ = decompose_prod c in prod_it  newconcl lv
+
+let lam_change_concl c newconcl = 
+ let lv,_ = decompose_prod c in lam_it newconcl lv
+
+
+let rec mkAppRel c largs n =
+ match largs with
+  | [] -> c
+  | arg::largs' -> 
+     let newc = mkApp (c,[|(mkRel n)|]) in mkAppRel newc largs' (n-1)
+
+let applFull c typofc =
+ let lv,t = decompose_prod typofc in 
+ let ltyp = List.map fst lv in 
+ let res = mkAppRel c ltyp (List.length ltyp) in
+ res
+
+
+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
+  | 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.")
+  | _,_ -> 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
+
+
+(*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}
+*)
+
+type mimickinfo =
+    {
+     concl: constr;
+     absconcl: constr array;
+     mimick: constr;
+     env: env;
+     sigma: Evd.evar_map;
+     nmefonc: constr array;
+     fonc: int * int;
+     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
+                  found before a case or a fix are treated as parameters of
+                  the induction principle *)
+    }
+
+(*
+  \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 =
+    {
+     princ:constr;
+     evarlist: (constr*Term.types) list;
+     hypnum: (int*int*int) list;
+     mutfixmetas: constr array ;
+     conclarray: types array;
+     params:(constr*name*constr) list
+    }
+
+(* 
+  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.
+
+  \item[[(ev1,tev1);(ev2,tev2)...]] est l'ensemble des méta variables
+  correspondant à des trous. [evi] est la meta variable, [tevi] est son type.
+
+  \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.
+
+  \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.
+
+  \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 =
+ 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
+     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,[]
+
+  (* <pcase> Cases b of arrPt end.*)
+  | 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 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)*)
+      
+  | 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
+     (* 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,[]
+     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)
+
+  | 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 nb_vars = (List.length varnames) in
+     let nb_eqs = (List.length lst_eqs) in
+     let eqrels = List.map fst lst_eqs in
+     (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs
+        trouvés dans les let in et les Cases. *)
+     (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *)
+     let terms_recs = 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. *)
+     (* d'abord, on fabrique les types des appels recursifs en replacant le nom
+        de des fonctions par les predicats dans [terms_recs]: [(f_i t u v)]
+        devient [(P_i t u v)] *)
+     (* TODO optimiser ici: *)
+     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,[]
+
+
+
+let mkevarmap_aux ex = let x,y = ex in	(mkevarmap_from_listex x),y
+
+(* Interpretation of constr's *)
+let constr_of_Constr c = Constrintern.interp_constr Evd.empty (Global.env()) c
+
+
+(* TODO: deal with any term, not only a constant. *)
+let interp_fonc_tacarg fonctac gl =
+ (* [fonc] is the constr corresponding to fontact not unfolded,
+    if [fonctac] is a (qualified) name then this is a [const] ?. *)
+(*  let fonc = constr_of_Constr fonctac in *)
+ (* TODO: replace the [with _ -> ] by something more precise in
+    the following. *)
+ (* [def_fonc] is the definition of fonc. TODO: We should do this only
+    if [fonc] is a const, and take [fonc] otherwise.*)
+ try fonctac, pf_const_value gl (destConst fonctac)
+ with _ -> failwith ("don't know how to deal with this function "
+ ^"(DEBUG:is it a constante?)")
+
+
+
+
+(* [invfun_proof fonc  def_fonc  gl_abstr pis]  builds  the principle,
+   following  the shape  of   [def_fonc],    [fonc]  is the      constant
+   corresponding to [def_func] (or a reduced form of  it ?), gl_abstr and
+   pis are the goal to be proved, of the form [x,y...]g and (x.y...)g.
+
+   This function calls the big function proofPrinc. *)
+
+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
+
+(* 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 = 
+ if i<=0 then tclIDTAC else 
+   tclTHEN
+    (tclTHEN 
+     intro
+     (iterintro (i-1)))
+    (fun gl -> 
+     (tclREPEAT 
+      (tclNTH_HYP i
+       (fun hyp -> 
+        let hypname = (string_of_id (destVar hyp)) in
+        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")
+      )) gl)
+
+
+(* 
+       (fun hyp gl -> 
+        let _ = print_string ("nthhyp= "^ string_of_int i) in
+        if isConst hyp && ((name_of_const hyp)==heq_prefix) then
+          let _ = print_string "YES\n" in
+          rewriteLR hyp gl 
+        else 
+          let _ = print_string "NO\n" in
+          tclIDTAC gl)
+ *)
+    
+(* [invfun_basic C listargs_ids gl dorew lposeq] builds the tactic
+   which:
+   \begin{itemize}
+   \item Do refine on C (the induction principle),
+   \item try to Clear listargs_ids
+   \item if boolean dorew is true, then intro all new hypothesis, and
+   try rewrite on those hypothesis that are equalities.
+   \end{itemize}
+*)
+
+let invfun_basic open_princ_proof_applied listargs_ids gl dorew lposeq =
+ (tclTHEN_i
+  (tclTHEN
+   (tclTHEN
+    (* Refine on the right term (following the sheme of the
+       given function) *)
+    (fun gl -> refine open_princ_proof_applied  gl)
+    (* Clear the hypothesis given as arguments of the tactic
+       (because they are generalized) *)
+    (tclTHEN simpl_in_concl (tclTRY (clear listargs_ids))))
+   (* Now we introduce the created hypothesis, and try rewrite on
+      equalities due to case analysis *)
+   (fun gl ->  (tclIDTAC gl)))
+		(fun i gl -> 
+   if not dorew then tclIDTAC gl
+   else
+     (* d,m,f correspond respectively to vars, induction hyps and
+        equalities*)
+     let d,m,f = List.nth lposeq (i-1) in
+     tclTHEN (iterintro (d)) (tclDO m (tclTRY intro)) gl)
+ )
+ gl
+
+
+
+
+(* This function trys to reduce instanciated arguments, provided they
+   are of the form [(C t u v...)] where [C] is a constructor, and
+   provided that the argument is not the argument of a fixpoint (i.e. the
+   argument corresponds to a simple lambda) . *)
+let rec applistc_iota cstr lcstr env sigma = 
+ match lcstr with
+  | [] -> cstr,[]
+  | arg::lcstr' -> 
+     let arghd = 
+      if isApp arg then let x,_ = destApplication 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])))
+         lcstr' env sigma
+     else 
+       try 
+        let nme,typ,suite = destLambda cstr in
+        let c, l = applistc_iota suite lcstr' env sigma in
+        mkLambda (nme,typ,c), arg::l
+       with _ -> cstr,arg::lcstr' (* the arg does not correspond to a lambda*)
+
+
+
+(* TODO: ne plus mettre les sous-but à l'exterieur, mais à l'intérieur (le bug
+   de refine est normalement resolu). Ca permettra 2 choses: d'une part que
+   les preuves soient plus simple, et d'autre part de fabriquer un terme de
+   refine qui pourra s'aapliquer SANS FAIRE LES INTROS AVANT, ce qui est bcp
+   mieux car fonctionne comme induction et plus comme inversion (pas de perte
+   de connexion entre les hypothèse et les variables). *)
+
+(*s Tactic that makes induction and case analysis following the shape
+  of a function (idf) given with arguments (listargs) *)
+let invfun c l dorew gl = 
+(* \begin{itemize}
+    \item [fonc] = the constant corresponding to the function
+    (necessary for equalities of the form [(f x1 x2 ...)=...] where
+    [f] is the recursive function).
+    \item [def_fonc] = body of the function, where let ins have
+    been expanded. *)
+ let fonc, def_fonc' = interp_fonc_tacarg c gl in
+ let def_fonc'',listargs' = 
+  applistc_iota def_fonc' l (pf_env gl) (project gl)  in
+ let def_fonc = expand_letins def_fonc'' in
+ (* quantifies on previously generalized arguments. 
+    [(x1:T1)...g[arg1 <- x1 ...]] *)
+ 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
+
+ (* 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
+
+ (* 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
+
+ (* 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)
+  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''
+  else princ_applied_hyps'' in
+ 
+ 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')
+  else princ_applied_hyps' (* No Fixpoint *) in
+ let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in
+
+ (* replace params metavar by real args *)
+ let rec replace_parms lparms largs t = 
+  match lparms, largs with
+     [], _ -> 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
+
+
+(*
+ (* replace params metavar by abstracted variables *)
+  let princ_proof_params = npatternify (List.rev parms) princ_applied_hyps in
+ (* we apply now the real parameters *)
+ let princ_proof_applied = 
+  applistc princ_proof_params (listpref (List.length parms) listargs') in
+*)
+
+
+
+ let princ_applied_evars = apply_levars princ_proof_applied levar in
+ let open_princ_proof_applied = princ_applied_evars in
+ let listargs_ids = List.map destVar (List.filter isVar listargs') in
+ invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids 
+  gl dorew lposeq
+
+(* function must be a constant, all arguments must be given. *)
+let invfun_verif c l dorew gl =
+ if not (isConst c) then error "given function is not a constant"
+ else 
+   let x,_ = decompose_prod (pf_type_of gl c) in
+   if List.length x = List.length l then 
+     try invfun c l dorew gl
+     with 
+        UserError (x,y) -> raise (UserError (x,y))
+   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. *)
+let buildFunscheme fonc mutflist =
+ let def_fonc = expand_letins (def_of_const fonc) in
+ let ftyp = type_of (Global.env ()) Evd.empty fonc in
+ let _ = resetmeta() in
+ let gl = mknewmeta() in
+ let gl_app = applFull gl ftyp in
+ 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
+ (* 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_hyps = 
+  patternify (List.rev levar) 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? *)
+    princ_replace_metas ev abs (i+1)
+     (mkLambda (
+      (Name (id_of_string ("Q"^(string_of_int i)))),
+      prod_change_concl (lift 0 abs.(i)) mkthesort,
+      (substitterm 0 ev.(i) (mkRel 1) (lift 0 t))))
+ in
+ let rec princ_replace_params params t = 
+  List.fold_left (
+   fun acc ev,nam,typ -> 
+    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? *)
+	then (* No Fixpoint *)
+   princ_replace_params parms (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
+
+
+    
+(* Declaration of the functional scheme. *)
+let declareFunScheme f fname mutflist =
+ let scheme = 
+   buildFunscheme (constr_of f) 
+    (Array.of_list (List.map constr_of (f::mutflist))) 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
+ ()
+
+
+
+VERNAC COMMAND EXTEND FunctionalScheme
+ [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" 
+    constr(c) "with" ne_constr_list(l) ]
+  -> [ declareFunScheme c na l ]
+| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" constr(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 ***
+*** tuareg-match-indent:-1 ***
+*** tuareg-try-indent:1 ***
+*** tuareg-with-indent:1 ***
+*** tuareg-if-then-else-inden:1 ***
+*** fill-column: 78 ***
+*** indent-tabs-mode: nil ***
+***  test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" ***
+*** End: ***
+*)
+          
+
diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml
new file mode 100644
index 00000000..758071ba
--- /dev/null
+++ b/contrib/funind/tacinvutils.ml
@@ -0,0 +1,277 @@
+(* tacinvutils.ml *)
+(*s utilities *)
+
+(*i*)
+open Names
+open Util
+open Term
+open Termops
+open Coqlib
+open Pp
+open Printer
+open Inductiveops
+open Environ
+open Declarations
+open Nameops
+open Evd
+open Sign
+open Reductionops
+(*i*)
+
+(*s printing of constr -- debugging *)
+
+let msg x = () ;; let prterm c = str "" (* comment this to see debug msgs *)
+  (* uncomment this to see debugging *)
+let prconstr c =  msg (str"  " ++ prterm c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+
+let prchr () = msg (str" (ret) \n")
+let prNamedConstr s c = 
+  begin
+    msg(str "");
+    msg(str(s^"==>\n ") ++ prterm c ++ str "\n<==\n");
+    msg(str "");
+  end
+
+let prNamedLConstr_aux lc = 
+  List.iter (prNamedConstr "#>") lc
+
+let prNamedLConstr s lc = 
+  begin
+    prstr s;
+    prNamedLConstr_aux lc
+  end
+
+
+(* FIXME: ref 1, pas bon, si? *)
+let evarcpt = ref 0
+let metacpt = ref 0
+let mknewexist ()= 
+  begin
+    evarcpt := !evarcpt+1;
+    !evarcpt,[||]
+  end
+
+let resetexist ()= evarcpt := 0
+
+let mknewmeta ()= 
+  begin
+    metacpt := !metacpt+1;
+    mkMeta (!metacpt)
+  end
+
+let resetmeta () = metacpt := 0
+
+let  rec mkevarmap_from_listex lex =
+  match lex with
+	 | [] -> Evd.empty
+	 | ((ex,_),typ)::lex' -> 
+		  let info ={
+			 evar_concl = typ;
+			 evar_hyps = empty_named_context;
+			 evar_body = Evar_empty} in
+		  Evd.add (mkevarmap_from_listex lex') ex info
+
+let mkEq typ c1 c2 = 
+  mkApp (build_coq_eq(),[| typ; c1; c2|])
+
+let mkRefl typ c1 = 
+  mkApp ((build_coq_eq_data()).refl, [| typ; c1|])
+
+let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
+
+
+(* Operations on names *)
+let id_of_name = function
+    Anonymous -> id_of_string "H"
+  | Name id   -> id;;
+let string_of_name nme = string_of_id (id_of_name nme)
+let name_of_string str = Name (id_of_string str)
+let newname_append nme str = 
+  Name(id_of_string ((string_of_id (id_of_name nme))^str))
+
+(* 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 apply_eqtrpl eq t =
+  let r,(tb,b,by_t) = eq in
+  substitterm 0 b by_t t
+
+let apply_eqtrpl_lt lt eq =  List.map (apply_eqtrpl eq) lt
+
+let apply_leqtrpl_t t leq =
+  List.fold_left (fun x y -> apply_eqtrpl y x) t leq
+
+
+let apply_refl_term eq t =
+  let _,arr = destApplication eq in
+  let reli= (Array.get arr 1) in
+  let by_t= (Array.get arr 2) in
+  substitterm 0 reli by_t t
+
+let apply_eq_leqtrpl leq eq =
+  List.map 
+    (function (r,(tb,b,t)) ->
+		r,(tb, 
+		(if isRel b then b else (apply_refl_term eq b)), apply_refl_term eq t))
+	 leq
+
+
+
+(* [(a b c) a] -> true *)
+let constr_head_match u t=
+  if isApp u 
+  then 
+	 let uhd,args= destApplication u in
+    uhd=t
+  else false
+
+(* My operations on constr *)
+let lift1L l = (List.map (lift 1) l)
+let mkArrow_lift t1 t2 = mkArrow t1 (lift 1 t2)
+let mkProd_liftc nme c1 c2 = mkProd (nme,c1,(lift 1 c2))
+(* prod_it_lift x [a1 a2 ...] *)
+let prod_it_lift ini lcpl =
+  List.fold_right (function a,b -> (fun c -> mkProd_liftc a b c)) ini lcpl;;
+
+let prod_it_anonym_lift trm lst = List.fold_right mkArrow_lift lst trm
+
+let lam_it_anonymous trm lst =
+  List.fold_right 
+	 (fun elt res -> mkLambda(Name(id_of_string "Hrec"),elt,res)) lst trm
+
+let lambda_id id typeofid cstr =
+  let cstr' = mkNamedLambda (id_of_string "FUNX") typeofid cstr in
+  substitterm 0 id (mkRel 0) cstr'
+
+let prod_id id typeofid cstr =
+  let cstr' = mkNamedProd (id_of_string "FUNX") typeofid cstr in
+  substitterm 0 id (mkRel 0) cstr'
+
+
+
+
+
+let nth_dep_constructor indtype n =
+  let sigma = Evd.empty and env = Global.env() in
+  let indtypedef = find_rectype env sigma indtype in
+  let indfam,_ = dest_ind_type indtypedef in
+  let arr_cstr_summary = get_constructors env indfam in
+  let cstr_sum = Array.get arr_cstr_summary n in
+  build_dependent_constructor cstr_sum,  cstr_sum.cs_nargs
+
+
+let rec buildrefl_from_eqs eqs = 
+  match eqs with 
+    | []  ->  []
+    | cstr::eqs' -> 
+        let eq,args = destApplication cstr in
+        (mkRefl (Array.get args 0) (Array.get args 2))
+	:: (buildrefl_from_eqs eqs')
+
+
+
+
+(* list of occurrences of a term inside another, no imbricated
+   occurrence are considered (ie we stop looking inside a termthat is
+   an occurrence). *)
+let rec hdMatchSub u t=
+  if constr_head_match u t then 
+	 u::(fold_constr (fun l cstr -> l@(hdMatchSub cstr t))
+      [] 
+      u)
+  else
+    fold_constr (fun l cstr -> l@(hdMatchSub cstr t))
+      [] 
+      u
+
+(* let hdMatchSub_list u lt = List.flatten (List.map (hdMatchSub u) lt) *)
+let hdMatchSub_cpl u (d,f) = 
+	 let res = ref [] in
+	 begin
+	 	for i = d to f do res := (hdMatchSub u (mkRel i)) @ !res done;
+		  !res
+	 end
+
+
+(* destApplication raises an exception if [t] is not an application *)      
+let exchange_hd_prod subst_hd t =
+    let (hd,args)= destApplication t in mkApp (subst_hd,args)
+
+(* substitute t by by_t in head of products inside in_u, reduces each
+	product found  *)
+let rec substit_red prof t by_t in_u =
+  if constr_head_match in_u (lift prof t) 
+  then
+	 let _ = prNamedConstr "in_u" in_u in
+	 let x = whd_beta (exchange_hd_prod (lift prof by_t) in_u) in
+	 let _ = prNamedConstr "xx " x in
+	 let _ = prstr "\n\n" in
+	 x
+  else
+    map_constr_with_binders succ (fun i u -> substit_red i t by_t u)
+    	prof 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 i = destRel hd in
+  whd_beta (mkApp (tarr.(f-i) ,args))
+
+let exchange_reli_arrayi_L tarr (d,f) = 
+  List.map (exchange_reli_arrayi tarr (d,f))
+
+
+(* expand all letins in a term, before building the principle. *)
+let rec expand_letins mimick =
+  match kind_of_term mimick with
+    | LetIn(nme,cstr1, typ, cstr) ->
+        let cstr' = substitterm 0 (mkRel 1) (lift 1 cstr1) cstr in
+        expand_letins (pop cstr')
+    | x -> map_constr expand_letins mimick
+	  
+
+(* Valeur d'une constante, or identity *)
+let def_of_const t =
+  match kind_of_term t with
+    | Const sp -> 
+		  (try 
+			 match Global.lookup_constant sp with
+              {const_body=Some c} -> force c
+ 				|_ -> assert false
+			 with _ -> assert false)
+    | _ -> 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)
+		|_ -> assert false
+ ;;
+
+
+(*i
+***  Local Variables:
+***  compile-command: "make -k tacinvutils.cmo"
+***  test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v"
+***  End:
+i*)
+
diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli
new file mode 100644
index 00000000..2fc37b2c
--- /dev/null
+++ b/contrib/funind/tacinvutils.mli
@@ -0,0 +1,79 @@
+(* tacinvutils.ml *)
+(*s utilities *)
+
+(*i*)
+open Termops
+open Equality
+open Names
+open Pp
+open Tacmach
+open Proof_type
+open Tacinterp
+open Tactics
+open Tacticals
+open Term
+open Util
+open Printer
+open Reductionops
+open Inductiveops
+open Coqlib
+open Refine
+open Evd
+(*i*)
+
+(* printing debugging *)
+val prconstr: constr -> unit
+val prlistconstr: constr list  -> unit
+val prNamedConstr:string -> constr -> unit
+val prNamedLConstr:string -> constr list -> unit
+val prstr: string -> unit 
+
+
+val mknewmeta: unit -> constr
+val mknewexist: unit -> existential
+val resetmeta: unit -> unit (* safe *)
+val resetexist: unit -> unit (* be careful with this one *)
+val mkevarmap_from_listex: (Term.existential * Term.types) list -> evar_map
+val mkEq: types -> constr -> constr -> constr
+(* let mkEq typ c1 c2 =   mkApp (build_coq_eq_data.eq(),[| typ; c1; c2|]) *)
+val mkRefl: types -> constr -> constr
+val buildrefl_from_eqs: constr list -> constr list
+(* typ c1 =  mkApp ((constant ["Coq"; "Init"; "Logic"] "refl_equal"), [| typ; c1|]) *)
+
+val nth_dep_constructor: constr -> int -> (constr*int)
+
+val prod_it_lift:  (name*constr) list -> constr -> constr
+val prod_it_anonym_lift: constr -> constr list -> constr
+val lam_it_anonymous: constr -> constr list -> constr
+val lift1L: (constr list) -> constr list
+val popn: int -> constr -> constr
+val lambda_id: constr -> constr -> constr -> constr
+val prod_id: constr -> constr -> constr -> constr
+
+
+val name_of_string : string -> name
+val newname_append: name -> string -> name
+
+val apply_eqtrpl: constr*(constr*constr*constr) -> constr -> constr
+val substitterm: int -> constr -> constr -> constr -> constr
+val apply_leqtrpl_t: 
+  constr -> (constr*(constr*constr*constr)) list -> constr
+val apply_eq_leqtrpl: 
+  (constr*(constr*constr*constr)) list -> constr -> (constr*(constr*constr*constr)) list
+(* val apply_leq_lt: constr list -> constr list -> constr list *)
+
+val hdMatchSub: constr -> constr -> constr list
+val hdMatchSub_cpl: constr -> int*int -> constr list
+val exchange_hd_prod: constr -> constr -> constr
+val exchange_reli_arrayi_L: constr array  -> int*int -> constr list -> constr list
+val substit_red: int -> constr -> constr -> constr -> constr
+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:
+i*)
+
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT
new file mode 100644
index 00000000..2fb11c6b
--- /dev/null
+++ b/contrib/interface/COPYRIGHT
@@ -0,0 +1,19 @@
+(*****************************************************************************)
+(*                                                                           *)
+(*            Coq support for the Pcoq Graphical Interface of Coq            *)
+(*                                                                           *)
+(*        Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team)        *)
+(*                                                                           *)
+(*****************************************************************************)
+
+The current directory contrib/interface implements Coq support for the
+Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot
+with contributions from Loïc Pottier and Laurence Rideau.
+
+The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq)
+is developed by the Lemme team at INRIA Sophia-Antipolis (see
+http://www-sop.inria.fr/lemme)
+
+The files of the current directory are distributed under the terms of
+the GNU Lesser General Public License Version 2.1.
+
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
new file mode 100644
index 00000000..61d0d5a3
--- /dev/null
+++ b/contrib/interface/ascent.mli
@@ -0,0 +1,784 @@
+type ct_AST =
+    CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT
+  | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING
+  | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE
+  | CT_astnode of ct_ID * ct_AST_LIST
+  | CT_astpath of ct_ID_LIST
+  | CT_astslam of ct_ID_OPT * ct_AST
+and ct_AST_LIST =
+    CT_ast_list of ct_AST list
+and ct_BINARY =
+    CT_binary of int
+and ct_BINDER =
+    CT_coerce_DEF_to_BINDER of ct_DEF
+  | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA
+  | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA
+and ct_BINDER_LIST =
+    CT_binder_list of ct_BINDER list
+and ct_BINDER_NE_LIST =
+    CT_binder_ne_list of ct_BINDER * ct_BINDER list
+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 =
+    CT_false
+  | CT_true
+and ct_CASE =
+    CT_case of string
+and ct_CLAUSE =
+    CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT
+and ct_COERCION_OPT =
+    CT_coerce_NONE_to_COERCION_OPT of ct_NONE
+  | CT_coercion_atm
+and ct_COFIXTAC =
+    CT_cofixtac of ct_ID * ct_FORMULA
+and ct_COFIX_REC =
+    CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA
+and ct_COFIX_REC_LIST =
+    CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list
+and ct_COFIX_TAC_LIST =
+    CT_cofix_tac_list of ct_COFIXTAC list
+and ct_COMMAND =
+    CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST
+  | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD
+  | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN
+  | 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_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
+  | CT_bind_scope of ct_ID * ct_ID_NE_LIST
+  | CT_cd of ct_STRING_OPT
+  | CT_check of ct_FORMULA
+  | CT_class of ct_ID
+  | CT_close_scope of ct_ID
+  | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID
+  | CT_cofix_decl of ct_COFIX_REC_LIST
+  | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT
+  | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
+  | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
+  | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT
+  | CT_delim_scope of ct_ID * ct_ID
+  | CT_delpath of ct_STRING
+  | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
+  | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID
+  | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE
+  | CT_explain_proof of ct_INT_LIST
+  | CT_explain_prooftree of ct_INT_LIST
+  | CT_export_id of ct_ID_NE_LIST
+  | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST
+  | CT_extraction of ct_ID_OPT
+  | CT_fix_decl of ct_FIX_REC_LIST
+  | CT_focus of ct_INT_OPT
+  | CT_go of ct_INT_OR_LOCN
+  | CT_guarded
+  | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
+  | CT_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
+  | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM
+  | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
+  | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
+  | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
+  | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
+  | CT_implicits of ct_ID * ct_ID_LIST_OPT
+  | CT_import_id of ct_ID_NE_LIST
+  | CT_ind_scheme of ct_SCHEME_SPEC_LIST
+  | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
+  | CT_inline of ct_ID_NE_LIST
+  | CT_inspect of ct_INT
+  | CT_kill_node of ct_INT
+  | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING
+  | CT_local_close_scope of ct_ID
+  | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT
+  | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
+  | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST
+  | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST
+  | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST
+  | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST
+  | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT
+  | CT_local_open_scope of ct_ID
+  | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST
+  | CT_locate of ct_ID
+  | CT_locate_file of ct_STRING
+  | CT_locate_lib of ct_ID
+  | CT_locate_notation of ct_STRING
+  | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST
+  | CT_ml_add_path of ct_STRING
+  | CT_ml_declare_modules of ct_STRING_NE_LIST
+  | CT_ml_print_modules
+  | CT_ml_print_path
+  | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR
+  | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT
+  | CT_no_inline of ct_ID_NE_LIST
+  | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE
+  | CT_opaque of ct_ID_NE_LIST
+  | CT_open_scope of ct_ID
+  | CT_print
+  | CT_print_about of ct_ID
+  | CT_print_all
+  | CT_print_classes
+  | 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_id of ct_ID
+  | CT_print_implicit of ct_ID
+  | CT_print_loadpath
+  | CT_print_module of ct_ID
+  | CT_print_module_type of ct_ID
+  | CT_print_modules
+  | CT_print_natural of ct_ID
+  | CT_print_natural_feature of ct_NATURAL_FEATURE
+  | CT_print_opaqueid of ct_ID
+  | CT_print_path of ct_ID * ct_ID
+  | CT_print_proof of ct_ID
+  | CT_print_scope of ct_ID
+  | CT_print_scopes
+  | CT_print_section of ct_ID
+  | CT_print_states
+  | CT_print_tables
+  | CT_print_universes of ct_STRING_OPT
+  | CT_print_visibility of ct_ID_OPT
+  | CT_proof of ct_FORMULA
+  | CT_proof_no_op
+  | CT_proof_with of ct_TACTIC_COM
+  | CT_pwd
+  | CT_quit
+  | CT_read_module of ct_ID
+  | CT_rec_ml_add_path of ct_STRING
+  | CT_recaddpath of ct_STRING * ct_ID_OPT
+  | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST
+  | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID
+  | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING
+  | CT_reserve of ct_ID_NE_LIST * ct_FORMULA
+  | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST
+  | CT_reset of ct_ID
+  | CT_reset_section of ct_ID
+  | CT_restart
+  | CT_restore_state of ct_ID
+  | CT_resume of ct_ID_OPT
+  | CT_save of ct_THM_OPT * ct_ID_OPT
+  | CT_scomments of ct_SCOMMENT_CONTENT_LIST
+  | CT_search of ct_ID * ct_IN_OR_OUT_MODULES
+  | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES
+  | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES
+  | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES
+  | CT_section_end of ct_ID
+  | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND
+  | CT_set_natural of ct_ID
+  | CT_set_natural_default
+  | CT_set_option of ct_TABLE
+  | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE
+  | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST
+  | CT_sethyp of ct_INT
+  | CT_setundo of ct_INT
+  | CT_show_existentials
+  | CT_show_goal of ct_INT_OPT
+  | CT_show_implicit of ct_INT
+  | CT_show_intro
+  | CT_show_intros
+  | CT_show_node
+  | CT_show_proof
+  | CT_show_proofs
+  | CT_show_script
+  | CT_show_tree
+  | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT
+  | CT_suspend
+  | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT
+  | CT_tactic_definition of ct_TAC_DEF_NE_LIST
+  | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID
+  | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT
+  | CT_time of ct_COMMAND
+  | CT_transparent of ct_ID_NE_LIST
+  | CT_undo of ct_INT_OPT
+  | CT_unfocus
+  | CT_unset_option of ct_TABLE
+  | CT_unsethyp
+  | CT_unsetundo
+  | CT_user_vernac of ct_ID * ct_VARG_LIST
+  | CT_variable of ct_VAR * ct_BINDER_NE_LIST
+  | CT_write_module of ct_ID * ct_STRING_OPT
+and ct_COMMAND_LIST =
+    CT_command_list of ct_COMMAND * ct_COMMAND list
+and ct_COMMENT =
+    CT_comment of string
+and ct_COMMENT_S =
+    CT_comment_s of ct_COMMENT list
+and ct_CONSTR =
+    CT_constr of ct_ID * ct_FORMULA
+  | CT_constr_coercion of ct_ID * ct_FORMULA
+and ct_CONSTR_LIST =
+    CT_constr_list of ct_CONSTR list
+and ct_CONTEXT_HYP_LIST =
+    CT_context_hyp_list of ct_PREMISE_PATTERN list
+and ct_CONTEXT_PATTERN =
+    CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA
+  | CT_context of ct_ID_OPT * ct_FORMULA
+and ct_CONTEXT_RULE =
+    CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM
+  | CT_def_context_rule of ct_TACTIC_COM
+and ct_CONVERSION_FLAG =
+    CT_beta
+  | CT_delta
+  | CT_evar
+  | CT_iota
+  | CT_zeta
+and ct_CONVERSION_FLAG_LIST =
+    CT_conversion_flag_list of ct_CONVERSION_FLAG list
+and ct_CONV_SET =
+    CT_unf of ct_ID list
+  | CT_unfbut of ct_ID list
+and ct_CO_IND =
+    CT_co_ind of string
+and ct_DECL_NOTATION_OPT =
+    CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE
+  | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT
+and ct_DEF =
+    CT_def of ct_ID_OPT * ct_FORMULA
+and ct_DEFN =
+    CT_defn of string
+and ct_DEFN_OR_THM =
+    CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN
+  | CT_coerce_THM_to_DEFN_OR_THM of ct_THM
+and ct_DEF_BODY =
+    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN
+  | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD
+  | CT_type_of of ct_FORMULA
+and ct_DEF_BODY_OPT =
+    CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY
+  | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT
+and ct_DEP =
+    CT_dep of string
+and ct_DESTRUCTING =
+    CT_coerce_NONE_to_DESTRUCTING of ct_NONE
+  | CT_destructing
+and ct_DESTRUCT_LOCATION =
+    CT_conclusion_location
+  | CT_discardable_hypothesis
+  | CT_hypothesis_location
+and ct_DOTDOT_OPT =
+    CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE
+  | CT_dotdot
+and ct_EQN =
+    CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA
+and ct_EQN_LIST =
+    CT_eqn_list of ct_EQN list
+and ct_EVAL_CMD =
+    CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA
+and ct_FIXTAC =
+    CT_fixtac of ct_ID * ct_INT * ct_FORMULA
+and ct_FIX_BINDER =
+    CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC
+  | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA
+and ct_FIX_BINDER_LIST =
+    CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list
+and ct_FIX_REC =
+    CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT *
+      ct_FORMULA * ct_FORMULA
+and ct_FIX_REC_LIST =
+    CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list
+and ct_FIX_TAC_LIST =
+    CT_fix_tac_list of ct_FIXTAC list
+and ct_FORMULA =
+    CT_coerce_BINARY_to_FORMULA of ct_BINARY
+  | CT_coerce_ID_to_FORMULA of ct_ID
+  | CT_coerce_NUM_to_FORMULA of ct_NUM
+  | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE
+  | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA
+  | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST
+  | CT_arrowc of ct_FORMULA * ct_FORMULA
+  | CT_bang of ct_FORMULA
+  | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST
+  | CT_cofixc of ct_ID * ct_COFIX_REC_LIST
+  | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST
+  | CT_existvarc
+  | CT_fixc of ct_ID * ct_FIX_BINDER_LIST
+  | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
+  | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA
+  | CT_labelled_arg of ct_ID * ct_FORMULA
+  | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA
+  | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA
+  | CT_letin of ct_DEF * ct_FORMULA
+  | CT_notation of ct_STRING * ct_FORMULA_LIST
+  | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA
+  | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA
+  | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST
+and ct_FORMULA_LIST =
+    CT_formula_list of ct_FORMULA list
+and ct_FORMULA_NE_LIST =
+    CT_formula_ne_list of ct_FORMULA * ct_FORMULA list
+and ct_FORMULA_OPT =
+    CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA
+  | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT
+and ct_FORMULA_OR_INT =
+    CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA
+  | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT
+and ct_GRAMMAR =
+    CT_grammar_none
+and ct_HYP_LOCATION =
+    CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD
+  | CT_intype of ct_ID * ct_INT_LIST
+  | CT_invalue of ct_ID * ct_INT_LIST
+and ct_HYP_LOCATION_LIST_OR_STAR =
+    CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR
+  | CT_hyp_location_list of ct_HYP_LOCATION list
+and ct_ID =
+    CT_ident of string
+  | CT_metac of ct_INT
+  | CT_metaid of string
+and ct_IDENTITY_OPT =
+    CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE
+  | CT_identity
+and ct_ID_LIST =
+    CT_id_list of ct_ID list
+and ct_ID_LIST_LIST =
+    CT_id_list_list of ct_ID_LIST list
+and ct_ID_LIST_OPT =
+    CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST
+  | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE
+and ct_ID_NE_LIST =
+    CT_id_ne_list of ct_ID * ct_ID list
+and ct_ID_NE_LIST_OR_STAR =
+    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST
+  | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR
+and ct_ID_NE_LIST_OR_STRING =
+    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST
+  | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING
+and ct_ID_OPT =
+    CT_coerce_ID_to_ID_OPT of ct_ID
+  | CT_coerce_NONE_to_ID_OPT of ct_NONE
+and ct_ID_OPT_LIST =
+    CT_id_opt_list of ct_ID_OPT list
+and ct_ID_OPT_NE_LIST =
+    CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list
+and ct_ID_OPT_OR_ALL =
+    CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT
+  | CT_all
+and ct_ID_OR_INT =
+    CT_coerce_ID_to_ID_OR_INT of ct_ID
+  | CT_coerce_INT_to_ID_OR_INT of ct_INT
+and ct_ID_OR_INT_OPT =
+    CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT
+  | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT
+  | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT
+and ct_ID_OR_STAR =
+    CT_coerce_ID_to_ID_OR_STAR of ct_ID
+  | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR
+and ct_ID_OR_STRING =
+    CT_coerce_ID_to_ID_OR_STRING of ct_ID
+  | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING
+and ct_ID_OR_STRING_NE_LIST =
+    CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list
+and ct_IMPEXP =
+    CT_coerce_NONE_to_IMPEXP of ct_NONE
+  | CT_export
+  | CT_import
+and ct_IND_SPEC =
+    CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT
+and ct_IND_SPEC_LIST =
+    CT_ind_spec_list of ct_IND_SPEC list
+and ct_INT =
+    CT_int of int
+and ct_INTRO_PATT =
+    CT_coerce_ID_to_INTRO_PATT of ct_ID
+  | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list
+and ct_INTRO_PATT_LIST =
+    CT_intro_patt_list of ct_INTRO_PATT list
+and ct_INTRO_PATT_OPT =
+    CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT
+  | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT
+and ct_INT_LIST =
+    CT_int_list of ct_INT list
+and ct_INT_NE_LIST =
+    CT_int_ne_list of ct_INT * ct_INT list
+and ct_INT_OPT =
+    CT_coerce_INT_to_INT_OPT of ct_INT
+  | CT_coerce_NONE_to_INT_OPT of ct_NONE
+and ct_INT_OR_LOCN =
+    CT_coerce_INT_to_INT_OR_LOCN of ct_INT
+  | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN
+and ct_INT_OR_NEXT =
+    CT_coerce_INT_to_INT_OR_NEXT of ct_INT
+  | CT_next_level
+and ct_INV_TYPE =
+    CT_inv_clear
+  | CT_inv_regular
+  | CT_inv_simple
+and ct_IN_OR_OUT_MODULES =
+    CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE
+  | CT_in_modules of ct_ID_NE_LIST
+  | CT_out_modules of ct_ID_NE_LIST
+and ct_LET_CLAUSE =
+    CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE
+and ct_LET_CLAUSES =
+    CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list
+and ct_LET_VALUE =
+    CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY
+  | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM
+and ct_LOCAL_OPT =
+    CT_coerce_NONE_to_LOCAL_OPT of ct_NONE
+  | CT_local
+and ct_LOCN =
+    CT_locn of string
+and ct_MATCHED_FORMULA =
+    CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA
+  | CT_formula_as of ct_FORMULA * ct_ID_OPT
+  | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA
+  | CT_formula_in of ct_FORMULA * ct_FORMULA
+and ct_MATCHED_FORMULA_NE_LIST =
+    CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list
+and ct_MATCH_PATTERN =
+    CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT
+  | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM
+  | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST
+  | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT
+  | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN
+  | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST
+and ct_MATCH_PATTERN_LIST =
+    CT_match_pattern_list of ct_MATCH_PATTERN list
+and ct_MATCH_PATTERN_NE_LIST =
+    CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list
+and ct_MATCH_TAC_RULE =
+    CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE
+and ct_MATCH_TAC_RULES =
+    CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list
+and ct_MODIFIER =
+    CT_entry_type of ct_ID * ct_ID
+  | CT_format of ct_STRING
+  | CT_lefta
+  | CT_nona
+  | CT_only_parsing
+  | CT_righta
+  | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT
+  | CT_set_level of ct_INT
+and ct_MODIFIER_LIST =
+    CT_modifier_list of ct_MODIFIER list
+and ct_MODULE_BINDER =
+    CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE
+and ct_MODULE_BINDER_LIST =
+    CT_module_binder_list of ct_MODULE_BINDER list
+and ct_MODULE_EXPR =
+    CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT
+  | 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
+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
+and ct_MODULE_TYPE_OPT =
+    CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT
+  | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE
+and ct_NATURAL_FEATURE =
+    CT_contractible
+  | CT_implicit
+  | CT_nat_transparent
+and ct_NONE =
+    CT_none
+and ct_NUM =
+    CT_int_encapsulator of string
+and ct_NUM_TYPE =
+    CT_num_type of string
+and ct_OMEGA_FEATURE =
+    CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING
+  | CT_flag_action
+  | CT_flag_system
+  | CT_flag_time
+and ct_OMEGA_MODE =
+    CT_set
+  | CT_switch
+  | CT_unset
+and ct_ORIENTATION =
+    CT_lr
+  | CT_rl
+and ct_PATTERN =
+    CT_pattern_occ of ct_INT_LIST * ct_FORMULA
+and ct_PATTERN_NE_LIST =
+    CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list
+and ct_PATTERN_OPT =
+    CT_coerce_NONE_to_PATTERN_OPT of ct_NONE
+  | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN
+and ct_PREMISE =
+    CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA
+  | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA
+  | CT_premise of ct_ID * ct_FORMULA
+and ct_PREMISES_LIST =
+    CT_premises_list of ct_PREMISE list
+and ct_PREMISE_PATTERN =
+    CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN
+and ct_PROOF_SCRIPT =
+    CT_proof_script of ct_COMMAND list
+and ct_RECCONSTR =
+    CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
+  | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT
+  | CT_recconstr of ct_ID_OPT * ct_FORMULA
+  | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA
+and ct_RECCONSTR_LIST =
+    CT_recconstr_list of ct_RECCONSTR list
+and ct_REC_TACTIC_FUN =
+    CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM
+and ct_REC_TACTIC_FUN_LIST =
+    CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list
+and ct_RED_COM =
+    CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
+  | CT_fold of ct_FORMULA_LIST
+  | CT_hnf
+  | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET
+  | CT_pattern of ct_PATTERN_NE_LIST
+  | CT_red
+  | CT_simpl of ct_PATTERN_OPT
+  | CT_unfold of ct_UNFOLD_NE_LIST
+and ct_RETURN_INFO =
+    CT_coerce_NONE_to_RETURN_INFO of ct_NONE
+  | CT_as_and_return of ct_ID_OPT * ct_FORMULA
+  | CT_return of ct_FORMULA
+and ct_RULE =
+    CT_rule of ct_PREMISES_LIST * ct_FORMULA
+and ct_RULE_LIST =
+    CT_rule_list of ct_RULE list
+and ct_SCHEME_SPEC =
+    CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE
+and ct_SCHEME_SPEC_LIST =
+    CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list
+and ct_SCOMMENT_CONTENT =
+    CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA
+  | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING
+and ct_SCOMMENT_CONTENT_LIST =
+    CT_scomment_content_list of ct_SCOMMENT_CONTENT list
+and ct_SECTION_BEGIN =
+    CT_section of ct_ID
+and ct_SECTION_BODY =
+    CT_section_body of ct_COMMAND list
+and ct_SIGNED_INT =
+    CT_coerce_INT_to_SIGNED_INT of ct_INT
+  | CT_minus of ct_INT
+and ct_SIGNED_INT_LIST =
+    CT_signed_int_list of ct_SIGNED_INT list
+and ct_SINGLE_OPTION_VALUE =
+    CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT
+  | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING
+and ct_SORT_TYPE =
+    CT_sortc of string
+and ct_SPEC_LIST =
+    CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST
+  | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST
+and ct_SPEC_OPT =
+    CT_coerce_NONE_to_SPEC_OPT of ct_NONE
+  | CT_spec
+and ct_STAR =
+    CT_star
+and ct_STAR_OPT =
+    CT_coerce_NONE_to_STAR_OPT of ct_NONE
+  | CT_coerce_STAR_to_STAR_OPT of ct_STAR
+and ct_STRING =
+    CT_string of string
+and ct_STRING_NE_LIST =
+    CT_string_ne_list of ct_STRING * ct_STRING list
+and ct_STRING_OPT =
+    CT_coerce_NONE_to_STRING_OPT of ct_NONE
+  | CT_coerce_STRING_to_STRING_OPT of ct_STRING
+and ct_TABLE =
+    CT_coerce_ID_to_TABLE of ct_ID
+  | CT_table of ct_ID * ct_ID
+and ct_TACTIC_ARG =
+    CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD
+  | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT
+  | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM
+  | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE
+  | CT_void
+and ct_TACTIC_ARG_LIST =
+    CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list
+and ct_TACTIC_COM =
+    CT_abstract of ct_ID_OPT * ct_TACTIC_COM
+  | CT_absurd of ct_FORMULA
+  | CT_any_constructor of ct_TACTIC_OPT
+  | CT_apply of ct_FORMULA * ct_SPEC_LIST
+  | CT_assert of ct_ID_OPT * ct_FORMULA
+  | CT_assumption
+  | CT_auto of ct_INT_OPT
+  | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR
+  | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT
+  | CT_autotdb of ct_INT_OPT
+  | CT_case_type of ct_FORMULA
+  | CT_casetac of ct_FORMULA * ct_SPEC_LIST
+  | CT_cdhyp of ct_ID
+  | CT_change of ct_FORMULA * ct_CLAUSE
+  | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE
+  | CT_clear of ct_ID_NE_LIST
+  | CT_clear_body of ct_ID_NE_LIST
+  | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST
+  | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
+  | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT
+  | CT_constructor of ct_INT * ct_SPEC_LIST
+  | CT_contradiction
+  | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST
+  | CT_cut of ct_FORMULA
+  | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT
+  | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT
+  | CT_dauto of ct_INT_OPT * ct_INT_OPT
+  | CT_dconcl
+  | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA
+  | CT_decompose_record of ct_FORMULA
+  | CT_decompose_sum of ct_FORMULA
+  | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT
+  | CT_deprewrite_lr of ct_ID
+  | CT_deprewrite_rl of ct_ID
+  | CT_destruct of ct_ID_OR_INT
+  | CT_dhyp of ct_ID
+  | CT_discriminate_eq of ct_ID_OR_INT_OPT
+  | CT_do of ct_ID_OR_INT * ct_TACTIC_COM
+  | CT_eapply of ct_FORMULA * ct_SPEC_LIST
+  | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT
+  | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR
+  | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING
+  | CT_elim_type of ct_FORMULA
+  | CT_exact 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
+  | CT_firstorder of ct_TACTIC_OPT
+  | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST
+  | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST
+  | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST
+  | CT_formula_marker of ct_FORMULA
+  | CT_fresh of ct_STRING_OPT
+  | CT_generalize of ct_FORMULA_NE_LIST
+  | CT_generalize_dependent of ct_FORMULA
+  | CT_idtac of ct_STRING_OPT
+  | CT_induction of ct_ID_OR_INT
+  | CT_info of ct_TACTIC_COM
+  | CT_injection_eq of ct_ID_OR_INT_OPT
+  | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE
+  | CT_intro of ct_ID_OPT
+  | CT_intro_after of ct_ID_OPT * ct_ID
+  | CT_intros of ct_INTRO_PATT_LIST
+  | CT_intros_until of ct_ID_OR_INT
+  | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST
+  | CT_left of ct_SPEC_LIST
+  | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE
+  | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE
+  | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list
+  | 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_omega
+  | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM
+  | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list
+  | CT_pose of ct_ID_OPT * ct_FORMULA
+  | CT_progress of ct_TACTIC_COM
+  | CT_prolog of ct_FORMULA_LIST * ct_INT
+  | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM
+  | CT_reduce of ct_RED_COM * ct_CLAUSE
+  | CT_refine of ct_FORMULA
+  | 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_right of ct_SPEC_LIST
+  | CT_ring of ct_FORMULA_LIST
+  | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST
+  | CT_simplify_eq of ct_ID_OR_INT_OPT
+  | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST
+  | CT_split of ct_SPEC_LIST
+  | CT_subst of ct_ID_LIST
+  | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB
+  | CT_symmetry of ct_CLAUSE
+  | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT
+  | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list
+  | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM
+  | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list
+  | CT_transitivity of ct_FORMULA
+  | CT_trivial
+  | CT_trivial_with of ct_ID_NE_LIST_OR_STAR
+  | CT_truecut of ct_ID_OPT * ct_FORMULA
+  | CT_try of ct_TACTIC_COM
+  | CT_use of ct_FORMULA
+  | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST
+  | CT_user_tac of ct_ID * ct_TARG_LIST
+and ct_TACTIC_OPT =
+    CT_coerce_NONE_to_TACTIC_OPT of ct_NONE
+  | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM
+and ct_TAC_DEF =
+    CT_tac_def of ct_ID * ct_TACTIC_COM
+and ct_TAC_DEF_NE_LIST =
+    CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list
+and ct_TARG =
+    CT_coerce_BINDING_to_TARG of ct_BINDING
+  | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC
+  | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC
+  | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT
+  | CT_coerce_PATTERN_to_TARG of ct_PATTERN
+  | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT
+  | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST
+  | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE
+  | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST
+  | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM
+  | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST
+  | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD
+  | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST
+and ct_TARG_LIST =
+    CT_targ_list of ct_TARG list
+and ct_TERM_CHANGE =
+    CT_check_term of ct_FORMULA
+  | CT_inst_term of ct_ID * ct_FORMULA
+and ct_TEXT =
+    CT_coerce_ID_to_TEXT of ct_ID
+  | CT_text_formula of ct_FORMULA
+  | CT_text_h of ct_TEXT list
+  | CT_text_hv of ct_TEXT list
+  | CT_text_op of ct_TEXT list
+  | CT_text_path of ct_SIGNED_INT_LIST
+  | CT_text_v of ct_TEXT list
+and ct_THEOREM_GOAL =
+    CT_goal of ct_FORMULA
+  | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA
+and ct_THM =
+    CT_thm of string
+and ct_THM_OPT =
+    CT_coerce_NONE_to_THM_OPT of ct_NONE
+  | CT_coerce_THM_to_THM_OPT of ct_THM
+and ct_TYPED_FORMULA =
+    CT_typed_formula of ct_FORMULA * ct_FORMULA
+and ct_UNFOLD =
+    CT_coerce_ID_to_UNFOLD of ct_ID
+  | CT_unfold_occ of ct_ID * ct_INT_NE_LIST
+and ct_UNFOLD_NE_LIST =
+    CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list
+and ct_USING =
+    CT_coerce_NONE_to_USING of ct_NONE
+  | CT_using of ct_FORMULA * ct_SPEC_LIST
+and ct_USINGTDB =
+    CT_coerce_NONE_to_USINGTDB of ct_NONE
+  | CT_usingtdb
+and ct_VAR =
+    CT_var of string
+and ct_VARG =
+    CT_coerce_AST_to_VARG of ct_AST
+  | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST
+  | CT_coerce_BINDER_to_VARG of ct_BINDER
+  | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST
+  | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST
+  | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST
+  | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT
+  | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT
+  | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL
+  | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT
+  | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST
+  | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT
+  | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT
+  | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT
+  | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST
+and ct_VARG_LIST =
+    CT_varg_list of ct_VARG list
+and ct_VERBOSE_OPT =
+    CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE
+  | CT_verbose
+;;
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
new file mode 100755
index 00000000..d5236a7a
--- /dev/null
+++ b/contrib/interface/blast.ml
@@ -0,0 +1,628 @@
+(* 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;;
+open Environ;;
+open Equality;;
+open Evd;;
+open Hipattern;;
+open Inductive;;
+open Names;;
+open Pattern;;
+open Pbp;;
+open Pfedit;;
+open Pp;;
+open Printer
+open Proof_trees;;
+open Proof_type;;
+open Rawterm;;
+open Reduction;;
+open Refiner;;
+open Sign;;
+open String;;
+open Tacmach;;
+open Tacred;;
+open Tacticals;;
+open Tactics;;
+open Term;;
+open Typing;;
+open Util;;
+open Vernacentries;;
+open Vernacinterp;;
+open Evar_refiner;;
+
+
+let parse_com   = Pcoq.parse_string Pcoq.Constr.constr;;
+let parse_tac  t =
+    try (Pcoq.parse_string Pcoq.Tactic.tactic t)
+    with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t));
+	       failwith "tactic")
+;;
+
+let is_free () =
+   let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in
+   let c=input_char st in
+   close_in st;
+   c = 'A'
+;;
+
+(* marche pas *)
+(*
+let is_free () =
+   msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]);
+   let s = Stream.of_channel stdin in
+   msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]);
+   try (Stream.empty s;
+        msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]);
+        true)
+   with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]);
+              false)
+;;
+*)
+let free_try tac g =
+    if is_free()
+    then (tac g)
+    else (failwith "not free")
+;;
+let adrel (x,t) e =
+    match x with 
+      Name(xid) -> Environ.push_rel (x,None,t) e
+    | Anonymous -> Environ.push_rel (x,None,t) e
+(* les constantes ayant une définition apparaissant dans x *)
+let rec def_const_in_term_rec vl x = 
+     match (kind_of_term x) with
+     Prod(n,t,c)->
+        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
+   | Lambda(n,t,c) ->
+        let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c
+   | App(f,args) -> def_const_in_term_rec vl f
+   | Sort(Prop(Null)) -> Prop(Null)
+   | Sort(c) -> c
+   | Ind(ind) ->
+          let (mib, mip) = Global.lookup_inductive ind in
+          mip.mind_sort
+   | 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
+   | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x)
+;;
+let def_const_in_term_ x =
+    def_const_in_term_rec  (Global.env()) (strip_outer_cast x)
+;;
+(*************************************************************************
+ recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli 
+ modif de print_info_script avec pr_bar
+*)
+
+let pr_bar () = str "|"
+
+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
+             | [] ->
+		   (str " " ++ fnl())
+             | [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_bar
+                         (print_info_script sigma sign) spfl ++
+                       str"]")
+
+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 pp_string x =
+   msgnl_with Format.str_formatter x;
+   Format.flush_str_formatter ()
+;;
+
+(***********************************************************************
+   copié de tactics/eauto.ml
+*)
+
+(***************************************************************************)
+(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
+(***************************************************************************)
+
+let unify_e_resolve  (c,clenv) gls = 
+  let (wc,kONT) = startWalk gls in
+  let clenv' = connect_clenv wc clenv in
+  let _ = clenv_unique_resolver false clenv' gls in
+  vernac_e_resolve_constr c gls
+
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl = 
+    registered_e_assumption ::
+    (tclTHEN Tactics.intro 
+       (function g'->
+	  let d = pf_last_hyp g' in
+	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
+          (e_trivial_fail_db db_list
+	     (Hint_db.add_list hintl local_db) g'))) ::
+    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+  in 
+  tclFIRST (List.map tclCOMPLETE tacl) goal 
+
+and e_my_find_search db_list local_db hdc concl = 
+  let hdc = head_of_constr_reference hdc in
+  let hintl =
+    if occur_existential concl then 
+      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+    else 
+      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+  in 
+  let tac_of_hint = 
+    fun ({pri=b; pat = p; code=t} as patac) -> 
+      (b, 
+       let tac =
+	 match t with
+	   | Res_pf (term,cl) -> unify_resolve (term,cl)
+	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
+	   | Give_exact (c) -> e_give_exact_constr c
+	   | Res_pf_THEN_trivial_fail (term,cl) ->
+               tclTHEN (unify_e_resolve (term,cl)) 
+		 (e_trivial_fail_db db_list local_db)
+	   | Unfold_nth c -> unfold_constr c
+	   | Extern tacast -> Auto.conclPattern concl 
+	       (out_some p) tacast
+       in 
+       (free_try tac,fmt_autotactic t))
+       (*i
+	 fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); 
+                     try tac gls
+		     with e when Logic.catchable_exception(e) -> 
+                            (Format.print_string "Fail\n"; 
+			     Format.print_flush (); 
+			     raise e)
+       i*)
+  in 
+  List.map tac_of_hint hintl
+    
+and e_trivial_resolve db_list local_db gl = 
+  try 
+    Auto.priority 
+      (e_my_find_search db_list local_db 
+	 (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db gl =
+  try List.map snd (e_my_find_search db_list local_db 
+		      (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
+
+let find_first_goal gls = 
+  try first_goal gls with UserError _ -> assert false
+
+(*s The following module [SearchProblem] is used to instantiate the generic
+    exploration functor [Explore.Make]. *)
+      
+module MySearchProblem = struct
+
+  type state = { 
+    depth : int; (*r depth of search before failing *)
+    tacres : goal list sigma * validation;
+    last_tactic : std_ppcmds;
+    dblist : Auto.Hint_db.t list;
+    localdb :  Auto.Hint_db.t list }
+		 
+  let success s = (sig_it (fst s.tacres)) = []
+
+  let rec filter_tactics (glls,v) = function
+    | [] -> []
+    | (tac,pptac) :: tacl -> 
+	try 
+	  let (lgls,ptl) = apply_tac_list tac glls in 
+	  let v' p = v (ptl p) in
+	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
+	with e when Logic.catchable_exception e ->
+	  filter_tactics (glls,v) tacl
+
+  let rec list_addn n x l = 
+    if n = 0 then l else x :: (list_addn (pred n) x l)
+
+  (* Ordering of states is lexicographic on depth (greatest first) then
+     number of remaining goals. *)
+  let compare s s' =
+    let d = s'.depth - s.depth in
+    let nbgoals s = List.length (sig_it (fst s.tacres)) in
+    if d <> 0 then d else nbgoals s - nbgoals s'
+
+  let branching s = 
+    if s.depth = 0 then 
+      []
+    else      
+      let lg = fst s.tacres in
+      let nbgl = List.length (sig_it lg) in
+      assert (nbgl > 0);
+      let g = find_first_goal lg in
+      let assumption_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (List.map 
+	       (fun id -> (e_give_exact_constr (mkVar id),
+			   (str "Exact" ++ spc()++ pr_id id)))
+	       (pf_ids_of_hyps g))
+	in
+	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
+				    last_tactic = pp; dblist = s.dblist;
+				    localdb = List.tl s.localdb }) l
+      in
+      let intro_tac = 
+	List.map 
+	  (fun ((lgls,_) as res,pp) -> 
+	     let g' = first_goal lgls in 
+	     let hintl = 
+	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	     in
+             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+	     { depth = s.depth; tacres = res; 
+	       last_tactic = pp; dblist = s.dblist;
+	       localdb = ldb :: List.tl s.localdb })
+	  (filter_tactics s.tacres [Tactics.intro,(str "Intro" )])
+      in
+      let rec_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+	in
+	List.map 
+	  (fun ((lgls,_) as res, pp) -> 
+	     let nbgl' = List.length (sig_it lgls) in
+	     if nbgl' < nbgl then
+	       { depth = s.depth; tacres = res; last_tactic = pp;
+		 dblist = s.dblist; localdb = List.tl s.localdb }
+	     else 
+	       { depth = pred s.depth; tacres = res; 
+		 dblist = s.dblist; last_tactic = pp;
+		 localdb = 
+		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
+	  l
+      in
+      List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
+
+  let pp s = 
+    msg (hov 0 (str " depth="++ int s.depth ++ spc() ++
+		  s.last_tactic ++ str "\n"))
+
+end
+
+module MySearch = Explore.Make(MySearchProblem)
+
+let make_initial_state n gl dblist localdb =
+  { MySearchProblem.depth = n;
+    MySearchProblem.tacres = tclIDTAC gl;
+    MySearchProblem.last_tactic = (mt ());
+    MySearchProblem.dblist = dblist;
+    MySearchProblem.localdb = [localdb] }
+
+let e_depth_search debug p db_list local_db gl =
+  try
+    let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in
+    let s = tac (make_initial_state p gl db_list local_db) in
+    s.MySearchProblem.tacres
+  with Not_found -> error "EAuto: depth first search failed"
+
+let e_breadth_search debug n db_list local_db gl =
+  try
+    let tac = 
+      if debug then MySearch.debug_breadth_first else MySearch.breadth_first 
+    in
+    let s = tac (make_initial_state n gl db_list local_db) in
+    s.MySearchProblem.tacres
+  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 
+  if n = 0 then 
+    e_depth_search debug p db_list local_db gl
+  else 
+    e_breadth_search debug n db_list local_db gl
+
+let eauto debug np dbnames = 
+  let db_list =
+    List.map
+      (fun x -> 
+	 try Stringmap.find x !searchtable
+	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  tclTRY (e_search_auto debug np db_list)
+
+let full_eauto debug n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames =  list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in
+  let local_db = make_local_hint_db gl in
+  tclTRY (e_search_auto debug n db_list) gl
+
+let 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
+  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
+
+let rec trivial_fail_db db_list local_db gl =
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g'->
+	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+  in
+  tclFIRST 
+    (assumption::intro_tac::
+     (List.map tclCOMPLETE 
+	(trivial_resolve db_list local_db (pf_concl gl)))) gl
+
+and my_find_search db_list local_db hdc concl =
+  let tacl = 
+    if occur_existential concl then 
+      list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
+    else 
+      list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
+      	(local_db::db_list)
+  in
+  List.map 
+    (fun ({pri=b; pat=p; code=t} as patac) -> 
+       (b,
+	match t with
+	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
+	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
+	  | Give_exact c  -> exact_check c
+	  | Res_pf_THEN_trivial_fail (term,cl) -> 
+	      tclTHEN 
+		(unify_resolve (term,cl)) 
+		(trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> unfold_constr c
+	  | Extern tacast -> 
+	      conclPattern concl (out_some p) tacast))
+    tacl
+
+and trivial_resolve db_list local_db cl = 
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    priority 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+(**************************************************************************)
+(*                       The classical Auto tactic                        *)
+(**************************************************************************)
+
+let possible_resolve db_list local_db cl =
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    List.map snd 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+let decomp_unary_term c gls = 
+  let typc = pf_type_of gls c in 
+  let hd = List.hd (head_constr typc) in 
+  if Hipattern.is_conjunction hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_unary_term" (str "not a unary type")
+
+let decomp_empty_term c gls = 
+  let typc = pf_type_of gls c in 
+  let (hd,_) = decompose_app typc in 
+  if Hipattern.is_empty_type hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_empty_term" (str "not an empty type")
+
+
+(* decomp is an natural number giving an indication on decomposition 
+   of conjunction in hypotheses, 0 corresponds to no decomposition *)
+(* n is the max depth of search *)
+(* local_db contains the local Hypotheses *)
+
+let rec search_gen decomp n db_list local_db extra_sign goal =
+  if n=0 then error "BOUND 2";
+  let decomp_tacs = match decomp with 
+    | 0 -> [] 
+    | p -> 
+	(tclTRY_sign decomp_empty_term extra_sign)
+	::
+	(List.map 
+	   (fun id -> tclTHEN (decomp_unary_term (mkVar id)) 
+		(tclTHEN 
+		   (clear [id])
+		   (free_try (search_gen decomp p db_list local_db []))))
+	   (pf_ids_of_hyps goal)) 
+  in
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g' -> 
+	 let (hid,_,htyp as d) = pf_last_hyp g' in
+	 let hintl = 
+	   try 
+	     [make_apply_entry (pf_env g') (project g')
+		(true,false) 
+		hid (mkVar hid,body_of_type htyp)]
+	   with Failure _ -> [] 
+	 in
+         (free_try
+	  (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d])
+	  g'))
+  in
+  let rec_tacs = 
+    List.map 
+      (fun ntac -> 
+	 tclTHEN ntac
+	   (free_try
+	    (search_gen decomp (n-1) db_list local_db empty_named_context)))
+      (possible_resolve db_list local_db (pf_concl goal))
+  in 
+  tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
+
+
+let search = search_gen 0
+
+let default_search_depth = ref 5
+			     
+let full_auto n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames = list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  let hyps = pf_hyps gl in
+  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+  
+let default_full_auto gl = full_auto !default_search_depth gl
+(************************************************************************)
+
+let blast_tactic = ref (free_try default_full_auto)
+;;
+
+let blast_auto = (free_try default_full_auto)
+(*                  (tclTHEN (free_try default_full_auto)
+			  (free_try (my_full_eauto 2)))
+*)
+;;
+let blast_simpl = (free_try (reduce (Simpl None) onConcl))
+;;
+let blast_induction1 = 
+    (free_try (tclTHEN (tclTRY intro)
+		       (tclTRY (tclLAST_HYP simplest_elim))))
+;;
+let blast_induction2 = 
+    (free_try (tclTHEN (tclTRY (tclTHEN intro intro))
+		       (tclTRY (tclLAST_HYP simplest_elim))))
+;;
+let blast_induction3 = 
+    (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro)))
+		       (tclTRY (tclLAST_HYP simplest_elim))))
+;;
+
+blast_tactic :=
+  (tclORELSE (tclCOMPLETE blast_auto)
+  (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto))
+  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1
+                          (tclTHEN blast_simpl blast_auto)))
+  (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2
+                          (tclTHEN blast_simpl blast_auto)))
+             (tclCOMPLETE (tclTHEN blast_induction3
+                          (tclTHEN blast_simpl blast_auto)))))))
+;;
+(*
+blast_tactic := (tclTHEN (free_try default_full_auto)
+			 (free_try (my_full_eauto 4)))
+;;
+*)
+
+let vire_extvar s =
+   let interro = ref false in
+   let interro_pos = ref 0 in
+   for i=0 to (length s)-1 do
+     if get s i = '?'
+     then (interro := true;
+           interro_pos := i)
+     else if (!interro && 
+              (List.mem (get s i)
+			['0';'1';'2';'3';'4';'5';'6';'7';'8';'9']))
+     then set s i ' '
+     else interro:=false
+   done;
+   s
+;;
+
+let blast gls =
+   let leaf g = {
+      open_subgoals = 1;
+      goal = g;
+      ref = None } 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
+                let sign = (sig_it gls).evar_hyps in
+                let x = print_subscript 
+                     (sig_sig gls) sign pf in
+		msgnl (hov 0 (str"Blast ==> " ++ x));
+                let x = print_subscript 
+                     (sig_sig gls) sign pf in
+                let tac_string =
+                pp_string  (hov 0 x ) in
+    (* on remplace les ?1 ?2 ... de refine par ? *)
+		parse_tac ((vire_extvar tac_string)
+			   ^ ".")
+	  )
+	  else (msgnl (hov 0 (str"Blast failed to prove the goal..."));
+		failwith "echec de blast"))
+     with _ -> failwith "echec de blast"
+;;
+
+let blast_tac display_function = function 
+          | (n::_) as l -> 
+                 (function g ->
+                    let exp_ast = (blast g) in
+                     (display_function exp_ast;
+                       tclIDTAC g))
+          |  _ -> failwith "expecting other arguments";;
+
+let blast_tac_txt = 
+  blast_tac
+    (function x -> msgnl(Pptactic.pr_glob_tactic (Tacinterp.glob_tactic x)));;
+
+(* Obsolète ?
+overwriting_add_tactic "Blast1" blast_tac_txt;;
+*)
+
+(*
+Grammar tactic ne_numarg_list : list :=
+  ne_numarg_single [numarg($n)] ->[$n]
+| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ].
+Grammar tactic simple_tactic : ast :=
+  blast1 [ "Blast1" ne_numarg_list($ns) ] ->
+         [ (Blast1 ($LIST $ns)) ].
+
+
+
+PATH=/usr/local/bin:/usr/bin:$PATH
+COQTOP=d:/Tools/coq-7.0-3mai
+CAMLLIB=/usr/local/lib/ocaml
+CAMLP4LIB=/usr/local/lib/camlp4
+export CAMLLIB
+export COQTOP
+export CAMLP4LIB 
+d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe 
+Drop.
+#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";;
+*)
diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli
new file mode 100644
index 00000000..21c29bc9
--- /dev/null
+++ b/contrib/interface/blast.mli
@@ -0,0 +1,5 @@
+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;;
+
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
new file mode 100644
index 00000000..7bf12f3b
--- /dev/null
+++ b/contrib/interface/centaur.ml4
@@ -0,0 +1,700 @@
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(*Toplevel loop for the communication between Coq and Centaur *)
+open Names;;
+open Nameops;;
+open Util;;
+open Ast;;
+open Term;;
+open Pp;;
+open Libnames;;
+open Libobject;;
+open Library;;
+open Vernacinterp;;
+open Evd;;
+open Proof_trees;;
+open Termast;;
+open Tacmach;;
+open Pfedit;;
+open Proof_type;;
+open Parsing;;
+open Environ;;
+open Declare;;
+open Declarations;;
+open Rawterm;;
+open Reduction;;
+open Classops;;
+open Vernacinterp;;
+open Vernac;;
+open Command;;
+open Protectedtoplevel;;
+open Coqast;;
+open Line_oriented_parser;;
+open Xlate;;
+open Vtp;;
+open Ascent;;
+open Translate;;
+open Name_to_ast;;
+open Pbp;;
+open Blast;;
+(* open Dad;; *)
+open Debug_tac;;
+open Search;;
+open Constrintern;;
+open Nametab;;
+open Showproof;;
+open Showproof_ct;;
+open Tacexpr;;
+open Vernacexpr;;
+
+let pcoq_started = ref None;;
+
+let if_pcoq f a =
+  if !pcoq_started <> None then f a else error "Pcoq is not started";;
+
+let text_proof_flag = ref "en";;
+
+let current_proof_name () = 
+  try 
+    string_of_id (get_current_proof_name ())
+  with
+      UserError("Pfedit.get_proof", _) -> "";;
+
+let current_goal_index = ref 0;;
+
+let guarded_force_eval_stream (s : std_ppcmds) = 
+  let l = ref [] in
+  let f elt = l:= elt :: !l in 
+  (try  Stream.iter f s with
+  | _ -> f (Stream.next (str "error guarded_force_eval_stream")));
+  Stream.of_list (List.rev !l);;
+
+
+let rec string_of_path p =
+    match p with [] -> "\n"
+              | i::p -> (string_of_int i)^" "^ (string_of_path p)
+;;
+let print_path p =
+    output_results_nl (str "Path:" ++ str  (string_of_path p))
+;;
+
+let kill_proof_node index =
+ let paths = History.historical_undo (current_proof_name()) index in
+ let _ =  List.iter
+            (fun path -> (traverse_to path;
+                          Pfedit.mutate weak_undo_pftreestate;
+			  traverse_to []))
+          paths in
+ History.border_length (current_proof_name());;
+
+
+(*Message functions, the text of these messages is recognized by the protocols *)
+(*of CtCoq                                                                     *)
+let ctf_header message_name request_id =
+ fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++
+ int request_id ++ fnl();;
+
+let ctf_acknowledge_command request_id command_count opt_exn =
+  let goal_count, goal_index = 
+    if refining() then
+      let g_count =
+        List.length 
+          (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in
+        g_count, (min g_count !current_goal_index)
+    else
+      (0, 0) in
+   (ctf_header "acknowledge" request_id ++
+    int command_count ++ fnl() ++
+    int goal_count ++ fnl () ++
+    int goal_index ++ fnl () ++
+    str (current_proof_name()) ++ fnl() ++
+    (match opt_exn with
+      Some e -> Cerrors.explain_exn e
+    | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());;
+
+let ctf_undoResults = ctf_header "undo_results";;
+
+let ctf_TextMessage = ctf_header "text_proof";;
+
+let ctf_SearchResults = ctf_header "search_results";;
+
+let ctf_OtherGoal = ctf_header "other_goal";;
+
+let ctf_Location = ctf_header "location";;
+
+let ctf_StateMessage = ctf_header "state";;
+
+let ctf_PathGoalMessage () =
+ fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();;
+
+let ctf_GoalReqIdMessage = ctf_header "single_goal_state";;
+
+let ctf_NewStateMessage = ctf_header "fresh_state";;
+
+let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++
+			  str "saved" ++ fnl();;
+
+let ctf_KilledMessage req_id ngoals =
+ ctf_header "killed" req_id ++ int ngoals ++ fnl ();;
+
+let ctf_AbortedAllMessage () =
+  fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();;
+
+let ctf_AbortedMessage request_id na =
+  ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ 
+  str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
+
+let ctf_UserErrorMessage request_id stream =
+ let stream = guarded_force_eval_stream stream in
+ ctf_header "user_error" request_id ++ stream ++ fnl() ++
+ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
+
+let ctf_ResetInitialMessage () =
+ fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();;
+
+let ctf_ResetIdentMessage request_id s =
+ ctf_header "reset_ident" request_id ++ str s ++ fnl () ++
+  str  "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
+
+type vtp_tree =
+  | P_rl of ct_RULE_LIST
+  | P_r of ct_RULE
+  | P_s_int of ct_SIGNED_INT_LIST
+  | P_pl of ct_PREMISES_LIST
+  | P_cl of ct_COMMAND_LIST
+  | P_t of ct_TACTIC_COM
+  | P_text of ct_TEXT
+  | P_ids of ct_ID_LIST;;
+
+let print_tree t = 
+  (match t with
+  | P_rl x -> fRULE_LIST x
+  | P_r x -> fRULE x
+  | P_s_int x -> fSIGNED_INT_LIST x
+  | P_pl x -> fPREMISES_LIST x
+  | P_cl x -> fCOMMAND_LIST x
+  | P_t x -> fTACTIC_COM x
+  | P_text x -> fTEXT x
+  | P_ids x -> fID_LIST x);
+  print_string "e\nblabla\n";;
+
+
+
+let break_happened = ref false;;
+
+let output_results stream vtp_tree =
+    let _ = Sys.signal Sys.sigint
+       (Sys.Signal_handle(fun i -> (break_happened := true;()))) in
+    msg stream;
+    match vtp_tree with
+      Some t -> print_tree t
+    | None -> ();;
+
+let output_results_nl stream =
+    let _ = Sys.signal Sys.sigint
+       (Sys.Signal_handle(fun i -> break_happened := true;()))
+    in
+    msgnl stream;;
+
+
+let rearm_break () =
+    let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break))
+    in ();;
+
+let check_break () =
+   if (!break_happened) then
+    begin
+      break_happened := false;
+      raise Sys.Break
+    end
+   else ();;
+
+let print_past_goal index =
+ let path = History.get_path_for_rank (current_proof_name()) index in
+ try traverse_to path;
+     let pf = proof_of_pftreestate (get_pftreestate ()) in
+     output_results  (ctf_PathGoalMessage ())
+       (Some (P_r (translate_goal pf.goal)))
+ with
+   | Invalid_argument s ->
+      ((try traverse_to [] with _ -> ());
+       error "No focused proof (No proof-editing in progress)")
+   | e -> (try traverse_to [] with _ -> ()); raise e
+;;
+
+let show_nth n =
+  try
+    let pf = proof_of_pftreestate (get_pftreestate()) in
+    if (!text_proof_flag<>"off") then
+       (if n=0
+	   then output_results (ctf_TextMessage !global_request_id)
+                               (Some (P_text (show_proof !text_proof_flag [])))
+           else			       
+	   let path = History.get_nth_open_path (current_proof_name()) n in
+	   output_results (ctf_TextMessage !global_request_id)
+                          (Some (P_text (show_proof !text_proof_flag path))))
+    else
+      output_results (ctf_GoalReqIdMessage !global_request_id)
+      (let goal = List.nth (fst (frontier pf))
+                   (n - 1) in
+      (Some (P_r (translate_goal goal))))
+  with
+  | Invalid_argument s -> 
+       error "No focused proof (No proof-editing in progress)";;
+
+(* The rest of the file contains commands that are changed from the plain
+   Coq distribution *)
+
+let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);;
+
+(*
+let filter_by_module_from_varg_list l =
+  let dir_list, b = Vernacentries.interp_search_restriction l in
+    Search.filter_by_module_from_list (dir_list, b);;
+*)
+
+let add_search (global_reference:global_reference) assumptions cstr =
+  try 
+  let id_string =
+    string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty
+			global_reference) in
+  let ast = 
+    try
+      CT_premise (CT_ident id_string, translate_constr false assumptions cstr)
+    with Not_found ->
+      CT_premise (CT_ident id_string,
+                  CT_coerce_ID_to_FORMULA(
+                    CT_ident ("Error printing" ^ id_string))) in
+    ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST
+  with e -> msgnl (str "add_search raised an exception"); raise e;;
+
+(*
+let make_error_stream node_string =
+  str "The syntax of " ++ str node_string ++
+  str " is inconsistent with the vernac interpreter entry";;
+*)
+
+let ctf_EmptyGoalMessage id =
+  fnl () ++ str "Empty Goal is a no-op.  Fun oh fun." ++ fnl ();;
+
+
+let print_check judg =
+ let {uj_val=value; uj_type=typ} = judg in
+ 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) ++
+			      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
+ ((ctf_SearchResults !global_request_id),
+ (Some  (P_pl
+  (CT_premises_list
+  [CT_coerce_TYPED_FORMULA_to_PREMISE
+    (CT_typed_formula(value_ct_ast,type_ct_ast)
+    )]))));;
+
+let ct_print_eval ast red_fun env judg =
+((if refining() then traverse_to []);
+let {uj_val=value; uj_type=typ} = judg in
+let nvalue = red_fun value
+(* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
+and ntyp = nf_betaiota typ in
+(ctf_SearchResults !global_request_id,
+ Some (P_pl
+  (CT_premises_list
+  [CT_eval_result
+    (xlate_formula ast,
+    translate_constr false env nvalue,
+    translate_constr false env ntyp)]))));;
+
+
+
+(* 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
+        (ctf_header "pbp_results" !global_request_id)
+       (Some (P_t(xlate_tactic x))));;
+
+let blast_tac_pcoq =
+    blast_tac (function (x:raw_tactic_expr) -> 
+      output_results
+	(ctf_header "pbp_results" !global_request_id)
+       (Some (P_t(xlate_tactic x))));;
+
+(* <\cpa> 
+let dad_tac_pcoq =
+  dad_tac(function x -> 
+    output_results
+    (ctf_header "pbp_results" !global_request_id)
+    (Some (P_t(xlate_tactic x))));;
+</cpa> *)
+
+let search_output_results () =
+  output_results
+       (ctf_SearchResults !global_request_id)
+       (Some (P_pl (CT_premises_list
+                      (List.rev !ctv_SEARCH_LIST))));;
+
+
+let debug_tac2_pcoq tac =
+      (fun g ->
+	let the_goal = ref (None : goal sigma option) in
+	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
+	  (errorlabstrm "DEBUG TACTIC"
+	     (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++
+	      fnl () ++ str "the tactic is" ++ fnl () ++
+	      Pptactic.pr_glob_tactic tac);
+	   result)
+	with
+	  e ->
+	    match !the_goal with
+	      None -> raise e
+	    | Some g -> 
+                (output_results
+		   (ctf_Location !global_request_id)
+		   (Some (P_s_int
+			    (CT_signed_int_list
+                               (List.map
+                                  (fun n -> CT_coerce_INT_to_SIGNED_INT
+                                                 (CT_int n))
+                                  (clean_path tac 
+					       (List.rev !the_path)))))));
+	    	(output_results
+		   (ctf_OtherGoal !global_request_id)
+		   (Some (P_r (translate_goal (sig_it g)))));
+	    raise e);;
+
+let rec selectinspect n env =
+    match env with
+      [] -> []
+    | a::tl ->
+      if n = 0 then
+         []
+      else
+         match a with
+           (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl)
+         | _ -> (selectinspect n tl);;
+
+open Term;;
+
+let inspect n =
+  let env = Global.env() in
+  let add_search2 x y = add_search x env y in
+  let l = selectinspect n (Lib.contents_after None) in
+    ctv_SEARCH_LIST := [];
+    List.iter
+      (fun a ->
+	 try
+           (match a with
+             	oname, Lib.Leaf lobj ->
+		  (match oname, object_tag lobj with
+                       (sp,_), "VARIABLE" ->
+			 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
+			   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())
+			      (RRef(dummy_loc, IndRef(kn,0))))
+		     | _ -> failwith ("unexpected value 1 for "^ 
+				      (string_of_id (basename (fst oname)))))
+              | _ -> failwith "unexpected value")
+	 with e -> ())
+      l;
+    output_results
+      (ctf_SearchResults !global_request_id)
+      (Some
+         (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
+
+let ct_int_to_TARG n = 
+	CT_coerce_FORMULA_OR_INT_to_TARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)));;
+
+let pair_list_to_ct l =
+    CT_user_tac(CT_ident "pair_int_list",
+		CT_targ_list
+		  (List.map (fun (a,b) ->
+			       CT_coerce_TACTIC_COM_to_TARG
+				 (CT_user_tac
+				    (CT_ident "pair_int",
+				     CT_targ_list
+				       [ct_int_to_TARG a; ct_int_to_TARG b])))
+		     l));;
+
+(* Annule toutes les commandes qui s'appliquent sur les sous-buts du
+   but auquel a été appliquée la n-ième tactique *)
+let logical_kill n =
+  let path = History.get_path_for_rank (current_proof_name()) n in
+  begin
+    traverse_to path;
+    Pfedit.mutate weak_undo_pftreestate;
+    (let kept_cmds, undone_cmds, remaining_goals, current_goal =
+      History.logical_undo (current_proof_name()) n in
+       output_results (ctf_undoResults !global_request_id)
+	 (Some
+	    (P_t
+	       (CT_user_tac
+		  (CT_ident "log_undo_result",
+		   CT_targ_list
+		     [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds);
+		      CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds);
+		      ct_int_to_TARG remaining_goals;
+		      ct_int_to_TARG current_goal])))));
+    traverse_to []
+  end;;
+
+let simulate_solve n tac =
+  let path = History.get_nth_open_path (current_proof_name()) n in
+  solve_nth n (Tacinterp.hide_interp tac (get_end_tac()));
+  traverse_to path;
+  Pfedit.mutate weak_undo_pftreestate;
+  traverse_to []
+
+let kill_node_verbose n =
+  let ngoals = kill_proof_node n in
+  output_results_nl (ctf_KilledMessage !global_request_id ngoals)
+
+let set_text_mode s = text_proof_flag := s
+
+let pcoq_reset_initial() =
+  output_results(ctf_AbortedAllMessage()) None;
+  Vernacentries.abort_refine Lib.reset_initial ();
+  output_results(ctf_ResetInitialMessage()) None;;
+
+let pcoq_reset x =
+  if refining() then
+    output_results (ctf_AbortedAllMessage ()) None;
+    Vernacentries.abort_refine Lib.reset_name (dummy_loc,x);
+    output_results
+      (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;;
+
+
+VERNAC ARGUMENT EXTEND text_mode
+| [ "fr" ] -> [ "fr" ]
+| [ "en" ] -> [ "en" ]
+| [ "Off" ] -> [ "off" ]
+END
+
+VERNAC COMMAND EXTEND TextMode
+| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ]
+END
+
+VERNAC COMMAND EXTEND OutputGoal
+  [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ]
+END
+
+VERNAC COMMAND EXTEND OutputGoal
+  [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ]
+END
+
+VERNAC COMMAND EXTEND KillProofAfter
+| [ "Kill" "Proof" "after"  natural(n) ] -> [ kill_node_verbose n ]
+END
+
+VERNAC COMMAND EXTEND KillProofAt
+| [ "Kill" "Proof" "at"  natural(n) ] -> [ kill_node_verbose n ]
+END
+
+VERNAC COMMAND EXTEND KillSubProof
+  [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ]
+END
+
+VERNAC COMMAND EXTEND PcoqReset
+  [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ]
+END
+
+VERNAC COMMAND EXTEND PcoqResetInitial
+  [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ]
+END
+
+let start_proof_hook () =
+  History.start_proof (current_proof_name());
+  current_goal_index := 1
+
+let solve_hook n =
+  let name = current_proof_name () in
+  let old_n_count = History.border_length name in
+  let pf = proof_of_pftreestate (get_pftreestate ()) in
+  let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
+  begin
+    current_goal_index := n;
+    History.push_command name  n n_goals
+  end
+
+let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s)
+
+let interp_search_about_item = function
+  | SearchRef qid -> GlobSearchRef (Nametab.global qid)
+  | SearchString s -> GlobSearchString s
+
+let pcoq_search s l =
+  ctv_SEARCH_LIST:=[];
+  begin match s with
+  | SearchAbout sl -> 
+      raw_search_about (filter_by_module_from_list l) add_search
+	(List.map interp_search_about_item sl)
+  | SearchPattern c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      raw_pattern_search (filter_by_module_from_list l) add_search pat
+  | SearchRewrite c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      raw_search_rewrite (filter_by_module_from_list l) add_search pat;
+  | SearchHead locqid ->
+      filtered_search
+	(filter_by_module_from_list l) add_search (Nametab.global locqid)
+  end;
+  search_output_results()
+
+(* 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
+    match kind_of_term c with
+      | Prod(_, hyp, c2) -> 
+	  (try
+(*	     let _ = msgnl ((str "WHOLE ") ++ (Printer.prterm c)) in
+             let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *)
+             if Matching.is_matching pat hyp then
+	       (msgnl (str "ok"); true)
+	     else
+	       false
+           with UserError _ -> false) or
+	  hyp_pattern_filter pat name a c2
+      | _ -> false;;
+
+let hyp_search_pattern c l =
+  let _, pat = interp_constrpattern Evd.empty (Global.env()) c in
+    ctv_SEARCH_LIST := [];
+    gen_filtered_search
+      (fun s a c -> (filter_by_module_from_list l s a c &&
+		     (if hyp_pattern_filter pat s a c then
+		   	(msgnl (str "ok2"); true) else false)))
+      (fun s a c -> (msgnl (str "ok3"); add_search s a c));
+    output_results
+      (ctf_SearchResults !global_request_id)
+      (Some
+	 (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
+let pcoq_print_name ref =
+  let results = xlate_vernac_list (name_to_ast ref) in
+  output_results 
+    (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ())
+    (Some (P_cl results))
+
+let pcoq_print_check j =
+  let a,b = print_check j in output_results a b
+
+let pcoq_print_eval redfun env c j =
+  let strm, vtp = ct_print_eval c redfun env j in
+  output_results strm vtp;;
+
+open Vernacentries
+
+let pcoq_show_goal = function
+  | Some n -> show_nth n
+  | None ->
+      if !pcoq_started = Some true (* = debug *) then
+	msg (Pfedit.pr_open_subgoals ())
+      else errorlabstrm "show_goal"
+	(str "Show must be followed by an integer in Centaur mode");;
+
+let pcoq_hook = {
+  start_proof = start_proof_hook;
+  solve = solve_hook;
+  abort = abort_hook;
+  search = pcoq_search;
+  print_name = pcoq_print_name;
+  print_check = pcoq_print_check;
+  print_eval = pcoq_print_eval;
+  show_goal = pcoq_show_goal
+}
+
+
+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) ]
+END
+
+TACTIC EXTEND CtDebugTac2
+| [ "DebugTac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ]
+END
+
+
+let start_pcoq_mode debug = 
+  begin
+    pcoq_started := Some debug;
+(* <\cpa> 
+    start_dad();
+</cpa> *)
+    declare_in_coq();
+(* The following ones are added to enable rich comments in pcoq *)
+(* TODO ...
+    add_tactic "Image" (fun _ -> tclIDTAC);
+*)
+(* "Comments" moved to Vernacentries, other obsolete ?
+    List.iter (fun (a,b) -> vinterp_add a b) command_creations;
+*)
+(* Now hooks in Vernacentries
+    List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes;
+    if not debug then
+      List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes;
+*)
+    set_pcoq_hook pcoq_hook;
+  end;;
+
+
+let start_pcoq () =
+  start_pcoq_mode false;
+  set_acknowledge_command ctf_acknowledge_command;
+  set_start_marker "CENTAUR_RESERVED_TOKEN_start_command";
+  set_end_marker "CENTAUR_RESERVED_TOKEN_end_command";
+  raise Vernacexpr.ProtectedLoop;;
+
+let start_pcoq_debug () =
+  start_pcoq_mode true;
+  set_acknowledge_command ctf_acknowledge_command;
+  set_start_marker "--->";
+  set_end_marker "<---";
+  raise Vernacexpr.ProtectedLoop;;
+
+VERNAC COMMAND EXTEND HypSearchPattern
+  [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ]
+END
+
+VERNAC COMMAND EXTEND StartPcoq
+  [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ]
+END
+
+VERNAC COMMAND EXTEND Pcoq_inspect
+  [ "Pcoq_inspect" ] -> [ inspect 15 ]
+END
+
+VERNAC COMMAND EXTEND StartPcoqDebug
+| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ]
+END
diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml
new file mode 100644
index 00000000..67279bb8
--- /dev/null
+++ b/contrib/interface/ctast.ml
@@ -0,0 +1,76 @@
+(* 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
new file mode 100644
index 00000000..ec989296
--- /dev/null
+++ b/contrib/interface/dad.ml
@@ -0,0 +1,382 @@
+(* This file contains an ml version of drag-and-drop. *)
+
+(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *)
+
+open Names;;
+open Term;;
+open Rawterm;;
+open Util;;
+open Environ;;
+open Tactics;;
+open Tacticals;;
+open Pattern;;
+open Matching;;
+open Reduction;;
+open Constrextern;;
+open Constrintern;;
+open Vernacinterp;;
+open Libnames;;
+open Nametab
+
+open Proof_type;;
+open Proof_trees;;
+open Tacmach;;
+open Typing;;
+open Pp;;
+
+open Paths;;
+
+open Topconstr;;
+open Genarg;;
+open Tacexpr;;
+open Rawterm;;
+
+(* In a first approximation, drag-and-drop rules are like in CtCoq
+   1/ a pattern,
+   2,3/ Two paths: start and end positions,
+   4/ the degree: the number of steps the algorithm should go up from the
+      longest common prefix,
+   5/ the tail path: the suffix of the longest common prefix of length the
+      degree,
+   6/ the command pattern, where meta variables are represented by objects
+      of the form Node(_,"META"; [Num(_,i)])
+*)
+
+
+type dad_rule =
+    constr_expr * int list * int list * int * int list
+    * raw_atomic_tactic_expr;;
+
+(* This value will be used systematically when constructing objects *)
+
+let zz = Util.dummy_loc;;
+
+(* This function receives a length n, a path p, and a term and returns a
+   couple whose first component is the subterm designated by the prefix
+   of p of length n, and the second component is the rest of the path *)
+
+let rec get_subterm  (depth:int) (path: int list) (constr:constr) =
+  match depth, path, kind_of_term constr with
+    0, l, c -> (constr,l)
+  | n, 2::a::tl, App(func,arr) -> 
+      get_subterm (n - 2) tl arr.(a-1)
+  | _,l,_ -> failwith (int_list_to_string 
+                        "wrong path or wrong form of term"
+                        l);;
+
+(* This function maps a substitution on an abstract syntax tree.  The
+   first argument, an object of type env, is necessary to
+   transform constr terms into abstract syntax trees.  The second argument is
+   the substitution, a list of pairs linking an integer and a constr term. *)
+
+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;;
+
+let map_subst_tactic env subst = function
+  | TacExtend (loc,("Rewrite" as x),[b;cbl]) ->
+      let c,bl = out_gen rawwit_constr_with_bindings cbl in
+      assert (bl = NoBindings);
+      let c = (map_subst env subst c,NoBindings) in
+      TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c])
+  | _ -> failwith "map_subst_tactic: unsupported tactic"
+
+(* This function is really the one that is important. *)
+let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 =
+  match l with
+    [] -> failwith "nothing happens"
+  | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl ->
+     let length = List.length p in
+     try
+       if deg > length then
+         failwith "internal"
+       else
+         let term_to_match, p_r = 
+             try 
+                get_subterm (length - deg) p constr
+             with
+                Failure s -> failwith "internal" in
+         let _, constr_pat = 
+            interp_constrpattern Evd.empty (Global.env())
+               ((*ct_to_ast*) pat) in
+         let subst = matches constr_pat term_to_match in
+         if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then
+           TacAtom (zz, map_subst_tactic env subst cmd)
+         else
+	   failwith "internal"
+     with
+       Failure "internal" -> find_cmd tl env constr p p1 p2
+     | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;;
+
+
+let dad_rule_list = ref ([]: (string * dad_rule) list);;
+
+(*
+(* \\ This function is also used in pbp. *)
+let rec tactic_args_to_ints = function
+    [] -> []
+  | (Integer n)::l -> n::(tactic_args_to_ints l)
+  | _ -> failwith "expecting only numbers";;
+
+(* We assume that the two lists of integers for the tactic are simply
+   given in one list, separated by a dummy tactic. *)
+let rec part_tac_args l = function
+    [] -> l,[]
+  | (Tacexp a)::tl -> l, (tactic_args_to_ints tl)
+  | (Integer n)::tl -> part_tac_args (n::l) tl
+  | _ -> failwith "expecting only numbers and the word \"to\"";;
+
+
+(* The dad_tac tactic takes a display_function as argument.  This makes
+   it possible to use it in pcoq, but also in other contexts, just by
+   changing the output routine. *)
+let dad_tac display_function = function
+   l -> let p1, p2 = part_tac_args [] l in
+        (function g ->
+           let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in
+           (display_function 
+            (find_cmd (!dad_rule_list) (pf_env g)
+	       (pf_concl g) p_a p1prime p2prime));
+            tclIDTAC g);;
+*)
+let dad_tac display_function p1 p2 g =
+  let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in
+  (display_function 
+    (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime));
+  tclIDTAC g;;
+
+(* Now we enter dad rule list management. *)
+
+let add_dad_rule name patt p1 p2 depth pr command =
+  dad_rule_list := (name, 
+		    (patt, p1, p2, depth, pr, command))::!dad_rule_list;;
+
+let rec remove_if_exists name = function
+    [] -> false, []
+  | ((a,b) as rule1)::tl -> if a = name then 
+               let result1, l = (remove_if_exists name tl) in
+               true, l
+             else
+               let result1, l = remove_if_exists name tl in
+               result1, (rule1::l);;
+
+let remove_dad_rule name =
+  let result1, result2 = remove_if_exists name !dad_rule_list in
+  if result1 then
+    failwith("No such name among the drag and drop rules " ^ name)
+  else
+     dad_rule_list := result2;;
+
+let dad_rule_names () =
+    List.map (function (s,_) -> s) !dad_rule_list;;
+
+(* this function is inspired from matches_core in pattern.ml *)
+let constrain ((n : patvar),(pat : constr_pattern)) sigma =
+  if List.mem_assoc n sigma then
+    if pat = (List.assoc n sigma) then sigma
+    else failwith "internal"
+  else 
+    (n,pat)::sigma
+    
+(* This function is inspired from matches_core in pattern.ml *)
+let more_general_pat pat1 pat2 = 
+  let rec match_rec sigma p1 p2 =
+    match p1, p2 with
+      | PMeta (Some n), m -> constrain (n,m) sigma
+
+      | PMeta None, m -> sigma
+
+      | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma
+
+      | PVar v1, PVar v2 when v1 = v2 -> sigma
+
+      | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma
+
+      | PRel n1, PRel n2 when n1 = n2 -> sigma
+
+      | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma
+
+      | PSort (RType _), PSort (RType _) -> sigma
+
+      | PApp (c1,arg1), PApp (c2,arg2) ->
+        (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2
+         with Invalid_argument _ -> failwith "internal")
+      | _ -> failwith "unexpected case in more_general_pat" in 
+  try let _ = match_rec [] pat1 pat2 in true
+  with Failure "internal" -> false;;
+
+let more_general r1 r2 =
+  match r1,r2 with
+    (_,(patt1,p11,p12,_,_,_)),
+    (_,(patt2,p21,p22,_,_,_)) ->
+	(more_general_pat patt1 patt2) &
+      (is_prefix p11 p21) & (is_prefix p12 p22);;
+
+let not_less_general r1 r2 = 
+  not (match r1,r2 with
+    (_,(patt1,p11,p12,_,_,_)),
+    (_,(patt2,p21,p22,_,_,_)) ->
+	(more_general_pat patt1 patt2) &
+      (is_prefix p21 p11) & (is_prefix p22 p12));;
+
+let rec add_in_list_sorting rule1 = function
+    [] -> [rule1]
+  | (b::tl) as this_list ->
+      if more_general rule1 b  then
+	b::(add_in_list_sorting rule1 tl)
+      else if not_less_general rule1 b then
+	let tl2 = add_in_list_sorting_aux rule1 tl in
+	(match tl2 with
+	  [] -> rule1::this_list
+	| _ -> b::tl2)
+      else
+	rule1::this_list
+and add_in_list_sorting_aux rule1 = function
+    [] -> []
+  | b::tl -> 
+      if more_general rule1 b then
+      	b::(add_in_list_sorting rule1 tl)
+      else
+	let tl2 = add_in_list_sorting_aux rule1 tl in
+	(match tl2 with
+	  [] -> []
+	| _ -> rule1::tl2);;
+
+let rec sort_list = function
+    [] -> [] 
+  | a::l -> add_in_list_sorting a (sort_list l);;
+
+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
+  TacExtend (zz,"Rewrite",[b;cb])
+
+open Vernacexpr
+
+let dad_status = ref false;;
+
+let start_dad () = dad_status := true;;
+
+let add_dad_rule_fn name pat p1 p2 tac =
+  let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in
+  add_dad_rule name pat p1 p2 (List.length pr) pr tac;;
+
+(* To be parsed by camlp4
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+VERNAC COMMAND EXTEND AddDadRule
+  [ "Add" "Dad" "Rule" string(name) constr(pat)
+    "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] ->
+  [ add_dad_rule_fn name pat p1 p2 tac ]
+END
+
+*)
+
+let mk_id s = mkIdentC (id_of_string s);;
+let mkMetaC = mk_dad_meta;;
+
+add_dad_rule "distributivity-inv"
+(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
+[2; 2]
+[2; 1]
+1
+[2]
+(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "distributivity1-r"
+(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
+[2; 2; 2; 2]
+[]
+0
+[]
+(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "distributivity1-l"
+(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])]))
+[2; 1; 2; 2]
+[]
+0
+[]
+(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "associativity"
+(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)]))
+[2; 1]
+[]
+0
+[]
+(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "minus-identity-lr"
+(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
+[2; 1]
+[2; 2]
+1
+[2]
+(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
+
+add_dad_rule "minus-identity-rl"
+(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)]))
+[2; 2]
+[2; 1]
+1
+[2]
+(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ])));
+
+add_dad_rule "plus-sym-rl"
+(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
+[2; 2]
+[2; 1]
+1
+[2]
+(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "plus-sym-lr"
+(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)]))
+[2; 1]
+[2; 2]
+1
+[2]
+(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "absorb-0-r-rl"
+(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
+[2; 2]
+[1]
+0
+[]
+(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
+
+add_dad_rule "absorb-0-r-lr"
+(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")]))
+[1]
+[2; 2]
+0
+[]
+(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ])));
+
+add_dad_rule "plus-permute-lr"
+(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
+[2; 1]
+[2; 2; 2; 1]
+1
+[2]
+(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));
+
+add_dad_rule "plus-permute-rl"
+(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])]))
+[2; 2; 2; 1]
+[2; 1]
+1
+[2]
+(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));;
+
+vinterp_add "StartDad"
+   (function
+     | [] ->
+       (function () -> start_dad())
+     | _ -> errorlabstrm "StartDad" (mt()));;
diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli
new file mode 100644
index 00000000..f556c192
--- /dev/null
+++ b/contrib/interface/dad.mli
@@ -0,0 +1,10 @@
+open Proof_type;;
+open Tacmach;;
+open Topconstr;;
+
+val dad_rule_names : unit -> string list;;
+val start_dad : unit -> unit;;
+val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma ->
+                  goal list sigma * validation;;
+val add_dad_rule : string -> constr_expr -> (int list) -> (int list) ->
+                   int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;;
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
new file mode 100644
index 00000000..bf596b28
--- /dev/null
+++ b/contrib/interface/debug_tac.ml4
@@ -0,0 +1,570 @@
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Ast;;
+open Coqast;;
+open Tacmach;;
+open Tacticals;;
+open Proof_trees;;
+open Pp;;
+open Pptactic;;
+open Util;;
+open Proof_type;;
+open Tacexpr;;
+open Genarg;;
+
+(* Compacting and uncompacting proof commands *)
+
+type report_tree =
+    Report_node of bool *int * report_tree list
+  | Mismatch of int * int
+  | Tree_fail of report_tree
+  | Failed of int;;
+
+type report_card =
+    Ngoals of int
+  | Goals_mismatch of int
+  | Recursive_fail of report_tree
+  | Fail;;
+
+type card_holder = report_card ref;;
+type report_holder = report_tree list ref;;
+
+(* This tactical receives an integer and a tactic and checks that the
+   tactic produces that number of goals.  It never fails but signals failure
+   by updating the boolean reference given as third argument to false.
+   It is especially suited for use in checked_thens below. *)
+
+let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic =
+  fun card_holder count flag t g ->
+    try
+      let (gls, v) as result = t g in
+      let len = List.length (sig_it gls) in
+      card_holder :=
+      (if len = count then
+	  (flag := true;
+	  Ngoals count)
+       else
+          (flag := false;
+          Goals_mismatch len));
+      result
+    with
+      e -> card_holder := Fail;
+           flag := false;
+           tclIDTAC g;;
+
+let no_failure = function
+    [Report_node(true,_,_)] -> true
+  | _ -> false;;
+
+let check_subgoals_count2 
+    : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic =
+  fun card_holder count flag t g ->
+    let new_report_holder = ref ([] : report_tree list) in
+    let (gls, v) as result = t new_report_holder g in
+    let succeeded = no_failure !new_report_holder in
+    let len = List.length (sig_it gls) in
+    card_holder :=
+      (if (len = count) & succeeded then
+	(flag := true;
+	 Ngoals count)
+      else
+	(flag := false;
+	 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;;
+
+let rec collect_status = function
+    Report_node(true,_,_)::tl -> collect_status tl
+  | [] -> true
+  | _ -> false;;
+
+(* This tactical receives a tactic and executes it, reporting information
+   about success in the report holder and a boolean reference. *)
+
+let count_subgoals : card_holder -> bool ref -> tactic -> tactic =
+  fun card_holder flag t g ->
+    try
+      let (gls, _) as result = t g in
+      card_holder := (Ngoals(List.length (sig_it gls)));
+      flag := true;
+      result
+    with
+      e -> card_holder := Fail;
+           flag := false;
+           tclIDTAC g;;
+   
+let count_subgoals2
+    : card_holder -> bool ref -> (report_holder -> tactic) -> tactic =
+  fun card_holder flag t g ->
+    let new_report_holder = ref([] : report_tree list) in
+    let (gls, v) as result = t new_report_holder g in
+    let succeeded = no_failure !new_report_holder in
+    if succeeded then
+      (flag := true;
+       card_holder := Ngoals (List.length (sig_it gls)))
+    else
+      (flag := false;
+       card_holder := Recursive_fail(List.hd !new_report_holder));
+    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) ->
+      (fun report_holder -> checked_then report_holder a b)
+  | t ->
+      (fun report_holder g ->
+	try
+	  let (gls, _) as result = Tacinterp.eval_tactic t 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))
+
+
+(* This tactical receives a tactic and a list of tactics as argument.
+   It applies the first tactic and then maps the list of tactics to
+   various produced sub-goals.  This tactic will never fail, but reports
+   are added in the report_holder in the following way:
+   - In case of partial success, a new report_tree is added to the report_holder
+   - In case of failure of the first tactic, with no more indications
+     then Failed 0 is added to the report_holder,
+   - In case of partial failure of the first tactic then (Failed n) is added to
+     the report holder.
+   - In case of success of the first tactic, but count mismatch, then
+     Mismatch n is added to the report holder. *)
+
+and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = 
+  (fun report_holder t1 l g ->
+    let flag = ref true in
+    let traceable_t1 = traceable t1 in
+    let card_holder = ref Fail in
+    let new_holder = ref ([]:report_tree list) in
+    let tac_t1 = 
+      if traceable_t1 then
+	(check_subgoals_count2 card_holder (List.length l)
+           flag (local_interp t1))
+      else
+	(check_subgoals_count card_holder (List.length l)
+           flag (Tacinterp.eval_tactic t1)) in
+    let (gls, _) as result = 
+      tclTHEN_i tac_t1
+	(fun i ->
+	  if !flag then
+	    (fun g -> 
+              let tac_i = (List.nth l i) in
+	      if traceable tac_i then
+                 local_interp tac_i new_holder g
+              else
+		 try
+		   let (gls,_) as result = Tacinterp.eval_tactic tac_i g in
+		   let len = List.length (sig_it gls) in
+				   new_holder :=
+		     (Report_node(true, len, []))::!new_holder;
+		   result
+		 with
+			       e -> (new_holder := (Failed 1)::!new_holder;
+			 tclIDTAC g))
+	  else
+	    tclIDTAC) g in
+      let new_goal_list = sig_it gls in
+      (if !flag then
+	report_holder := 
+	  (Report_node(collect_status !new_holder,
+		    (List.length new_goal_list),
+		    List.rev !new_holder))::!report_holder
+      else
+	report_holder :=
+	  (match !card_holder with
+	    Goals_mismatch(n) -> Mismatch(n, List.length l)
+	  | Recursive_fail tr -> Tree_fail tr
+	  | Fail -> Failed 1
+	  | _ -> errorlabstrm "check_thens"
+                  (str "this case should not happen in check_thens"))::
+	  !report_holder);
+      result)
+
+(* This tactical receives two tactics as argument, it executes the
+   first tactic and applies the second one to all the produced goals,
+   reporting information about the success of all tactics in the report
+   holder. It never fails. *)
+
+and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic =
+  (fun report_holder t1 t2 g ->
+    let flag = ref true in
+    let card_holder = ref Fail in
+    let tac_t1 =
+      if traceable t1 then
+	(count_subgoals2 card_holder flag (local_interp t1))
+      else
+	(count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in
+    let new_tree_holder = ref ([] : report_tree list) in
+    let (gls, _) as result =
+      tclTHEN tac_t1
+	(fun (g:goal sigma) -> 
+	  if !flag then
+	    if traceable t2 then
+	      local_interp t2 new_tree_holder g
+	    else
+	      try
+		let (gls, _) as result = Tacinterp.eval_tactic t2 g in
+	      	new_tree_holder :=
+		  (Report_node(true, List.length (sig_it gls),[]))::
+		  !new_tree_holder;
+		result
+	      with
+		e ->
+		  (new_tree_holder := ((Failed 1)::!new_tree_holder);
+		   tclIDTAC g)
+	  else
+	    tclIDTAC g) g in
+    (if !flag then
+      report_holder :=
+	(Report_node(collect_status !new_tree_holder,
+		     List.length (sig_it gls),
+		     List.rev !new_tree_holder))::!report_holder
+    else
+      report_holder :=
+	(match !card_holder with
+	  Recursive_fail tr -> Tree_fail tr
+	| Fail -> Failed 1
+	| _ -> error "this case should not happen in check_then")::!report_holder);
+    result);;
+
+(* This tactic applies the given tactic only to those subgoals designated
+   by the list of integers given as extra arguments.
+ *)
+
+let on_then = function [t1;t2;l] ->
+  let t1 = out_gen wit_tactic t1 in
+  let t2 = out_gen wit_tactic t2 in
+  let l = out_gen (wit_list0 wit_int) l in
+  tclTHEN_i (Tacinterp.eval_tactic t1)
+    (fun i ->
+      if List.mem (i + 1) l then
+      	(Tacinterp.eval_tactic t2)
+      else
+	tclIDTAC)
+  | _ -> 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 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) ->
+      (function 
+	  Report_node(true, n, l) -> tac
+      	| Report_node(false, n, rl) ->
+	    TacThens (a,List.map2 reconstruct_success_tac l rl)
+      	| Failed n -> TacId ""
+      	| Tree_fail r -> reconstruct_success_tac a r
+      	| Mismatch (n,p) -> a)
+  | TacThen (a,b) ->
+      (function
+	  Report_node(true, n, l) -> tac
+	| 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 (wit_list0 globwit_int) selected_indices]))
+	| 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 ""
+	| _ ->
+	    errorlabstrm
+	      "this error case should not happen on an unknown tactic"
+              (str "error in reconstruction with " ++ fnl () ++
+	       (pr_glob_tactic tac)));;
+	  
+
+let rec path_to_first_error = function
+| Report_node(true, _, l) ->
+  let rec find_first_error n = function
+  | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl
+  | it::tl -> n, it
+  | [] -> error "no error detected" in
+  let p, t = find_first_error 1 l in
+    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 -> 
+      	let report = ref ([] : report_tree list) in
+      	let result = local_interp ast report g in
+      	let clean_ast = (* expand_tactic *) ast in
+      	let report_tree =
+          try List.hd !report with
+	    Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in
+      	let success_tac = 
+	  reconstruct_success_tac clean_ast report_tree in
+        let compact_success_tac = (* flatten_then *) success_tac in
+      	msgnl (fnl () ++
+	       str "=========    Successful tactic    =============" ++
+               fnl () ++
+	       pr_glob_tactic compact_success_tac ++ fnl () ++
+	       str "========= End of successful tactic ============");
+      	result)
+  | _ -> error "wrong arguments for debug_tac";;
+
+(* TODO ... used ?
+add_tactic "DebugTac" debug_tac;;
+*)
+
+(*
+hide_tactic "OnThen" on_then;;
+*)
+Refiner.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 ->
+      fst::(clean_path (if fst = 1 then a else b) tl)
+  | TacThens (a,l), 1::tl ->
+      1::(clean_path a tl)
+  | TacThens (a,tacs), 2::fst::tl ->
+      2::fst::(clean_path (List.nth tacs (fst - 1)) tl)
+  | _, [] -> []
+  | _, _ -> failwith "this case should not happen in clean_path";;
+
+let rec report_error
+    : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> 
+      int list -> tactic =
+  fun tac the_goal the_ast returned_path path -> 
+    match tac with
+      TacThens (a,l) ->
+      let the_card_holder = ref Fail in
+      let the_flag = ref false in
+      let the_exn = ref (Failure "") in
+      tclTHENS
+	(fun g ->
+	  let result =
+	    check_subgoals_count 
+	      the_card_holder
+	      (List.length l) 
+	      the_flag
+	      (fun g2 -> 
+		try 
+		  (report_error a the_goal the_ast returned_path (1::path) g2)
+	  	with
+		  e -> (the_exn := e; raise e))
+	      g in
+	  if !the_flag then
+	    result
+	  else
+	    (match !the_card_holder with
+			Fail -> 
+			  the_ast := TacThens (!the_ast, l);
+			  raise !the_exn
+	    | Goals_mismatch p -> 
+		the_ast := tac;
+		returned_path := path;
+		error ("Wrong number of tactics: expected " ^
+		       (string_of_int (List.length l)) ^ " received " ^
+		       (string_of_int p))
+	    | _ -> error "this should not happen"))
+        (let rec fold_num n = function
+	    [] -> []
+	  | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path))::
+	      (fold_num (n + 1) tl) in
+	fold_num 1 l)
+    | TacThen (a,b) ->
+	let the_count = ref 1 in
+	tclTHEN
+	  (fun g ->
+	    try
+	      report_error a the_goal the_ast returned_path (1::path) g
+	    with
+	      e ->
+		(the_ast := TacThen (!the_ast, b);
+		 raise e))
+	  (fun g ->
+	    try
+	      let result = 
+		report_error b the_goal the_ast returned_path (2::path) g in
+	      the_count := !the_count + 1;
+	      result
+	    with
+	      e ->
+		if !the_count > 1 then
+		  msgnl
+		    (str "in branch no " ++ int !the_count ++
+		     str " after tactic " ++ pr_glob_tactic a);
+		raise e)
+    | tac ->
+	(fun g ->
+	  try
+	   Tacinterp.eval_tactic tac g
+	  with
+	    e ->
+	      (the_ast := tac;
+	       the_goal := Some g;
+	       returned_path := path;
+	       raise e));;
+
+let strip_some = function
+    Some n -> n
+  | None -> failwith "No optional value";;
+
+let descr_first_error tac =
+      (fun g ->
+	let the_goal = ref (None : goal sigma option) in
+	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
+	  msgnl (str "no Error here");
+	  result
+	with
+	  e ->
+	    (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 () ++
+		    pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ());
+	     tclIDTAC g))
+
+(* TODO ... used ??
+add_tactic "DebugTac2" descr_first_error;;
+*)
+
+(*
+TACTIC EXTEND DebugTac2
+  [ ??? ] -> [ descr_first_error tac ]
+END
+*)
diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli
new file mode 100644
index 00000000..ded714b6
--- /dev/null
+++ b/contrib/interface/debug_tac.mli
@@ -0,0 +1,6 @@
+
+val report_error : Tacexpr.glob_tactic_expr ->
+    Proof_type.goal Proof_type.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/history.ml b/contrib/interface/history.ml
new file mode 100644
index 00000000..f73c2084
--- /dev/null
+++ b/contrib/interface/history.ml
@@ -0,0 +1,373 @@
+open Paths;;
+
+type tree = {mutable index : int;
+             parent : tree option;
+             path_to_root : int list;
+             mutable is_open : bool;
+             mutable sub_proofs : tree list};;
+
+type prf_info = {
+    mutable prf_length : int;
+    mutable ranks_and_goals : (int * int * tree) list;
+    mutable border : tree list;
+    prf_struct : tree};;
+
+let theorem_proofs = ((Hashtbl.create 17): 
+			(string, prf_info) Hashtbl.t);;
+
+
+let rec mk_trees_for_goals path tree rank k n =
+  if k = (n + 1) then
+    []
+  else
+    { index = rank;
+      parent = tree;
+      path_to_root = k::path;
+      is_open = true;
+      sub_proofs = [] } ::(mk_trees_for_goals  path tree rank (k+1) n);;
+
+
+let push_command s rank ngoals =
+  let ({prf_length = this_length;
+ 	ranks_and_goals = these_ranks;
+	border = this_border} as proof_info) =
+         Hashtbl.find theorem_proofs s in
+  let rec push_command_aux n = function
+      [] -> failwith "the given rank was too large"
+    | a::l ->
+	if n = 1 then
+	 let {path_to_root = p} = a in
+	 let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in
+	 new_trees,(new_trees@l),a
+	else
+	  let new_trees, res, this_tree = push_command_aux (n-1) l in
+	  new_trees,(a::res),this_tree in
+  let new_trees, new_border, this_tree =
+      push_command_aux rank this_border in
+  let new_length = this_length + 1 in
+  begin
+    proof_info.border <- new_border;
+    proof_info.prf_length <- new_length;
+    proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks;
+    this_tree.index <- new_length;
+    this_tree.is_open <- false;
+    this_tree.sub_proofs <- new_trees
+  end;;
+
+let get_tree_for_rank thm_name rank = 
+  let {ranks_and_goals=l;prf_length=n} = 
+         Hashtbl.find theorem_proofs thm_name in
+  let rec get_tree_aux = function
+      [] ->
+ 	failwith 
+         "inconsistent values for thm_name and rank in get_tree_for_rank"
+    | (_,_,({index=i} as tree))::tl ->
+	if i = rank then
+	  tree
+	else
+	  get_tree_aux tl in
+  get_tree_aux l;;
+
+let get_path_for_rank thm_name rank =
+  let {path_to_root=l}=get_tree_for_rank thm_name rank in
+  l;;
+
+let rec list_descendants_aux l tree =
+  let {index = i; is_open = open_status; sub_proofs = tl} = tree in
+  let res = (List.fold_left list_descendants_aux  l tl) in
+  if open_status then i::res else res;;
+
+let list_descendants thm_name rank =
+  list_descendants_aux [] (get_tree_for_rank thm_name rank);;
+
+let parent_from_rank thm_name rank =
+  let {parent=mommy} = get_tree_for_rank thm_name rank in
+  match mommy with
+   Some x -> Some x.index
+  | None -> None;;
+
+let first_child_command thm_name rank =
+  let {sub_proofs = l} = get_tree_for_rank thm_name rank in
+  let rec first_child_rec = function 
+      [] -> None
+    | {index=i;is_open=b}::l -> 
+	if b then
+	  (first_child_rec l)
+	else
+ 	  Some i in
+  first_child_rec l;;
+
+type index_or_rank = Is_index of int | Is_rank of int;;
+
+let first_child_command_or_goal thm_name rank =
+  let proof_info = Hashtbl.find theorem_proofs thm_name in
+  let {sub_proofs=l}=get_tree_for_rank thm_name rank in
+  match l with
+    [] -> None
+  | ({index=i;is_open=b} as t)::_ -> 
+      if b then
+	let rec get_rank n = function
+	    [] -> failwith "A goal is lost in first_child_command_or_goal"
+	  | a::l ->
+	      if a==t then
+		n
+	      else
+		get_rank (n + 1) l in
+	Some(Is_rank(get_rank 1 proof_info.border))
+      else
+	Some(Is_index i);;
+
+let next_sibling thm_name rank =
+  let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in
+  match mommy with
+    None -> None
+  |  Some real_mommy ->
+  let {sub_proofs=l}=real_mommy in
+  let rec next_sibling_aux b = function
+      (opt_first, []) -> 
+	if b then
+	  opt_first
+	else
+	  failwith "inconsistency detected in next_sibling"
+    | (opt_first, {is_open=true}::l) -> 
+	next_sibling_aux b (opt_first, l)
+    | (Some(first),({index=i; is_open=false} as t')::l) ->
+	if b then
+	  Some i
+	else
+	  next_sibling_aux (t == t') (Some first,l)
+    | None,({index=i;is_open=false} as t')::l ->
+  	next_sibling_aux (t == t') ((Some i), l)
+  in
+  Some (next_sibling_aux false (None, l));;
+
+
+let prefix l1 l2 =
+  let l1rev = List.rev l1 in
+  let l2rev = List.rev l2 in
+  is_prefix l1rev l2rev;;
+
+let rec remove_all_prefixes p = function
+    [] -> []
+  | a::l -> 
+      if is_prefix p a then
+ 	(remove_all_prefixes p l)
+      else
+	a::(remove_all_prefixes p l);;
+
+let recompute_border tree =
+  let rec recompute_border_aux tree acc =
+    let {is_open=b;sub_proofs=l}=tree in
+    if b then
+      tree::acc
+    else
+      List.fold_right recompute_border_aux l acc in
+  recompute_border_aux tree [];;
+ 
+   
+let historical_undo thm_name rank =
+  let ({ranks_and_goals=l} as proof_info)=
+       Hashtbl.find theorem_proofs thm_name in
+  let rec undo_aux acc = function
+      [] ->  failwith "bad rank provided for undoing in historical_undo"
+    | (r, n, ({index=i} as tree))::tl  ->
+	let this_path_reversed = List.rev tree.path_to_root in
+	let res = remove_all_prefixes this_path_reversed acc in
+	if i = rank then
+	  begin
+	    proof_info.prf_length <- i-1;
+	    proof_info.ranks_and_goals <- tl;
+	    tree.is_open <- true;
+	    tree.sub_proofs <- [];
+	    proof_info.border <- recompute_border proof_info.prf_struct;
+            this_path_reversed::res 
+	  end
+	else
+	  begin
+	    tree.is_open <- true;
+	    tree.sub_proofs <- [];
+	    undo_aux (this_path_reversed::res) tl
+	  end
+  in
+  List.map List.rev (undo_aux [] l);;
+
+(* The following function takes a list of trees and compute the
+   number of elements whose path is lexically smaller or a suffixe of
+   the path given as a first argument.  This works under the precondition that
+   the list is lexicographically order. *)
+
+let rec logical_undo_on_border the_tree rev_path = function
+    [] -> (0,[the_tree])
+  | ({path_to_root=p}as tree)::tl ->
+    let p_rev = List.rev p in
+    if is_prefix rev_path p_rev then
+      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
+          (k+1,res)
+    else if lex_smaller p_rev rev_path then
+      let (k,res) = (logical_undo_on_border the_tree rev_path tl) in
+          (k,tree::res)
+    else
+          (0, the_tree::tree::tl);;
+   
+
+let logical_undo thm_name rank =
+  let ({ranks_and_goals=l; border=last_border} as proof_info)=
+           Hashtbl.find theorem_proofs thm_name in
+  let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in
+  let rev_ref_path = List.rev ref_path in
+  let rec logical_aux lex_smaller_offset family_width = function
+      [] -> failwith "this case should never happen in logical_undo"
+    | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree))::
+        tl ->
+        let this_path_rev = List.rev this_path in
+        let new_rank, new_offset, new_width, kept =
+	  if is_prefix rev_ref_path this_path_rev then
+	    (r + lex_smaller_offset), lex_smaller_offset,
+              (family_width + 1 - n), false 
+	  else if lex_smaller this_path_rev rev_ref_path then
+            r, (lex_smaller_offset -  1 + n), family_width, true
+          else
+            (r + 1 - family_width+ lex_smaller_offset),
+	    lex_smaller_offset, family_width, true in
+        if i=rank then
+	  [i,new_rank],[], tl, rank
+        else
+          let ranks_undone, ranks_kept, ranks_and_goals, current_rank =
+	    (logical_aux new_offset new_width tl) in
+          begin
+	    if kept then
+	      begin
+	      	tree.index <- current_rank;
+	    	ranks_undone, ((i,new_rank)::ranks_kept),
+	    	((new_rank, n, tree)::ranks_and_goals), 
+                (current_rank + 1)
+	      end
+	    else
+	      ((i,new_rank)::ranks_undone), ranks_kept,
+	      ranks_and_goals, current_rank
+	  end in
+  let number_suffix, new_border = 
+     logical_undo_on_border ref_tree rev_ref_path last_border in
+  let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals,
+    new_length_plus_one = logical_aux 0 number_suffix l in
+  let the_goal_index =
+    let rec compute_goal_index n = function
+	[] -> failwith "this case should never happen in logical undo (2)"
+      |	{path_to_root=path}::tl ->
+	  if List.rev path = (rev_ref_path) then
+	    n
+	  else
+	    compute_goal_index (n+1) tl in
+    compute_goal_index 1 new_border in
+  begin
+    ref_tree.is_open <- true;
+    ref_tree.sub_proofs <- [];
+    proof_info.border <- new_border;
+    proof_info.ranks_and_goals <- new_ranks_and_goals;
+    proof_info.prf_length <- new_length_plus_one - 1;
+    changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, 
+    the_goal_index
+  end;;
+	
+let start_proof thm_name =
+   let the_tree = 
+      {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in
+   Hashtbl.add theorem_proofs thm_name
+     {prf_length=0;
+      ranks_and_goals=[];
+      border=[the_tree];
+      prf_struct=the_tree};;
+      
+let dump_sequence chan s =
+    match (Hashtbl.find theorem_proofs s) with
+    {ranks_and_goals=l}->
+      let rec dump_rec = function
+	  [] -> ()
+  	| (r,n,_)::tl ->
+	    dump_rec tl;
+	    output_string chan (string_of_int r);
+	    output_string chan ",";
+	    output_string chan (string_of_int n);
+	    output_string chan "\n" in
+      begin
+      	dump_rec l;
+	output_string chan "end\n"
+      end;;
+
+      
+let proof_info_as_string s =
+  let res = ref "" in
+  match (Hashtbl.find theorem_proofs s) with
+  {prf_struct=tree} ->
+  let open_goal_counter = ref 0 in
+  let rec dump_rec = function
+    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
+    begin
+      (match the_parent with
+         None ->
+	   if op then
+	     res := !res ^  "\"open goal\"\n"
+       | Some {index=j} -> 
+           begin
+             res := !res ^  (string_of_int j);
+             res := !res ^  " -> ";
+	     if op then
+	       begin
+		 res := !res ^  "\"open goal ";
+		 open_goal_counter := !open_goal_counter + 1;
+		 res := !res ^  (string_of_int !open_goal_counter);
+		 res := !res ^  "\"\n";
+	       end
+	     else
+	       begin
+		 res := !res ^  (string_of_int i);
+		 res := !res ^  "\n"
+	       end
+           end);
+      	List.iter dump_rec trees
+     end in
+  dump_rec tree;
+  !res;;
+
+
+let dump_proof_info chan s = 
+  match (Hashtbl.find theorem_proofs s) with
+  {prf_struct=tree} ->
+  let open_goal_counter = ref 0 in
+  let rec dump_rec = function
+    {index=i;sub_proofs=trees;parent=the_parent;is_open=op} ->
+    begin
+      (match the_parent with
+         None ->
+	   if op then
+	     output_string chan "\"open goal\"\n"
+       | Some {index=j} -> 
+           begin
+             output_string chan (string_of_int j);
+             output_string chan " -> ";
+	     if op then
+	       begin
+		 output_string chan "\"open goal ";
+		 open_goal_counter := !open_goal_counter + 1;
+		 output_string chan (string_of_int !open_goal_counter);
+		 output_string chan "\"\n";
+	       end
+	     else
+	       begin
+		 output_string chan (string_of_int i);
+		 output_string chan "\n"
+	       end
+           end);
+      	List.iter dump_rec trees
+     end in
+  dump_rec tree;;
+
+let get_nth_open_path s n =
+  match Hashtbl.find theorem_proofs s with
+    {border=l} ->
+    let {path_to_root=p}=List.nth l (n - 1) in
+    p;;
+
+let border_length s =
+  match Hashtbl.find theorem_proofs s with
+    {border=l} -> List.length l;;
diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli
new file mode 100644
index 00000000..053883f0
--- /dev/null
+++ b/contrib/interface/history.mli
@@ -0,0 +1,12 @@
+type prf_info;;
+
+val start_proof : string -> unit;;
+val historical_undo : string -> int -> int list list
+val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int
+val dump_sequence : out_channel -> string -> unit
+val proof_info_as_string : string -> string
+val dump_proof_info : out_channel -> string -> unit
+val push_command : string -> int -> int -> unit
+val get_path_for_rank : string -> int -> int list
+val get_nth_open_path : string -> int -> int list
+val border_length : string -> int
diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4
new file mode 100755
index 00000000..b5669351
--- /dev/null
+++ b/contrib/interface/line_parser.ml4
@@ -0,0 +1,241 @@
+(* line-oriented Syntactic analyser for a Coq parser *)
+(* This parser expects a very small number of commands, each given on a complete
+line.  Some of these commands are then followed by a text fragment terminated
+by a precise keyword, which is also expected to appear alone on a line. *)
+
+(* The main parsing loop procedure is "parser_loop", given at the end of this
+file.  It read lines one by one and checks whether they can be parsed using
+a very simple parser.  This very simple parser uses a lexer, which is also given
+in this file.  
+
+The lexical analyser:
+ There are only 5 sorts of tokens *)
+type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string |
+      Tlbracket | Trbracket;;
+
+(* When recognizing identifiers or strings, the lexical analyser accumulates
+   the characters in a buffer, using the command add_in_buff.  To recuperate
+   the characters, one can use get_buff (this code was inspired by the
+   code in src/meta/lexer.ml of Coq revision 6.1) *)
+let add_in_buff,get_buff =
+  let buff = ref (String.create 80) in
+    (fun i x -> 
+       let len = String.length !buff in
+        if i >= len then (buff := !buff ^ (String.create len);());
+         String.set !buff i x;
+         succ i),
+     (fun len -> String.sub !buff 0 len);;
+
+(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*.  When arriving here the first
+   character has already been recognized. *)
+let rec ident len = parser
+  [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] ->
+    ident (add_in_buff len c) s
+| [< >] -> let str = get_buff len in Tid(str);;
+
+(* While recognizing integers, one constructs directly the integer value.
+   The ascii code of '0' is important for this. *)
+let code0 = Char.code '0';;
+
+let get_digit c =  Char.code c - code0;;
+
+(* Integers are [0-9]*
+   The variable intval is the integer value of the text that has already
+   been recognized.  As for identifiers, the first character has already been
+   recognized. *)
+
+let rec parse_int intval = parser
+  [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i
+| [< >] -> Tint intval;;
+      
+(* The string lexer is borrowed from the string parser of Coq V6.1 
+   This may be a problem if convention have changed in Coq,
+   However this parser is only used to recognize file names which should
+   not contain too many special characters *)
+
+let rec spec_char = parser
+  [< ''n' >] -> '\n' 
+| [< ''t' >] -> '\t'
+| [< ''b' >] -> '\008' 
+| [< ''r' >] -> '\013'
+| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] ->
+    Char.chr v
+| [< 'x >] -> x
+
+and spec1 v = parser
+  [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s
+| [< >] -> v
+;;
+
+(* This is the actual string lexical analyser.  Strings are
+   QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used
+   to represents double quotation characters, that cannot be used
+   freely, even inside comments. *)
+
+let rec string len = parser
+  [< ''"' >] -> len
+| [<''\\' ;
+      len = (parser [< ''\n' >] -> len
+             | [< c=spec_char >] -> add_in_buff len c);
+      s >] -> string len s
+| [< 'x; s >] -> string (add_in_buff len x) s;;
+
+(* The lexical analyser repeats the recognized given by next_token:
+   spaces and tabulations are ignored, identifiers, integers,
+   strings, opening and closing square brackets.  Lexical errors are
+   ignored ! *)
+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
+| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len)
+| [< ''[' >] -> Tlbracket
+| [< '']' >] -> Trbracket
+| [< '_ ; x = next_token >] -> x;;
+
+(* A very simple lexical analyser to recognize a integer value behind 
+   blank characters *)
+
+let rec next_int = parser count
+  [< '' ' | '\t'; v = next_int >] -> v
+| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] ->
+     (match i with
+        Tint n -> n
+     |  _ -> failwith "unexpected branch in next_int");;
+
+(* This is the actual lexical analyser, implemented as a function on a stream.
+   It will be used with the Stream.from primitive to construct a function
+   of type char Stream.t -> simple_token option Stream.t *)
+let token_stream cs _ =
+ try  let tok = next_token cs in
+      Some tok
+ with Stream.Failure -> None;;
+
+(* Two of the actions of the parser request that one reads the rest of
+   the input up to a specific string stop_string.  This is done
+   with a function that transform the input_channel into a pair of
+   char Stream.t, reading from the input_channel all the lines to
+   the stop_string first. *)
+
+
+let rec gather_strings stop_string input_channel =
+   let buff = input_line input_channel in
+   if buff = stop_string then
+     []
+   else
+     (buff::(gather_strings stop_string input_channel));;
+
+
+(* the result of this function is supposed to be used in a Stream.from
+   construction. *)
+
+let line_list_to_stream string_list =
+   let count = ref 0 in
+   let buff = ref "" in
+   let reserve = ref string_list in
+   let current_length = ref 0 in
+   (fun i -> if (i - !count) >= !current_length then
+               begin
+                  count := !count + !current_length + 1;
+                  match !reserve with
+		  | [] -> None
+                  | s1::rest -> 
+                    begin
+                      buff := s1;
+                      current_length := String.length !buff;
+		      reserve := rest;
+                      Some '\n'
+                    end
+               end
+             else
+               Some(String.get !buff (i - !count)));;
+ 
+
+(* In older revisions of this file you would find a function that
+   does line oriented breakdown of the input channel without resorting to
+   a list of lines.  However, the need for the list of line appeared when
+   we wanted to have  a channel and a list of strings describing the same
+   data, one for regular parsing and the other for error recovery. *)
+
+let channel_to_stream_and_string_list stop_string input_channel =
+   let string_list = gather_strings stop_string input_channel in
+   (line_list_to_stream string_list, string_list);;
+
+let flush_until_end_of_stream char_stream =
+ Stream.iter (function _ -> ()) char_stream;;
+
+(* There are only 5 kinds of lines recognized by our little parser.
+   Unrecognized lines are ignored. *)
+type parser_request =
+  | PRINT_VERSION
+  | PARSE_STRING of string
+      (* parse_string <int> [<ident>] then text and && END--OF--DATA *)
+  | QUIET_PARSE_STRING
+      (* quiet_parse_string then text and && END--OF--DATA *)
+  | PARSE_FILE of string
+      (* parse_file <int> <string> *)
+  | ADD_PATH of string
+      (* add_path <int> <string> *)
+  | ADD_REC_PATH of string * string
+      (* add_rec_path <int> <string> <ident> *)
+  | LOAD_SYNTAX of string
+      (* load_syntax_file <int> <ident> *)
+  | GARBAGE
+;;
+
+(* The procedure parser_loop should never terminate while the input_channel is
+   not closed. This procedure receives the functions called for each sentence
+   as arguments.  Thus the code is completely independent from the Coq sources. *)
+let parser_loop functions input_channel =
+  let print_version_action,
+      parse_string_action,
+      quiet_parse_string_action,
+      parse_file_action,
+      add_path_action,
+      add_rec_path_action,
+      load_syntax_action = functions in
+  let rec parser_loop_rec input_channel =
+  (let line = input_line input_channel in
+  let reqid, parser_request = 
+      try 
+      (match Stream.from (token_stream (Stream.of_string line)) with
+        parser
+        | [< 'Tid "print_version" >] ->
+                     0, PRINT_VERSION
+        | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ;
+             'Tid phylum ; 'Trbracket >] 
+                  -> reqid,PARSE_STRING phylum
+        | [< 'Tid "quiet_parse_string" >] ->
+                     0,QUIET_PARSE_STRING
+        | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] ->
+                     reqid, PARSE_FILE fname
+        | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ;  'Tid alias >]
+            -> reqid, ADD_REC_PATH(directory, alias)
+        | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >]
+            -> reqid, ADD_PATH directory
+        | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] ->
+               reqid, LOAD_SYNTAX module_name
+	| [< 'Tid "quit_parser" >] -> raise End_of_file
+        | [< >] -> 0, GARBAGE)
+       with
+         Stream.Failure | Stream.Error _ -> 0,GARBAGE in
+   match parser_request with
+     PRINT_VERSION -> print_version_action ()
+   | PARSE_STRING phylum ->
+     let regular_stream, string_list =
+        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
+      parse_string_action reqid phylum (Stream.from regular_stream)
+        string_list;()
+   | QUIET_PARSE_STRING ->
+     let regular_stream, string_list =
+        channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in
+       quiet_parse_string_action
+        (Stream.from regular_stream);()
+   | PARSE_FILE file_name ->
+        parse_file_action reqid file_name
+   | ADD_PATH path -> add_path_action reqid path
+   | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias
+   | LOAD_SYNTAX syn -> load_syntax_action reqid syn
+   | GARBAGE -> ());
+   parser_loop_rec input_channel in
+   parser_loop_rec input_channel;;
diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli
new file mode 100644
index 00000000..b0b043c7
--- /dev/null
+++ b/contrib/interface/line_parser.mli
@@ -0,0 +1,5 @@
+val parser_loop :
+  (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) *
+  (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) *
+  (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c
+val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
new file mode 100644
index 00000000..eaff0968
--- /dev/null
+++ b/contrib/interface/name_to_ast.ml
@@ -0,0 +1,252 @@
+open Sign;;
+open Classops;;
+open Names;;
+open Nameops
+open Coqast;;
+open Ast;;
+open Termast;;
+open Term;;
+open Impargs;;
+open Reduction;;
+open Libnames;;
+open Libobject;;
+open Environ;;
+open Declarations;;
+open Prettyp;;
+open Inductive;;
+open Util;;
+open Pp;;
+open Declare;;
+open Nametab
+open Vernacexpr;;
+open Decl_kinds;;
+open Constrextern;;
+open Topconstr;;
+
+(* This function converts the parameter binders of an inductive definition,
+   in particular you have to be careful to handle each element in the
+   context containing all previously defined variables.  This squeleton
+   of this procedure is taken from the function print_env in pretty.ml *)
+let convert_env =
+    let convert_binder env (na, b, c) =
+      match b with 
+       | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b)
+       | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in
+    let rec cvrec env = function
+       [] -> []
+     | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in
+    cvrec (Global.env());;
+
+(* let mib string = 
+     let sp = Nametab.sp_of_id CCI (id_of_string string) in
+     let lobj = Lib.map_leaf (objsp_of sp) in
+     let (cmap, _) = outMutualInductive lobj in
+     Listmap.map cmap CCI;; *)
+
+(* This function is directly inspired by print_impl_args in pretty.ml *)
+
+let impl_args_to_string_by_pos = function
+    [] -> None
+  | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.")
+  | l -> Some (" positions " ^
+                (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s)
+                     l
+                     " are implicit."));;
+
+(* This function is directly inspired by implicit_args_id in pretty.ml *)
+
+let impl_args_to_string l = 
+  impl_args_to_string_by_pos (positions_of_implicits l)
+
+let implicit_args_id_to_ast_list id l ast_list = 
+    (match impl_args_to_string l with
+           None -> ast_list
+         | Some(s) -> CommentString s::
+                      CommentString ("For " ^ (string_of_id id))::
+                      ast_list);;
+
+(* This function construct an ast to enumerate the implicit positions for an
+   inductive type and its constructors. It is obtained directly from
+   implicit_args_msg in pretty.ml.  *)
+
+let implicit_args_to_ast_list sp mipv =
+    let implicit_args_descriptions = 
+      let ast_list = ref [] in
+       	(Array.iteri
+           (fun i mip  ->
+	      let imps = implicits_of_global (IndRef (sp, i)) in
+		      (ast_list :=
+	      	implicit_args_id_to_ast_list mip.mind_typename imps !ast_list;
+	      	Array.iteri
+		  (fun j idc ->
+		     let impls = implicits_of_global
+		       (ConstructRef ((sp,i),j+1)) in
+		       ast_list := 
+		       implicit_args_id_to_ast_list idc impls !ast_list)
+		  mip.mind_consnames))
+	  mipv;
+	 !ast_list) in
+      match implicit_args_descriptions with
+	  [] -> []
+	| _ -> [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 *)
+
+let convert_constructors envpar names types =
+  let array_idC = 
+    array_map2 
+      (fun n t -> 
+	let coercion_flag = false (* arbitrary *) in
+	(coercion_flag, ((dummy_loc,n), extern_constr true envpar t)))
+      names types in
+  Array.to_list array_idC;;
+  
+(* this function converts one inductive type in a possibly multiple inductive
+   definition *)
+
+let convert_one_inductive sp tyi =
+  let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in
+  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,
+   convert_env(List.rev params),
+   (extern_constr true envpar arity),
+   convert_constructors envpar cstrnames cstrtypes);;
+
+(* This function converts a Mutual inductive definition to a Coqast.t.
+   It is obtained directly from print_mutual in pretty.ml.  However, all
+   references to kinds have been removed and it treats only CCI stuff. *)
+
+let mutual_to_ast_list sp mib =
+  let mipv = (Global.lookup_mind sp).mind_packets in
+  let _, l =
+    Array.fold_right
+      (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in
+  VernacInductive (mib.mind_finite, l)
+  :: (implicit_args_to_ast_list sp mipv);;
+
+let constr_to_ast v = 
+  extern_constr true (Global.env()) v;;
+
+let implicits_to_ast_list implicits =
+  match (impl_args_to_string implicits) with
+    | 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),
+     [false,([dummy_loc,name], constr_to_ast (body_of_type typ))]))
+  ::(implicits_to_ast_list implicits);;
+    
+
+let make_definition_ast name c typ implicits =
+  VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None,
+    (constr_to_ast c), Some (constr_to_ast (body_of_type typ))),
+    (fun _ _ -> ()))
+  ::(implicits_to_ast_list implicits);;
+
+(* This function is inspired by print_constant *)
+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 l = implicits_of_global (ConstRef kn) in
+  (match c with
+      None -> 
+	make_variable_ast (id_of_label (label kn)) typ l
+    | Some c1 ->
+	make_definition_ast (id_of_label (label kn)) (Declarations.force c1) typ l)
+
+let variable_to_ast_list sp =
+  let (id, c, v) = get_variable sp in
+  let l = implicits_of_global (VarRef sp) in
+    (match c with
+	 None -> 
+	   make_variable_ast id v l
+       | Some c1 ->
+	   make_definition_ast id c1 v l);;
+
+(* this function is taken from print_inductive in file pretty.ml *)
+
+let inductive_to_ast_list sp =
+  let mib = Global.lookup_mind sp in
+  mutual_to_ast_list sp mib
+
+(* this function is inspired by print_leaf_entry from pretty.ml *)
+
+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
+  | "INDUCTIVE" -> inductive_to_ast_list kn
+  | s -> 
+      errorlabstrm 
+      	"print" (str ("printing of unrecognized object " ^
+		      s ^ " has been required"));;
+
+
+
+
+(* this function is inspired by print_name *)
+let name_to_ast ref =
+  let (loc,qid) = qualid_of_reference ref in
+  let l = 
+    try
+      let sp = Nametab.locate_obj qid in
+      let (sp,lobj) = 
+      	let (sp,entry) =
+          List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
+      	in
+	  match entry with
+            | Lib.Leaf obj -> (sp,obj)
+            | _ -> raise Not_found
+      in
+    	leaf_entry_to_ast_list (sp,lobj)
+    with Not_found -> 
+      try 
+    	match Nametab.locate qid with
+	  | ConstRef sp -> constant_to_ast_list sp
+	  | IndRef (sp,_) -> inductive_to_ast_list sp
+	  | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp
+	  | VarRef sp -> variable_to_ast_list sp
+  	with Not_found -> 
+	  try  (* Var locale de but, pas var de section... donc pas d'implicits *)
+	    let dir,name = repr_qualid qid in 
+	      if (repr_dirpath dir) <> [] then raise Not_found;
+	      let (_,c,typ) = Global.lookup_named name in 
+		(match c with
+		     None -> make_variable_ast name typ []
+		   | Some c1 -> make_definition_ast name c1 typ [])
+	  with Not_found ->
+	    try
+	      let sp = Nametab.locate_syntactic_definition qid in
+		errorlabstrm "print"
+      		  (str "printing of syntax definitions not implemented")
+	    with Not_found ->
+	      errorlabstrm "print"
+		(pr_qualid qid ++
+		 spc () ++ str "not a defined object")
+  in
+  VernacList (List.map (fun x -> (dummy_loc,x)) l)
+
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
new file mode 100644
index 00000000..0eca0a1e
--- /dev/null
+++ b/contrib/interface/name_to_ast.mli
@@ -0,0 +1,2 @@
+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
new file mode 100644
index 00000000..3f0b2d2e
--- /dev/null
+++ b/contrib/interface/parse.ml
@@ -0,0 +1,488 @@
+open Util;;
+open System;;
+open Pp;;
+open Libnames;;
+open Library;;
+open Ascent;;
+open Vtp;;
+open Xlate;;
+open Line_parser;;
+open Pcoq;;
+open Vernacexpr;;
+open Mltop;;
+
+type parsed_tree =
+  | P_cl of ct_COMMAND_LIST
+  | P_c of ct_COMMAND
+  | P_t of ct_TACTIC_COM
+  | P_f of ct_FORMULA
+  | P_id of ct_ID
+  | P_s of ct_STRING
+  | P_i of ct_INT;;
+
+let print_parse_results n msg =
+  print_string "message\nparsed\n";
+  print_int n;
+  print_string "\n";
+  (match msg with
+  | P_cl x -> fCOMMAND_LIST x
+  | P_c x -> fCOMMAND x
+  | P_t x -> fTACTIC_COM x
+  | P_f x -> fFORMULA x
+  | P_id x -> fID x
+  | P_s x -> fSTRING x
+  | P_i x -> fINT x);
+  print_string "e\nblabla\n";
+  flush stdout;;
+
+let ctf_SyntaxErrorMessage reqid pps =
+ fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++
+   int reqid ++ fnl () ++
+   pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();;
+let ctf_SyntaxWarningMessage reqid pps =
+  fnl () ++  str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++
+  int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
+
+let ctf_FileErrorMessage reqid pps =
+  fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++
+  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 
+	Vernacentries.interp v
+       with _ ->
+	 let l=prlist_with_sep spc pr_reference l in
+	 msgnl (str "Reinterning of " ++ l ++ str " failed"))
+  | VernacRequireFrom (_,_,f) ->
+      (try 
+	Vernacentries.interp v
+       with _ ->
+	 msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed"))
+  | _ -> ()); v;;
+
+let parse_to_dot =
+  let rec dot st = match Stream.next st with
+    | ("", ".") -> ()
+    | ("EOI", "") -> raise End_of_file
+    | _ -> dot st in
+    Gram.Entry.of_parser "Coqtoplevel.dot" dot;;
+
+let rec discard_to_dot stream =
+  try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with
+  | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;;
+
+let rec decompose_string_aux s n =
+    try let index = String.index_from s n '\n' in
+            (String.sub s n (index - n))::
+            (decompose_string_aux s (index + 1))
+    with Not_found -> [String.sub s n ((String.length s) - n)];;
+
+let decompose_string s n =
+  match decompose_string_aux s n with
+      ""::tl -> tl
+    | a -> a;;
+
+let make_string_list file_chan fst_pos snd_pos =
+    let len = (snd_pos - fst_pos) in
+    let s = String.create len in
+    begin
+      seek_in file_chan fst_pos;
+      really_input file_chan s 0 len;
+      decompose_string s 0;
+    end;;
+
+let rec get_sub_aux string_list snd_pos =
+    match string_list with
+      [] -> []
+    | s::l ->
+      let len = String.length s in
+        if len >= snd_pos then
+          if snd_pos < 0 then
+            []
+          else
+            [String.sub s 0 snd_pos]
+        else
+          s::(get_sub_aux l (snd_pos - len - 1));;
+
+let rec get_substring_list string_list fst_pos snd_pos =
+  match string_list with
+    [] -> []
+  | s::l -> 
+    let len = String.length s in
+    if fst_pos > len then
+       get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1)
+    else
+       (* take into account the fact that carriage returns are not in the *)
+       (* strings. *)
+       let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in
+       if snd_pos > len then
+         String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2)::
+         (get_sub_aux l (snd_pos - len - 2))
+       else
+         let gap = (snd_pos - fst_pos2) in
+         if gap < 0 then
+            []
+         else
+            [String.sub s (fst_pos2 - 1) gap];;
+
+(* When parsing a list of commands, we try to recover error messages for
+   each individual command. *)
+
+type parse_result =
+  | ParseOK of Vernacexpr.vernac_expr located option
+  | ParseError of string * string list
+
+let embed_string s =
+  CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s))
+
+let make_parse_error_item s l =
+  CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l))
+
+let parse_command_list reqid stream string_list =
+    let rec parse_whole_stream () =
+    let this_pos = Stream.count stream in
+    let first_ast = 
+        try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
+        with
+        | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> 
+          begin
+             msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e));
+             try
+                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))
+             with End_of_file -> ParseOK None
+           end
+        | 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
+          (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()
+    | ParseOK None -> []
+    | ParseError (s,l) -> 
+	(make_parse_error_item s l)::parse_whole_stream()
+ in
+    match parse_whole_stream () with
+    | first_one::tail -> (P_cl (CT_command_list(first_one, tail)))
+    | [] -> raise (UserError ("parse_string", (str "empty text.")));;
+
+(*When parsing a string using a phylum, the string is first transformed
+  into a Coq Ast using the regular Coq parser, then it is transformed into
+  the right ascent term using xlate functions, then it is transformed into
+  a stream, using the right vtp function. There is a special case for commands,
+  since some of these must be executed!*)
+let parse_string_action reqid phylum char_stream string_list =
+ try let msg =
+      match phylum with
+      | "COMMAND_LIST" ->
+        parse_command_list reqid char_stream string_list
+      | "COMMAND" ->
+       P_c
+        (xlate_vernac
+        (execute_when_necessary
+        (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream))))
+      | "TACTIC_COM" ->
+       P_t
+        (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi 
+                         (Gram.parsable char_stream)))
+      | "FORMULA" ->
+       P_f
+        (xlate_formula
+	   (Gram.Entry.parse 
+              (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream)))
+      | "ID" -> P_id (CT_ident
+                        (Libnames.string_of_qualid 
+			 (snd 
+			       (Gram.Entry.parse  (Pcoq.eoi_entry Pcoq.Prim.qualid)
+						 (Gram.parsable char_stream)))))
+      | "STRING" ->
+	  P_s
+         (CT_string (Gram.Entry.parse Pcoq.Prim.string 
+                  (Gram.parsable char_stream)))
+      | "INT" ->
+	  P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural
+                              (Gram.parsable char_stream)))
+      | _ -> error "parse_string_action : bad phylum" in
+      print_parse_results reqid msg
+ with
+ | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
+    flush_until_end_of_stream char_stream;
+    msgnl (ctf_SyntaxErrorMessage reqid
+              (Cerrors.explain_exn 
+                 (Stdpp.Exc_located(l,Stream.Error "match failure"))))
+ | e ->
+    flush_until_end_of_stream char_stream;
+    msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));;
+
+
+let quiet_parse_string_action char_stream =
+ try let _ = 
+         Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in
+     ()
+ with
+ | _ -> flush_until_end_of_stream char_stream; ();;
+
+
+let parse_file_action reqid file_name =
+ try let file_chan = open_in file_name in
+     (* file_chan_err, stream_err are the channel and stream  used to 
+        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 rec discard_to_dot () =
+       try Gram.Entry.parse parse_to_dot (Gram.parsable stream)
+       with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in
+       match let rec parse_whole_file () =
+	 let this_pos = Stream.count stream in
+           match 
+             try
+	       ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream))
+             with
+               | Stdpp.Exc_located(l,Stream.Error txt) -> 
+                   msgnl (ctf_SyntaxWarningMessage reqid
+			    (str "Error with file" ++ spc () ++
+			     str file_name ++ fnl () ++
+			     Cerrors.explain_exn 
+				 (Stdpp.Exc_located(l,Stream.Error txt))));
+		   (try 
+		      begin
+                      	discard_to_dot ();
+                    	ParseError ("PARSING_ERROR",
+				   (make_string_list file_chan_err this_pos 
+			       	      (Stream.count stream)))
+		      end
+                    with End_of_file -> ParseOK None)
+               | e ->
+                   begin
+                     Gram.Entry.parse parse_to_dot (Gram.parsable stream);
+                     ParseError ("PARSING_ERROR2",
+			       (make_string_list file_chan this_pos
+				  (Stream.count stream)))
+                   end
+		   
+             with
+               | ParseOK (Some (_,ast)) ->
+		   let ast0=(execute_when_necessary ast) in 
+		   let term =
+                     (try xlate_vernac ast
+		      with e ->
+                    	print_string ("translation error between " ^
+				      (string_of_int this_pos) ^
+				      " " ^
+				      (string_of_int (Stream.count stream)) ^
+				      "\n");
+			make_parse_error_item "PARSING_ERROR2"
+			  (make_string_list file_chan_err this_pos
+			    (Stream.count stream))) in 
+		     term::parse_whole_file ()
+               | ParseOK None -> []
+	       | ParseError (s,l) -> 
+		   (make_parse_error_item s l)::parse_whole_file () in
+         parse_whole_file () with
+	   | first_one :: tail ->
+	       print_parse_results reqid
+		 (P_cl (CT_command_list (first_one, tail)))
+	   | [] -> raise (UserError ("parse_file_action", str "empty file."))
+       with
+	 | Stdpp.Exc_located(l,Match_failure(_,_,_)) ->
+	     msgnl
+	       (ctf_SyntaxErrorMessage reqid
+		  (str "Error with file" ++ spc () ++ str file_name ++ 
+		   fnl () ++
+		     Cerrors.explain_exn
+		       (Stdpp.Exc_located(l,Stream.Error "match failure"))))
+	 | e ->
+	     msgnl
+	       (ctf_SyntaxErrorMessage reqid
+		  (str "Error with file" ++ spc () ++ str file_name ++
+		   fnl () ++ Cerrors.explain_exn e));;
+
+let add_rec_path_action reqid string_arg ident_arg =
+  let directory_name = glob 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
+    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 $");;
+
+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);
+      msg (str "opening... ");
+      Declaremods.import_module false (Nametab.locate_module qid); 
+      msgnl (str "done" ++ fnl ());
+      ())
+ with
+ | UserError (label, pp_stream) ->
+ (*This one may be necessary to make sure that the message won't be indented *)
+ msgnl (mt ());
+ msgnl
+  (fnl () ++ str "error while loading syntax module " ++ str module_name ++
+   str ": " ++ str label ++ fnl () ++ pp_stream)
+ | e ->
+  msgnl (mt ());
+  msgnl
+   (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++
+    int reqid ++ fnl ());
+  ();;
+
+let coqparser_loop inchan =
+ (parser_loop : (unit -> unit) *
+                (int -> string -> char Stream.t -> string list -> unit) *
+                (char Stream.t -> unit) * (int -> string -> unit) *
+                (int -> string -> unit) * (int -> string -> string -> unit) *
+                (int -> string -> unit) -> in_channel -> unit)
+ (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action,
+ add_path_action, add_rec_path_action, load_syntax_action) inchan;;
+
+if !Sys.interactive then ()
+ else 
+Libobject.relax true;
+(let coqdir = 
+   try Sys.getenv "COQDIR"
+   with Not_found -> 
+     let coqdir = Coq_config.coqlib in
+       if Sys.file_exists coqdir then
+	 coqdir
+       else
+	 (msgnl (str "could not find the value of COQDIR"); exit 1) in
+     begin
+       add_rec_path (Filename.concat coqdir "theories")
+	 (Names.make_dirpath [Nameops.coq_root]);
+       add_rec_path (Filename.concat coqdir "contrib")
+	 (Names.make_dirpath [Nameops.coq_root])
+     end;
+(let vernacrc =
+   try
+     Sys.getenv "VERNACRC"
+   with
+       Not_found -> 
+	 List.fold_left 
+	   (fun s1 s2 -> (Filename.concat s1 s2))
+	   coqdir [ "contrib"; "interface"; "vernacrc"] in
+   try
+     (Gramext.warning_verbose := false;
+      Esyntax.warning_verbose := false;
+      coqparser_loop (open_in vernacrc))
+   with
+     | End_of_file -> ()
+     | e ->
+	 (msgnl (Cerrors.explain_exn e);
+	  msgnl (str "could not load the VERNACRC file"));
+	 try
+	   msgnl (str vernacrc)
+	 with
+	     e -> ());
+(try let user_vernacrc =
+   try Some(Sys.getenv "USERVERNACRC")
+   with
+     | Not_found as e ->
+	 msgnl (str "no .vernacrc file"); None in
+   (match user_vernacrc with
+      	Some f -> coqparser_loop (open_in f)
+      | None -> ())
+ with
+   | End_of_file -> ()
+   | e ->
+       msgnl (Cerrors.explain_exn e);
+       msgnl (str "error in your .vernacrc file"));
+msgnl (str "Starting Centaur Specialized Parser Loop");
+try
+  coqparser_loop stdin
+with 
+  | End_of_file -> ()
+  | e -> msgnl(Cerrors.explain_exn e))
diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml
new file mode 100644
index 00000000..b1244d15
--- /dev/null
+++ b/contrib/interface/paths.ml
@@ -0,0 +1,26 @@
+let int_list_to_string s l =
+    List.fold_left 
+       (fun s -> (fun v -> s ^ " " ^ (string_of_int v)))
+       s
+       l;;
+
+(* Given two paths, this function returns the longest common prefix and the
+   two suffixes. *)
+let rec decompose_path
+     : (int list * int list) -> (int list * int list * int list) =
+   function
+       (a::l,b::m) when a = b ->
+         let (c,p1,p2) = decompose_path (l,m) in
+         (a::c,p1,p2)
+     |  p1,p2 -> [], p1, p2;;
+
+let rec is_prefix p1 p2 = match p1,p2 with
+  [], _ -> true
+| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2
+| _ -> false;;
+
+let rec lex_smaller p1 p2 = match p1,p2 with
+  [], _ -> true
+| a::tl1, b::tl2 when a < b -> true
+| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2
+| _ -> false;;
\ No newline at end of file
diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli
new file mode 100644
index 00000000..26620723
--- /dev/null
+++ b/contrib/interface/paths.mli
@@ -0,0 +1,4 @@
+val decompose_path : (int list * int list) -> (int list * int list * int list);;
+val int_list_to_string : string -> int list -> string;;
+val is_prefix : int list -> int list -> bool;;
+val lex_smaller : int list -> int list -> bool;;
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
new file mode 100644
index 00000000..e0f88ba6
--- /dev/null
+++ b/contrib/interface/pbp.ml
@@ -0,0 +1,758 @@
+(* A proof by pointing algorithm. *)
+open Util;;
+open Names;;
+open Term;;
+open Tactics;;
+open Tacticals;;
+open Hipattern;;
+open Pattern;;
+open Matching;;
+open Reduction;;
+open Rawterm;;
+open Environ;;
+
+open Proof_trees;;
+open Proof_type;;
+open Tacmach;;
+open Tacexpr;;
+open Typing;;
+open Pp;;
+open Libnames;;
+open Genarg;;
+open Topconstr;;
+open Termops;;
+
+let zz = Util.dummy_loc;;
+
+let hyp_radix = id_of_string "H";;
+
+let next_global_ident = next_global_ident_away true
+
+(* get_hyp_by_name : goal sigma -> string -> constr,
+   looks up for an hypothesis (or a global constant), from its name *)
+let get_hyp_by_name g name =
+  let evd = project g in
+  let env = pf_env g in
+  try (let judgment = 
+         Pretyping.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)))
+;;
+
+type pbp_atom =
+  | PbpTryAssumption of identifier option
+  | PbpTryClear of identifier list
+  | PbpGeneralize of identifier * identifier list
+  | PbpLApply of identifier (* = CutAndApply *)
+  | PbpIntros of intro_pattern_expr list
+  | PbpSplit
+  (* Existential *)
+  | PbpExists of identifier
+  (* Or *)
+  | PbpLeft
+  | PbpRight
+  (* Head *)
+  | PbpApply of identifier
+  | PbpElim of identifier * identifier list;;
+
+(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics
+   [a1]..[an-1] are atomic (or try of an atomic) tactic and produce
+   exactly one goal, and [an] produces exactly p subgoals
+
+   In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and
+   produces exactly one subgoal, except the last one which may complete the
+   goal
+
+   Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion
+   from atomic to composed tactic
+*)
+
+type pbp_sequence =
+  | PbpThens of pbp_atom list * pbp_sequence list
+  | PbpThen of pbp_atom list
+
+(* This flattens sequences of tactics producing just one subgoal *)
+let chain_tactics tl1 = function
+  | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3)
+  | PbpThen tl2 -> PbpThen (tl1@tl2)
+
+type pbp_rule = (identifier list *
+                    identifier list *
+                    bool *
+                    identifier option *
+                    (types, constr) kind_of_term *
+                    int list *
+                    (identifier list ->
+                     identifier list ->
+                     bool ->
+                       identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) ->
+                    pbp_sequence option;;
+
+
+let make_named_intro id = PbpIntros [IntroIdentifier id];;
+
+let make_clears str_list = PbpThen [PbpTryClear str_list]
+
+let add_clear_names_if_necessary tactic clear_names =
+    match clear_names with
+      [] -> tactic
+    | l -> chain_tactics [PbpTryClear l] tactic;;
+
+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) ->
+      Some(func a c cf o (kind_of_term f) p)
+  | _ -> None;;
+
+let (forall_intro: pbp_rule) = function
+  (avoid,
+   clear_names,
+   clear_flag,
+   None,
+   Prod(Name x, _, body),
+   (2::path),
+   f) ->
+     let x' = next_global_ident x avoid in
+      Some(chain_tactics [make_named_intro x']
+	      (f (x'::avoid)
+		clear_names clear_flag None (kind_of_term body) path))
+| _ -> None;;
+
+let (imply_intro2: pbp_rule) = function
+  avoid, clear_names,
+  clear_flag, None, Prod(Anonymous, _, body), 2::path, f ->
+   let h' = next_global_ident hyp_radix avoid in
+     Some(chain_tactics [make_named_intro h']
+          (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path))
+  | _ -> None;;
+
+      
+(*
+let (imply_intro1: pbp_rule) = function
+  avoid, clear_names,
+  clear_flag, None, Prod(Anonymous, prem, body), 1::path, f ->
+   let h' = next_global_ident hyp_radix avoid in
+   let str_h' = h' in
+     Some(chain_tactics [make_named_intro str_h']
+            (f (h'::avoid) clear_names clear_flag (Some str_h') 
+		(kind_of_term prem) path))
+  | _ -> None;;
+*)
+
+let make_var id = CRef (Ident(zz, id))
+
+let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l)
+
+let make_pbp_pattern x =
+  make_app (make_var (id_of_string "PBP_META"))
+     [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))]
+
+let rec make_then = function
+  | [] -> TacId ""
+  | [t] -> t
+  | t1::t2::l -> make_then (TacThen (t1,t2)::l)
+
+let make_pbp_atomic_tactic = function
+  | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption))
+  | PbpTryAssumption (Some a) ->
+      TacTry (TacAtom (zz, TacExact (make_var a)))
+  | PbpExists x -> 
+      TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x]))
+  | PbpGeneralize (h,args) ->
+      let l = List.map make_pbp_pattern args in
+      TacAtom (zz, TacGeneralize [make_app (make_var h) l])
+  | PbpLeft -> TacAtom (zz, TacLeft NoBindings)
+  | PbpRight -> TacAtom (zz, TacRight NoBindings)
+  | PbpIntros l -> TacAtom (zz, TacIntroPattern l)
+  | PbpLApply h -> TacAtom (zz, TacLApply (make_var h))
+  | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings))
+  | PbpElim (hyp_name, names) ->
+      let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in
+      TacAtom
+	(zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None))
+  | PbpTryClear l -> 
+      TacTry (TacAtom (zz, TacClear (List.map (fun s -> AI (zz,s)) l)))
+  | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));;
+
+let rec make_pbp_tactic = function
+  | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl)
+  | PbpThens (l,tl) ->
+      TacThens
+        (make_then (List.map make_pbp_atomic_tactic l),
+	 List.map make_pbp_tactic tl)
+
+let (forall_elim: pbp_rule) = function
+  avoid, clear_names, clear_flag, 
+  Some h, Prod(Name x, _, body), 2::path, f ->
+  let h' = next_global_ident hyp_radix avoid in
+  let clear_names' = if clear_flag then h::clear_names else clear_names in
+    Some
+     (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h']
+        (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path))
+  | _ -> None;;
+
+
+let (imply_elim1: pbp_rule) = function
+  avoid, clear_names, clear_flag,
+  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
+  Some(PbpThens
+	  ([PbpLApply h],
+	   [chain_tactics [make_named_intro h'] (make_clears (h::clear_names));
+	    f avoid clear_names' false None (kind_of_term prem) path]))
+  | _ -> None;;
+
+
+let (imply_elim2: pbp_rule) = function
+  avoid, clear_names, clear_flag,
+  Some h, Prod(Anonymous, prem, body), 2::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
+  Some(PbpThens
+	 ([PbpLApply h],
+          [chain_tactics [make_named_intro h']
+              (f (h'::avoid) clear_names' false (Some h') 
+		      (kind_of_term body) path);
+           make_clears clear_names]))
+  | _ -> None;;
+
+let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s
+
+let constant dir s =  Coqlib.gen_constant "Pbp" ("Init"::dir) s
+
+let andconstr: unit -> constr = Coqlib.build_coq_and;;
+let prodconstr () = constant ["Datatypes"] "prod";;
+let exconstr = Coqlib.build_coq_ex;;
+let sigconstr () = constant ["Specif"] "sig";;
+let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;;
+let orconstr = Coqlib.build_coq_or;;
+let sumboolconstr = Coqlib.build_coq_sumbool;;
+let sumconstr() = constant ["Datatypes"] "sum";;
+let notconstr = Coqlib.build_coq_not;;
+let notTconstr () = constant ["Logic_Type"] "notT";;
+
+let is_matching_local a b = is_matching (pattern_of_constr a) b;;
+
+let rec (or_and_tree_to_intro_pattern: identifier list -> 
+	   constr -> int list -> 
+	     intro_pattern_expr * identifier list * identifier *constr
+	     * int list * int * int) =
+fun avoid c path -> match kind_of_term c, path with
+  | (App(oper, [|c1; c2|]), 2::a::path)
+    when ((is_matching_local (andconstr()) oper) or
+	  (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
+      let id2 = next_global_ident hyp_radix avoid in
+      let cont_expr = if a = 1 then c1 else c2 in
+      let cont_patt, avoid_names, id, c, path, rank, total_branches = 
+	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
+      let patt_list = 
+	if a = 1 then
+	  [cont_patt; IntroIdentifier id2]
+	else
+	  [IntroIdentifier id2; cont_patt] in
+      	(IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, 
+	 total_branches)
+  | (App(oper, [|c1; c2|]), 2::3::path)
+    when ((is_matching_local (exconstr()) oper) or
+	  (is_matching_local (sigconstr()) oper)) ->
+      (match (kind_of_term c2) with 
+	   Lambda (Name x, _, body) ->
+	     let id1 = next_global_ident x avoid in
+	     let cont_patt, avoid_names, id, c, path, rank, total_branches =
+	       or_and_tree_to_intro_pattern (id1::avoid) body path in
+	     (IntroOrAndPattern[[IntroIdentifier id1; cont_patt]],
+	      avoid_names, id, c, path, rank, total_branches)
+	 | _ -> assert false)
+  | (App(oper, [|c1; c2|]), 2::a::path)
+      when ((is_matching_local (orconstr ()) oper) or
+            (is_matching_local (sumboolconstr ()) oper) or
+	    (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) ->
+      let id2 = next_global_ident hyp_radix avoid in
+      let cont_expr = if a = 1 then c1 else c2 in
+      let cont_patt, avoid_names, id, c, path, rank, total_branches =
+ 	or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in
+      let new_rank = if a = 1 then rank else rank+1 in
+      let patt_list =
+	if a = 1 then
+	  [[cont_patt];[IntroIdentifier id2]]
+	else
+	  [[IntroIdentifier id2];[cont_patt]] in
+	(IntroOrAndPattern patt_list, 
+	 avoid_names, id, c, path, new_rank, total_branches+1)
+  | (_, path) -> let id = next_global_ident hyp_radix avoid in
+      (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);;
+
+let auxiliary_goals clear_names clear_flag this_name n_aux others =
+  let clear_cmd = 
+    make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in
+  let rec clear_list = function
+      0 -> others
+    | n -> clear_cmd::(clear_list (n - 1)) in
+  clear_list n_aux;;
+
+
+let (imply_intro3: pbp_rule) = function
+    avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body),
+    1::path, f ->
+      let intro_patt, avoid_names, id, c, p, rank, total_branches =
+	or_and_tree_to_intro_pattern avoid prem path in
+	if total_branches = 1 then
+	  Some(chain_tactics [PbpIntros [intro_patt]]
+		 (f avoid_names clear_names clear_flag (Some id)
+		    (kind_of_term c) path))
+	else
+	  Some
+	    (PbpThens
+	       ([PbpIntros [intro_patt]],
+	    	auxiliary_goals clear_names clear_flag id
+		  (rank - 1)
+		  ((f avoid_names clear_names clear_flag (Some id)
+		      (kind_of_term c) path)::
+		     auxiliary_goals clear_names clear_flag id 
+		     (total_branches - rank) [])))
+  | _ -> None;;
+		 
+
+
+let (and_intro: pbp_rule) = function
+    avoid, clear_names, clear_flag,
+    None, App(and_oper, [|c1; c2|]), 2::a::path, f 
+      ->
+      if ((is_matching_local (andconstr()) and_oper) or
+          (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then
+      	let cont_term = if a = 1 then c1 else c2 in
+      	let cont_cmd = f avoid clear_names false None 
+			 (kind_of_term cont_term) path in
+      	let clear_cmd = make_clears clear_names in
+      	let cmds =
+            (if a = 1 
+	    then [cont_cmd;clear_cmd] 
+	    else [clear_cmd;cont_cmd]) in
+      	Some (PbpThens ([PbpSplit],cmds))
+      else None
+  | _ -> None;;
+
+let exists_from_lambda avoid clear_names clear_flag c2 path f =
+  match kind_of_term c2 with
+    Lambda(Name x, _, body) -> 
+      Some (PbpThens ([PbpExists x],
+		      [f avoid clear_names false None (kind_of_term body) path]))
+  | _ -> None;;
+
+
+let (ex_intro: pbp_rule) = function
+    avoid, clear_names, clear_flag, None,
+    App(oper, [| c1; c2|]), 2::3::path, f
+      when (is_matching_local (exconstr ()) oper)
+ 	or (is_matching_local (sigconstr ()) oper) ->
+	  exists_from_lambda avoid clear_names clear_flag c2 path f
+  | _ -> None;;
+
+let (exT_intro : pbp_rule) = function
+    avoid, clear_names, clear_flag, None,
+    App(oper, [| c1; c2|]), 2::2::2::path, f
+      when (is_matching_local (sigTconstr ()) oper) ->
+	exists_from_lambda avoid clear_names clear_flag c2 path f
+  | _ -> None;;
+
+let (or_intro: pbp_rule) = function
+    avoid, clear_names, clear_flag, None,
+    App(or_oper, [|c1; c2 |]), 2::a::path, f ->
+      if ((is_matching_local (orconstr ()) or_oper) or
+        (is_matching_local (sumboolconstr ()) or_oper) or 
+	(is_matching_local (sumconstr ()) or_oper))
+	  & (a = 1 or a = 2) then
+	let cont_term = if a = 1 then c1 else c2 in
+	let fst_cmd = if a = 1 then PbpLeft else PbpRight in
+	let cont_cmd = f avoid clear_names false None 
+			 (kind_of_term cont_term) path in
+	Some(chain_tactics [fst_cmd] cont_cmd)
+      else
+	None
+  | _ -> None;;
+	
+let dummy_id = id_of_string "Dummy";;
+
+let (not_intro: pbp_rule) = function
+    avoid, clear_names, clear_flag, None,
+    App(not_oper, [|c1|]), 2::1::path, f ->
+      if(is_matching_local (notconstr ()) not_oper) or 
+	(is_matching_local (notTconstr ()) not_oper) then
+	let h' = next_global_ident hyp_radix avoid in
+	Some(chain_tactics [make_named_intro h']
+	       (f (h'::avoid) clear_names false (Some h') 
+		  (kind_of_term c1) path))
+      else
+ 	None
+  | _ -> None;;
+
+
+
+
+let elim_with_bindings hyp_name names =
+  PbpElim (hyp_name, names);;
+
+(* This function is used to follow down a path, while staying on the spine of
+   successive products (universal quantifications or implications).
+   Arguments are the current observed constr object and the path that remains
+   to be followed, and an integer indicating how many products have already been
+   crossed.
+   Result is:
+     - a list of string indicating the names of universally quantified variables.
+     - a list of integers indicating the positions of the successive 
+       universally quantified variables.
+     - an integer indicating the number of non-dependent products.
+     - the last constr object encountered during the walk down, and
+     - the remaining path.
+
+   For instance the following session should happen:
+  let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign()))
+     (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in
+     down_prods (tt, [2;2;2], 0)
+  ---> ["P","x"],[0;1], 1, <<(P x)>>, []
+*)
+
+
+let rec down_prods: (types, constr) kind_of_term * (int list) * int -> 
+           identifier list * (int list) * int * (types, constr) kind_of_term *
+  (int list) = 
+   function
+     Prod(Name x, _, body), 2::path, k ->
+	let res_sl, res_il, res_i, res_cstr, res_p 
+	    = down_prods (kind_of_term body, path, k+1) in
+	x::res_sl, (k::res_il), res_i, res_cstr, res_p
+   | Prod(Anonymous, _, body), 2::path, k ->
+        let res_sl, res_il, res_i, res_cstr, res_p 
+	    = down_prods (kind_of_term body, path, k+1) in
+	res_sl, res_il, res_i+1, res_cstr, res_p
+   | cstr, path, _ -> [], [], 0, cstr, path;;
+
+exception Pbp_internal of int list;;
+
+(* This function should be usable to check that a type can be used by the
+   Apply command.  Basically, c is supposed to be the head of some
+   type, where l gives the ranks of all universally quantified variables.
+   It check that these universally quantified variables occur in the head.
+
+   The knowledge I have on constr structures is incomplete.
+*)
+let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = 
+   function c -> function l ->
+   let rec delete n = function
+     | [] -> []
+     | p::tl -> if n = p then tl else p::(delete n tl) in
+   let rec check_rec l = function
+   | App(f, array) ->
+       Array.fold_left (fun l c -> check_rec l (kind_of_term c))
+	 (check_rec l (kind_of_term f)) array
+   | Const _ -> l
+   | Ind _ -> l
+   | Construct _ -> l
+   | Var _ -> l
+   | Rel p ->
+       let result = delete p l in
+       if result = [] then
+	 raise (Pbp_internal [])
+       else
+	 result
+   | _ -> raise (Pbp_internal l) in
+   try 
+     (check_rec l c) = []
+   with Pbp_internal l -> l = [];;
+
+let (mk_db_indices: int list -> int -> int list) =
+  function int_list -> function nprems ->
+   let total = (List.length int_list) + nprems  in
+   let rec mk_db_aux = function
+     [] -> []
+   | a::l -> (total - a)::(mk_db_aux l) in
+   mk_db_aux int_list;;
+     
+
+(* This proof-by-pointing rule is quite complicated, as it attempts to foresee
+   usages of head tactics.  A first operation is to follow the path as far
+   as possible while staying on the spine of products (function down_prods)
+   and then to check whether the next step will be an elim step.  If the 
+   answer is true, then the built command takes advantage of the power of
+   head tactics.  *)
+
+let (head_tactic_patt: pbp_rule) = function
+    avoid, clear_names, clear_flag, Some h, cstr, path, f ->
+    (match down_prods (cstr, path, 0) with
+    | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path)
+      when (((is_matching_local (exconstr ()) oper) (* or
+	      (is_matching_local (sigconstr ()) oper) *))  && a = 3) ->
+		   (match (kind_of_term c2) with
+		     Lambda(Name x, _,body) ->
+		       Some(PbpThens
+		    		 ([elim_with_bindings h str_list],
+				   let x' = next_global_ident x avoid in
+				   let cont_body =
+				     Prod(Name x', c1,
+					    mkProd(Anonymous, body, 
+						   mkVar(dummy_id))) in
+				   let cont_tac 
+				       = f avoid (h::clear_names) false None
+				       cont_body (2::1::path) in
+				   cont_tac::(auxiliary_goals
+						       clear_names clear_flag
+						       h nprems [])))
+		     | _ -> None)
+    | (str_list, _, nprems, 
+       App(oper,[|c1|]), 2::1::path) 
+      	when
+ 	  (is_matching_local (notconstr ()) oper) or
+ 	  (is_matching_local (notTconstr ()) oper) ->
+	 Some(chain_tactics [elim_with_bindings h str_list]
+		 (f avoid clear_names false None (kind_of_term c1) path))
+    | (str_list, _, nprems, 
+       App(oper, [|c1; c2|]), 2::a::path) 
+      when ((is_matching_local (andconstr()) oper) or
+	    (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) ->
+	let h1 = next_global_ident hyp_radix avoid in
+	let h2 = next_global_ident hyp_radix (h1::avoid) in
+	Some(PbpThens
+                  ([elim_with_bindings h str_list],
+		    let cont_body = 
+		      if a = 1 then c1 else c2 in
+		    let cont_tac = 
+		      f (h2::h1::avoid) (h::clear_names) 
+                        false (Some (if 1 = a then h1 else h2))
+                        (kind_of_term cont_body) path in
+		      (chain_tactics 
+			 [make_named_intro h1; make_named_intro h2]
+			 cont_tac)::
+	       (auxiliary_goals clear_names clear_flag h nprems [])))
+    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
+      when ((is_matching_local (sigTconstr()) oper)) & a = 2 ->
+		   (match (kind_of_term c2),path with
+		     Lambda(Name x, _,body), (2::path) ->
+		       Some(PbpThens
+		    		 ([elim_with_bindings h str_list],
+				   let x' = next_global_ident x avoid in
+				   let cont_body =
+				     Prod(Name x', c1,
+					    mkProd(Anonymous, body, 
+						   mkVar(dummy_id))) in
+				   let cont_tac 
+				       = f avoid (h::clear_names) false None
+				       cont_body (2::1::path) in
+				   cont_tac::(auxiliary_goals
+						       clear_names clear_flag
+						       h nprems [])))
+		     | _ -> None)
+    | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path)
+	when ((is_matching_local (orconstr ()) oper) or
+              (is_matching_local (sumboolconstr ()) oper) or
+	      (is_matching_local (sumconstr ()) oper)) &
+                (a = 1 or a = 2) ->
+	  Some(PbpThens
+		    ([elim_with_bindings h str_list],
+		      let cont_body =
+			if a = 1 then c1 else c2 in
+                      (* h' is the name for the new intro *)
+		      let h' = next_global_ident hyp_radix avoid in
+		      let cont_tac =
+                        chain_tactics 
+			  [make_named_intro h']
+			  (f 
+			     (* h' should not be used again *)
+			     (h'::avoid)
+			     (* the disjunct itself can be discarded *)
+			     (h::clear_names) false (Some h')
+                             (kind_of_term cont_body) path) in
+		      let snd_tac = 
+			chain_tactics
+			   [make_named_intro h']
+			   (make_clears (h::clear_names)) in
+		      let tacs1 = 
+			if a = 1 then
+			  [cont_tac; snd_tac]
+		      	else
+			  [snd_tac; cont_tac] in
+		      tacs1@(auxiliary_goals (h::clear_names)
+				   false dummy_id nprems [])))
+    | (str_list, int_list, nprems, c, []) 
+        when  (check_apply c (mk_db_indices int_list nprems)) &
+              (match c with Prod(_,_,_) -> false
+              |  _ -> true) &
+              (List.length int_list) + nprems > 0 ->
+          Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names)
+    | _ -> None)
+  | _ -> None;;
+      
+
+let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2;
+                      forall_elim; imply_intro3; imply_elim1; imply_elim2;
+		      and_intro; or_intro; not_intro; ex_intro; exT_intro];;
+
+
+let try_trace = ref true;;
+
+let traced_try (f1:tactic) g =
+    try (try_trace := true; tclPROGRESS f1 g)
+    with e when Logic.catchable_exception e ->
+      (try_trace := false; tclIDTAC g);;
+
+let traced_try_entry = function
+     [Tacexp t] ->
+           traced_try (Tacinterp.interp t)
+  |  _ -> failwith "traced_try_entry received wrong arguments";;
+
+
+(* When the recursive descent along the path is over, one includes the
+   command requested by the point-and-shoot strategy.  Default is
+   Try Assumption--Try Exact.  *)
+
+
+let default_ast optname constr path = PbpThen [PbpTryAssumption optname]
+
+(* This is the main proof by pointing function. *)
+(* avoid: les noms a ne pas utiliser *)
+(* final_cmd: la fonction appelee par defaut *)
+(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *)
+
+let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path =
+  let rec try_all_rules rl =
+      match rl with 
+         f::tl ->
+           (match f (avoid, clear_names, clear_flag,
+                     opt_name, constr, path, pbpt final_cmd) with
+              Some(ast) -> ast
+            | None -> try_all_rules tl)
+      |	 [] -> make_final_cmd final_cmd opt_name clear_names constr path
+  in try_all_rules (!pbp_rules);;
+
+(* these are the optimisation functions. *)
+(* This function takes care of flattening successive then commands. *)
+
+
+(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy
+    that t is some [PbpAtom t] *)
+
+(* This optimization function takes care of compacting successive Intro commands
+   together. *)
+
+let rec group_intros names = function
+    [] -> (match names with
+        [] -> []
+      | l -> [PbpIntros l])
+  | (PbpIntros ids)::others -> group_intros (names@ids) others
+  | t1::others ->
+      (match names with
+	  [] -> t1::(group_intros [] others)
+	| l -> (PbpIntros l)::t1::(group_intros [] others))
+
+let rec optim2 = function
+  | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2)
+  | PbpThen tl -> PbpThen (group_intros [] tl)
+
+
+let rec cleanup_clears str_list = function
+    [] -> []
+  | x::tail ->
+      if List.mem x str_list then cleanup_clears str_list tail
+      else x::(cleanup_clears str_list tail);;
+
+(* This function takes care of compacting instanciations of universal
+   quantifications. *)
+
+let rec optim3_aux str_list = function
+    (PbpGeneralize (h,l1))::
+    (PbpIntros [IntroIdentifier s])::(PbpGeneralize (h',l2))::others
+      when s=h' ->
+      optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others)
+  | (PbpTryClear names)::other ->
+      (match cleanup_clears str_list names with
+	  [] -> other
+	| l -> (PbpTryClear l)::other)
+  | a::l -> a::(optim3_aux str_list l) 
+  | [] -> [];;
+
+let rec optim3 str_list = function
+    PbpThens (tl1, tl2) ->
+      PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2)
+  | PbpThen tl -> PbpThen (optim3_aux str_list tl)
+
+let optim x = make_pbp_tactic (optim3 [] (optim2 x));;
+
+(* TODO
+add_tactic "Traced_Try" traced_try_entry;;
+*)
+
+let rec tactic_args_to_ints = function
+    [] -> []
+  | (Integer n)::l -> n::(tactic_args_to_ints l)
+  | _ -> failwith "expecting only numbers";;
+
+(*
+let pbp_tac display_function = function 
+            (Identifier a)::l -> 
+                 (function g ->
+                    let str = (string_of_id a) in
+		    let (ou,tstr) = (get_hyp_by_name g str) in
+		    let exp_ast =
+		      pbpt default_ast
+		        (match ou with
+			       "hyp" ->(pf_ids_of_hyps g)
+			       |_ -> (a::(pf_ids_of_hyps g)))
+                        []
+			false
+			(Some str)
+			(kind_of_term tstr)
+                        (tactic_args_to_ints l) in
+                    (display_function (optim exp_ast);
+                        tclIDTAC g))
+          | ((Integer n)::_) as l -> 
+                 (function g ->
+                    let exp_ast =
+                       (pbpt default_ast (pf_ids_of_hyps g) [] false
+                          None (kind_of_term (pf_concl g))
+			  (tactic_args_to_ints l)) in
+                     (display_function (optim exp_ast);
+                       tclIDTAC g))
+          | [] -> (function g ->
+                     (display_function (default_ast None (pf_concl g) []);
+                      tclIDTAC g))
+          |  _ -> failwith "expecting other arguments";;
+
+
+*)
+let pbp_tac display_function idopt nl =
+  match idopt with
+    | Some str ->
+        (function g ->
+	  let (ou,tstr) = (get_hyp_by_name g str) in
+	  let exp_ast =
+	    pbpt default_ast
+	      (match ou with
+		  "hyp" ->(pf_ids_of_hyps g)
+		|_ -> (str::(pf_ids_of_hyps g)))
+              []
+	      false
+	      (Some str)
+	      (kind_of_term tstr)
+              nl in
+              (display_function (optim exp_ast); tclIDTAC g))
+    | None ->
+	if nl <> [] then
+          (function g ->
+            let exp_ast =
+              (pbpt default_ast (pf_ids_of_hyps g) [] false
+		None (kind_of_term (pf_concl g)) nl) in
+            (display_function (optim exp_ast); tclIDTAC g))
+	else
+          (function g ->
+            (display_function
+	       (make_pbp_tactic (default_ast None (pf_concl g) []));
+            tclIDTAC g));;
+
+
diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli
new file mode 100644
index 00000000..43ec1274
--- /dev/null
+++ b/contrib/interface/pbp.mli
@@ -0,0 +1,4 @@
+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;;
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
new file mode 100644
index 00000000..5b265ec8
--- /dev/null
+++ b/contrib/interface/showproof.ml
@@ -0,0 +1,1899 @@
+(*
+#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
+open Coqast;;
+*)
+open Environ
+open Evd
+open Names
+open Nameops
+open Libnames
+open Term
+open Termops
+open Util
+open Proof_type
+open Coqast
+open Pfedit
+open Translate
+open Term
+open Reductionops
+open Clenv
+open Typing
+open Inductive
+open Inductiveops
+open Vernacinterp
+open Declarations
+open Showproof_ct
+open Proof_trees
+open Sign
+open Pp
+open Printer
+open Rawterm
+open Tacexpr
+open Genarg
+(*****************************************************************************)
+(*
+   Arbre de preuve maison:
+   
+*)
+
+(* hypotheses *)
+
+type nhyp = {hyp_name : identifier;
+             hyp_type : Term.constr;
+             hyp_full_type: Term.constr}
+;;
+
+type ntactic = tactic_expr
+;;
+
+type nproof =
+    Notproved
+  | Proof of ntactic * (ntree list)
+
+and ngoal=
+     {newhyp : nhyp list;
+      t_concl : Term.constr;
+      t_full_concl: Term.constr;
+      t_full_env: Sign.named_context}
+and ntree=
+      {t_info:string;
+	t_goal:ngoal;
+       	t_proof : nproof}
+;;
+
+
+let hyps {t_info=info;
+	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	 t_proof=p} = lh
+;;
+
+let concl {t_info=info;
+	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	 t_proof=p} = g
+;;
+
+let proof {t_info=info;
+	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	 t_proof=p} = p
+;;
+let g_env {t_info=info;
+	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	 t_proof=p} = ge
+;;
+let sub_ntrees t =
+  match (proof t) with
+    Notproved -> []
+  | Proof (_,l) -> l
+;;
+
+let tactic t =
+  match (proof t) with
+    Notproved -> failwith "no tactic applied"
+  | Proof (t,_) -> t
+;;
+
+
+(* 
+un arbre est clos s'il ne contient pas de sous-but non prouves,
+ou bien s'il a un cousin gauche qui n'est pas clos 
+ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but.
+*)
+let update_closed nt =
+  let found_not_closed=ref false in
+  let rec update {t_info=b; t_goal=g; t_proof =p} =
+    if !found_not_closed
+    then  {t_info="to_prove"; t_goal=g; t_proof =p}
+    else
+      match p with
+      	Notproved -> found_not_closed:=true;
+	  {t_info="not_proved"; t_goal=g; t_proof =p}
+      | Proof(tac,lt) ->
+	  let lt1=List.map update lt in
+	  let b=ref "proved" in
+	  (List.iter
+	     (fun x ->
+	       if x.t_info ="not_proved" then b:="not_proved") lt1;
+	   {t_info=(!b);
+	     t_goal=g;
+             t_proof=Proof(tac,lt1)})
+  in update nt
+    ;;
+    
+      
+(*
+    type complet avec les hypotheses.
+*)
+
+let long_type_hyp lh t=
+   let t=ref t in
+   List.iter (fun (n,th) ->
+         let ni = match n with Name ni -> ni | _ -> assert false in
+         t:= mkProd(n,th,subst_term (mkVar ni) !t))
+       (List.rev lh);
+   !t
+;;
+
+(* let long_type_hyp x y = y;; *)
+
+(* Expansion des tactikelles *)
+
+let seq_to_lnhyp sign sign' cl =
+      let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in
+      let nh=List.map (fun (id,c,ty) -> 
+             {hyp_name=id;
+              hyp_type=ty;
+              hyp_full_type=
+                let res= long_type_hyp !lh ty in
+                lh:=(!lh)@[(Name id,ty)];
+                res})
+              sign'
+      in
+      {newhyp=nh;
+       t_concl=cl;
+       t_full_concl=long_type_hyp !lh cl;
+       t_full_env = sign@sign'}
+;;
+
+
+let rule_is_complex r =
+   match r with
+      Tactic (TacArg (Tacexp t),_) -> true  
+   |  Tactic (TacAtom (_,TacAuto _), _) -> true
+   |  Tactic (TacAtom (_,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
+     | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h)
+     | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
+   if rule_is_complex r
+   then (match rt with
+           TacArg (Tacexp _) as t -> t
+          | _ -> assert false)
+
+   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  *)
+
+
+let fill_unproved nt l =
+  let lnt = ref l in
+  let rec fill nt =
+    let {t_goal=g;t_proof=p}=nt in
+       match p with
+        Notproved -> let p=List.hd (!lnt) in
+                     lnt:=List.tl (!lnt);
+                     {t_info="to_prove";t_goal=g;t_proof=p}
+       |Proof(tac,lt) ->
+          {t_info="to_prove";t_goal=g;
+           t_proof=Proof(tac,List.map fill lt)}
+  in fill nt
+;;
+(* Differences entre signatures *)
+
+let new_sign osign sign =
+    let res=ref [] in
+    List.iter (fun (id,c,ty) ->
+		   try (let  (_,_,ty1)= (lookup_named id osign) in
+			())
+		   with Not_found -> res:=(id,c,ty)::(!res))
+              sign;
+    !res
+;;
+
+let old_sign osign sign =
+    let res=ref [] in
+    List.iter (fun (id,c,ty) ->
+		   try (let (_,_,ty1) = (lookup_named id osign) in
+			if ty1 = ty then res:=(id,c,ty)::(!res))
+		   with Not_found -> ())
+              sign;
+    !res
+;;
+
+(* convertit l'arbre de preuve courant en ntree *)
+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 nsign = new_sign osign sign in 
+    let oldsign = old_sign osign sign in 
+    match pf.ref with
+      
+      None -> {t_info="to_prove";
+	      	t_goal=(seq_to_lnhyp oldsign nsign cl);
+              	t_proof=Notproved}
+    | Some(r,spfl) ->
+      	if rule_is_complex r
+      	then (
+	  let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in
+          let ntree= fill_unproved p1 
+              (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))
+      	else
+	  {t_info="to_prove";
+	    t_goal=(seq_to_lnhyp oldsign nsign cl);
+       	    t_proof=(Proof (rule_to_ntactic r,
+			      List.map (fun x -> to_nproof_rec sigma sign x) spfl))}
+  in update_closed (to_nproof_rec sigma osign pf)
+    ;;
+
+(* 
+  recupere l'arbre de preuve courant.
+*)
+
+let get_nproof () =
+  to_nproof (Global.env()) []
+            (Tacmach.proof_of_pftreestate (get_pftreestate()))
+;;
+
+    
+(*****************************************************************************)
+(*
+   Pprinter
+*)
+
+let pr_void () = sphs "";;
+
+let list_rem l = match l with [] -> [] |x::l1->l1;;
+
+(* liste de chaines *)
+let prls l = 
+   let res = ref (sps (List.hd l)) in
+   List.iter (fun s -> 
+     res:= sphv [ !res; spb; sps s]) (list_rem l);
+   !res
+;;
+
+let prphrases f l = 
+   spv (List.map (fun s -> sphv [f s; sps ","]) l)
+;;
+
+(* indentation *)
+let spi = spnb 3;;
+
+(* en colonne *)
+let prl f l = 
+   if l=[] then spe else spv (List.map f l);;
+(*en colonne,  avec indentation *)
+let prli f l =  
+   if l=[] then spe else sph [spi; spv (List.map f l)];;
+
+(* 
+  Langues.
+*)
+
+let rand l =
+  List.nth l (Random.int (List.length l))
+;;
+
+type natural_languages = French | English;;
+let natural_language = ref French;;
+
+(*****************************************************************************)
+(*
+   Les liens html pour proof-by-pointing
+*)
+
+(* le path du but en cours. *)
+
+let path=ref[1];;
+
+let ftag_apply =ref (fun (n:string) t -> spt t);;
+
+let ftag_case =ref (fun n -> sps n);;
+
+let ftag_elim =ref (fun n ->  sps n);;
+
+let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);;
+
+let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);;
+
+let ftag_uselemma =ref (fun h t ->
+  let intro = match !natural_language with
+    French -> "par"
+  | English -> "by"
+  in
+  spuselemma intro h t);;
+
+let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);;
+
+let tag_apply = !ftag_apply;;
+
+let tag_case = !ftag_case;;
+
+let tag_elim = !ftag_elim;;
+
+let tag_uselemma = !ftag_uselemma;;
+
+let tag_hyp = !ftag_hyp;;
+
+let tag_hypt = !ftag_hypt;;
+
+let tag_toprove = !ftag_toprove;;
+
+(*****************************************************************************)
+
+(* pluriel *)
+let txtn n s =
+  if n=1 then s
+  else match s with
+    |"un" -> "des"
+    |"a" -> ""
+    |"an" -> ""
+    |"une" -> "des"
+    |"Soit" -> "Soient"
+    |"Let" -> "Let"
+    | s -> s^"s"
+;;
+
+let _et () =  match !natural_language with
+    French -> sps "et"
+| English -> sps "and"
+;;
+
+let name_count = ref 0;;
+let new_name () =
+  name_count:=(!name_count)+1;
+  string_of_int !name_count
+;;
+
+let enumerate f ln =
+  match ln with
+    [] -> []
+  | [x] -> [f x]
+  |ln -> 
+  let rec enum_rec f ln = 
+     (match ln with 
+       [x;y] -> [f x; spb; sph [_et ();spb;f y]]
+      |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l)
+      | _ -> assert false)
+  in enum_rec 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
+    French ->
+      sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
+            @[spb; prls [txtn nh "une";txtn nh "proposition"]])
+| English ->
+      sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln)
+            @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]])
+;;
+
+let on_a ()=  match !natural_language with
+  French -> rand ["on a "]
+| English ->rand ["we have "]
+;;
+
+let bon_a ()=  match !natural_language with
+  French -> rand ["On a "]
+| English ->rand ["We have "]
+;;
+
+let soit_X_un_element_de_T nh ln t =  match !natural_language with
+  French ->
+    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
+          @[spb; prls [txtn nh "un";txtn nh "élément";"de"]]
+          @[spb; spt t])
+| English ->
+    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
+          @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]]
+          @[spb; spt t])
+;;
+
+let soit_F_une_fonction_de_type_T nh ln t =  match !natural_language with
+  French ->
+    sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln)
+          @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]]
+          @[spb; spt t])
+| English ->
+    sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln)
+          @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]]
+          @[spb; spt t])
+;;
+
+
+let telle_que nh =  match !natural_language with
+    French -> [prls [" ";txtn nh "telle";"que";" "]]
+| English -> [prls [" "; "such";"that";" "]]
+;;
+
+let tel_que nh =  match !natural_language with
+    French -> [prls [" ";txtn nh "tel";"que";" "]]
+| English -> [prls [" ";"such";"that";" "]]
+;;
+
+let supposons () =  match !natural_language with
+    French -> "Supposons "
+|  English -> "Suppose "
+;;
+
+let cas () =  match !natural_language with
+    French -> "Cas"
+|  English -> "Case"
+;;
+
+let donnons_une_proposition () =  match !natural_language with
+    French -> sph[ (prls ["Donnons";"une";"proposition"])]
+|  English -> sph[ (prls ["Let us give";"a";"proposition"])]
+;;
+
+let montrons g =  match !natural_language with
+    French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]);
+		   spb; spt g; sps ". "]
+|  English -> sph[ sps (rand ["Let us";"Now"]);spb;
+		   sps (rand ["prove";"show"]);
+		   spb; spt g; sps ". "]
+;;
+
+let calculons_un_element_de g =  match !natural_language with
+    French -> sph[ (prls ["Calculons";"un";"élément";"de"]);
+		   spb; spt g; sps ". "]
+|  English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]);
+		   spb; spt g; sps ". "]
+;;
+
+let calculons_une_fonction_de_type g =  match !natural_language with
+    French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]);
+                spb; spt g; sps ". "]
+|  English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]);
+                spb; spt g; sps ". "];;
+
+let en_simplifiant_on_obtient g =  match !natural_language with
+    French ->
+      sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"];
+		     rand ["on doit";"il reste à"];
+		     rand ["prouver";"montrer";"démontrer"]]);
+		     spb; spt g; sps ". "]
+|  English ->
+      sphv [ (prls [rand ["After simplification,"; "Simplifying,"];
+		     rand ["we must";"it remains to"];
+		     rand ["prove";"show"]]);
+		     spb; spt g; sps ". "] ;;
+
+let on_obtient g =  match !natural_language with
+  French -> sph[ (prls [rand ["on doit";"il reste à"];
+			 rand ["prouver";"montrer";"démontrer"]]);
+                 spb; spt g; sps ". "]
+|  English ->sph[ (prls [rand ["we must";"it remains to"];
+		     rand ["prove";"show"]]);
+                  spb; spt g; sps ". "]
+;;
+
+let reste_a_montrer g =  match !natural_language with
+    French -> sph[ (prls ["Reste";"à";
+			   rand ["prouver";"montrer";"démontrer"]]);
+                spb; spt g; sps ". "]
+|  English -> sph[ (prls ["It remains";"to";
+			   rand ["prove";"show"]]);
+                spb; spt g; sps ". "] 
+;;
+
+let discutons_avec_A type_arg  =  match !natural_language with
+    French -> sphv [sps "Discutons"; spb; sps "avec"; spb;
+				   spt type_arg; sps ":"] 
+|  English -> sphv [sps "Let us discuss"; spb; sps "with"; spb;
+				   spt type_arg; sps ":"] 
+;;
+
+let utilisons_A arg1  =  match !natural_language with
+    French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]);
+		     spb; spt arg1; sps ":"] 
+|  English -> sphv [sps (rand ["Let us use";"With";"With the help of"]);
+		     spb; spt arg1; sps ":"] 
+;;
+
+let selon_les_valeurs_de_A arg1  =  match !natural_language with
+    French -> sphv [  (prls ["Selon";"les";"valeurs";"de"]);
+                      spb; spt arg1; sps ":"] 
+|  English -> sphv [  (prls ["According";"values";"of"]);
+                      spb; spt arg1; sps ":"] 
+;;
+
+let de_A_on_a arg1  =  match !natural_language with
+    French -> sphv [  sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb;
+		      sps (rand ["on a:";"on déduit:";"on obtient:"])]
+|  English -> sphv [  sps (rand ["From";"With";"Thanks to"]); spb;
+		     spt arg1; spb;
+		      sps (rand ["we have:";"we deduce:";"we obtain:"])]
+;;
+
+
+let procedons_par_recurrence_sur_A arg1  =  match !natural_language with
+    French ->  sphv [  (prls ["Procédons";"par";"récurrence";"sur"]);
+			  spb; spt arg1; sps ":"]
+|  English -> sphv [  (prls ["By";"induction";"on"]);
+			  spb; spt arg1; sps ":"]
+;;
+
+
+let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A 
+  nfun tfun narg =  match !natural_language with
+    French ->  sphv [  
+                    sphv [ prls ["Calculons";"la";"fonction"];
+                     spb; sps (string_of_id nfun);spb;
+                     prls ["de";"type"];
+                     spb; spt tfun;spb;
+                     prls ["par";"récurrence";"sur";"son";"argument"];
+                     spb; sps (string_of_int narg); sps ":"]
+                 ]
+|  English ->  sphv [  
+                    sphv [ prls ["Let us compute";"the";"function"];
+                     spb; sps (string_of_id nfun);spb;
+                     prls ["of";"type"];
+                     spb; spt tfun;spb;
+                     prls ["by";"induction";"on";"its";"argument"];
+                     spb; sps (string_of_int narg); sps ":"]
+                 ]
+
+;;
+let pour_montrer_G_la_valeur_recherchee_est_A g arg1  =
+  match !natural_language with
+    French ->  sph [sps "Pour";spb;sps "montrer"; spt g; spb;
+		     sps ","; spb; sps "choisissons";spb;
+		     spt arg1;sps ". " ]
+|  English ->  sph [sps "In order to";spb;sps "show"; spt g; spb;
+		     sps ","; spb; sps "let us choose";spb;
+		     spt arg1;sps ". " ]
+;;
+
+let on_se_sert_de_A   arg1  =  match !natural_language with
+    French ->  sph [sps "On se sert de";spb ;spt arg1;sps ":" ]
+|  English ->  sph [sps "We use";spb ;spt arg1;sps ":" ]
+;;
+
+
+let d_ou_A g  =  match !natural_language with
+    French ->  sph [spi; sps "d'où";spb ;spt g;sps ". " ]
+|  English -> sph [spi; sps "then";spb ;spt g;sps ". " ]
+;;
+
+
+let coq_le_demontre_seul ()  =  match !natural_language with
+    French ->   rand [prls ["Coq";"le";"démontre"; "seul."];
+		       sps "Fastoche.";
+		     sps "Trop cool"]
+|  English -> 	rand [prls ["Coq";"shows";"it"; "alone."];
+		       sps "Fingers in the nose."]	      
+;;
+
+let de_A_on_deduit_donc_B arg g  =  match !natural_language with
+    French -> sph
+             [  sps "De"; spb; spt arg; spb; sps "on";spb;
+                sps "déduit";spb; sps "donc";spb;  spt g ]
+|  English -> sph
+             [  sps "From"; spb; spt arg; spb; sps "we";spb;
+                sps "deduce";spb; sps "then";spb;  spt g ]
+;;
+
+let _A_est_immediat_par_B g arg  =  match !natural_language with
+    French -> sph [  spt g;  spb; (prls ["est";"immédiat";"par"]);
+                     spb;  spt arg ] 
+|  English -> sph [  spt g;  spb; (prls ["is";"immediate";"from"]);
+                     spb;  spt arg ] 
+;;
+
+let le_resultat_est arg  =  match !natural_language with
+    French -> sph [  (prls ["le";"résultat";"est"]);
+                    spb; spt arg ] 
+|  English -> sph [  (prls ["the";"result";"is"]);
+                    spb; spt arg ];;
+
+let on_applique_la_tactique tactic tac =  match !natural_language with
+  French -> sphv 
+      [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac]
+|  English -> sphv 
+      [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac]
+;;
+
+let de_A_il_vient_B arg g  =  match !natural_language with
+    French -> sph
+             [  sps "De"; spb; spt arg; spb; 
+               sps "il";spb; sps "vient";spb; spt g; sps ". " ] 
+|  English -> sph
+             [  sps "From"; spb; spt arg; spb; 
+               sps "it";spb; sps "comes";spb; spt g; sps ". " ] 
+;;
+
+let ce_qui_est_trivial ()  =  match !natural_language with
+    French -> sps "Trivial."
+|  English -> sps "Trivial."
+;;
+
+let en_utilisant_l_egalite_A arg  =  match !natural_language with
+    French -> sphv [  sps "En"; spb;sps "utilisant"; spb;
+                   sps "l'egalite"; spb; spt arg; sps ","
+                  ]
+|  English -> sphv [  sps "Using"; spb;
+                   sps "the equality"; spb; spt arg; sps ","
+                  ]
+;;
+
+let simplifions_H_T hyp thyp =  match !natural_language with
+    French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:";
+		     spb;spt thyp;sps "."]
+|  English ->  sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:";
+		     spb;spt thyp;sps "."]
+;;
+
+let grace_a_A_il_suffit_de_montrer_LA arg lg=
+  match !natural_language with
+    French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb;
+		      spt arg;sps ",";spb;
+		     sps "il suffit";spb; sps "de"; spb;
+		      sps (rand["prouver";"montrer";"démontrer"]); spb]
+		     @[spv (enumerate (fun x->x) lg)])
+|  English -> sphv ([sps (rand ["Thanks to";"With"]);spb;
+		      spt arg;sps ",";spb;
+		     sps "it suffices";spb; sps "to"; spb;
+		      sps (rand["prove";"show"]); spb]
+		     @[spv (enumerate (fun x->x) lg)])
+;;
+let reste_a_montrer_LA lg=
+  match !natural_language with
+    French -> sphv ([ sps "Il reste";spb; sps "à"; spb;
+		      sps (rand["prouver";"montrer";"démontrer"]); spb]
+		     @[spv (enumerate (fun x->x) lg)])
+|  English -> sphv ([ sps "It remains";spb; sps "to"; spb;
+		      sps (rand["prove";"show"]); spb]
+		     @[spv (enumerate (fun x->x) lg)])
+;;
+(*****************************************************************************)
+(*
+  Traduction des hypothèses.
+*)
+
+type n_sort=
+      Nprop
+    | Nformula
+    | Ntype
+    | Nfunction
+;;
+
+   
+let sort_of_type t ts =
+   let t=(strip_outer_cast t) in
+   if is_Prop t
+   then Nprop
+   else 
+       match ts with
+         Prop(Null) -> Nformula
+        |_ -> (match (kind_of_term t) with
+                Prod(_,_,_) -> Nfunction
+               |_ -> Ntype)
+;;
+
+let adrel (x,t) e =
+    match x with 
+      Name(xid) -> Environ.push_rel (x,None,t) e
+    | Anonymous -> Environ.push_rel (x,None,t) e
+
+let rec nsortrec vl x = 
+     match (kind_of_term x) with
+     Prod(n,t,c)->
+        let vl = (adrel (n,t) vl) in nsortrec vl c
+   | Lambda(n,t,c) ->
+        let vl = (adrel (n,t) vl) in nsortrec vl c
+   | App(f,args) -> nsortrec vl f
+   | Sort(Prop(Null)) -> Prop(Null)
+   | Sort(c) -> c
+   | Ind(ind) ->
+          let (mib,mip) = lookup_mind_specif vl ind in
+          mip.mind_sort
+   | 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
+   | _ -> nsortrec vl (type_of vl Evd.empty x)
+;;
+let nsort x =
+    nsortrec  (Global.env()) (strip_outer_cast x)
+;;
+
+let sort_of_hyp h = 
+  (sort_of_type h.hyp_type (nsort h.hyp_full_type))
+;;
+
+(* grouper les hypotheses successives de meme type, ou logiques.
+   donne une liste de liste *)
+let rec group_lhyp lh =
+    match lh with
+     [] -> []
+    |[h] -> [[h]]
+    |h::lh ->
+      match group_lhyp lh with
+       (h1::lh1)::lh2 -> 
+        if h.hyp_type=h1.hyp_type
+          || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula)
+        then (h::(h1::lh1))::lh2
+        else [h]::((h1::lh1)::lh2)
+     |_-> assert false
+;;
+	
+(* ln noms des hypotheses, lt leurs types *)
+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
+  match sort with
+    Nprop -> soit_A_une_proposition nh ln t
+  | Ntype -> soit_X_un_element_de_T nh ln t
+  | Nfunction -> soit_F_une_fonction_de_type_T nh ln t
+  | Nformula -> 
+      sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t)
+			    (List.combine ln lt)))
+;;
+
+(* Cas d'une hypothese *)
+let natural_hyp h = 
+   let ns= string_of_id h.hyp_name in
+   let t=h.hyp_type in
+   let ts= (nsort h.hyp_full_type) in
+   natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ())
+;;
+
+let rec pr_ghyp lh intro=
+     match lh with
+       [] -> []
+     | [(sort,ln,t)]->
+         (match sort with
+           Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "]
+         | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "])
+     | (sort,ln,t)::lh  ->
+       let hp= 
+        ([natural_ghyp(sort,ln,t) intro]
+         @(match lh with
+           [] -> [sps ". "]
+          |(sort1,ln1,t1)::lh1  ->
+             match sort1 with
+               Nformula -> 
+                 (let nh=List.length ln in
+                     match sort with
+                   Nprop -> telle_que nh 
+                  |Nfunction -> telle_que nh 
+                  |Ntype -> tel_que nh 
+                  |Nformula -> [sps ". "])
+             | _ -> [sps ". "])) in
+        (sphv hp)::(pr_ghyp lh "")
+;;
+
+(* traduction d'une liste d'hypotheses groupees. *)
+let prnatural_ghyp llh intro=
+  if llh=[]
+  then spe
+  else
+    sphv (pr_ghyp (List.map
+		     (fun lh ->
+		       let h=(List.hd lh) in
+		       let sh = sort_of_hyp h in
+		       let lhname = (List.map (fun h ->
+			 string_of_id h.hyp_name) lh) in
+		       let lhtype = (List.map (fun h -> h.hyp_type) lh) in
+		       (sh,lhname,lhtype))
+		     llh) intro)
+;;
+
+
+(*****************************************************************************)
+(*
+    Liste des hypotheses.
+*)
+type type_info_subgoals_hyp=
+    All_subgoals_hyp
+  | Reduce_hyp
+  | No_subgoals_hyp
+  | Case_subgoals_hyp of string (* word for introduction *)
+	* Term.constr (* variable *)
+        * string (* constructor *)
+        * int (* arity *)
+        * int (* number of constructors *)
+  | Case_prop_subgoals_hyp of string (* word for introduction *)
+	* Term.constr (* variable *)
+        * int (* index of constructor *)
+        * int (* arity *)
+        * int (* number of constructors *)
+  | Elim_subgoals_hyp of Term.constr (* variable *)
+        * string (* constructor *)
+        * int (* arity *)
+        * (string list) (* rec hyp *)
+        * int (* number of constructors *)
+  | Elim_prop_subgoals_hyp of Term.constr (* variable *)
+        * int (* index of constructor *)
+        * int (* arity *)
+        * (string list) (* rec hyp *)
+        * int (* number of constructors *)
+;;
+let rec nrem l n =
+  if n<=0 then l else nrem (list_rem l) (n-1)
+;;
+
+let rec nhd l n =
+  if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1))
+;;
+
+let par_hypothese_de_recurrence () =  match !natural_language with
+    French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])]
+| English -> sphv [(prls ["by";"induction";"hypothesis";","])]
+;;
+
+let  natural_lhyp lh hi =
+  match hi with
+    All_subgoals_hyp -> 
+        ( match lh with
+          [] -> spe
+        |_-> prnatural_ghyp (group_lhyp lh) (supposons ()))
+  | Reduce_hyp ->
+      (match lh with
+	[h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type
+      |	_-> spe)
+  | No_subgoals_hyp -> spe
+  |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *)
+      let s=ref c in
+      for i=1 to a do
+        let nh=(List.nth lh (i-1)) in
+        s:=(!s)^" "^(string_of_id nh.hyp_name);
+      done;
+      if a>0 then s:="("^(!s)^")";
+      sphv [  (if ncase>1
+                     then sph[ sps ("-"^(cas ()));spb]
+                     else spe);
+                    (* spt var;sps "="; *) sps !s; sps ":";
+           (prphrases (natural_hyp) (nrem lh a))]
+  |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) ->
+      prnatural_ghyp (group_lhyp lh) sintro
+  |Elim_subgoals_hyp (var,c,a,lhci,ncase) ->
+      let nlh = List.length lh in
+      let nlhci = List.length lhci in
+      let lh0 = ref [] in
+      for i=1 to (nlh-nlhci) do
+         lh0:=(!lh0)@[List.nth lh (i-1)];
+      done;
+      let lh=nrem lh (nlh-nlhci) in
+      let s=ref c in
+      let lh1=ref [] in
+      for i=1 to nlhci do
+        let targ=(List.nth lhci (i-1))in
+        let nh=(List.nth lh (i-1)) in
+        if targ="arg" || targ="argrec" 
+        then
+            (s:=(!s)^" "^(string_of_id nh.hyp_name);
+	     lh0:=(!lh0)@[nh])
+        else lh1:=(!lh1)@[nh];
+      done;
+      let introhyprec=
+          (if (!lh1)=[] then spe 
+           else   par_hypothese_de_recurrence () )
+      in          
+      if a>0 then s:="("^(!s)^")";
+      spv [sphv [(if ncase>1
+                     then sph[ sps ("-"^(cas ()));spb]
+                     else spe);
+                     sps !s; sps ":"]; 
+           prnatural_ghyp (group_lhyp !lh0) (supposons ());
+           introhyprec;
+           prl (natural_hyp) !lh1]
+  |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) ->
+      sphv [  (if ncase>1
+                     then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c);
+                             sps ":";spb]
+                     else spe);
+           (prphrases (natural_hyp) lh )]
+
+;;
+
+(*****************************************************************************)
+(*
+    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"
+  | _ -> failwith "TODO"
+;;
+
+(*
+let arg1_tactic tac =
+  match tac with
+    (Node(_,"Interp",
+		(Node(_,_,
+		      (Node(_,_,x::_))::_))::_))::_ ->x
+  | (Node(_,_,x::_))::_ -> x
+  | x::_ -> x
+  | _ -> assert false
+;;
+*)
+
+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 id_of_command x =
+  match x with
+      Node(_,_,Node(_,_,y::_)::_) ->  y
+     |_ -> assert false
+;;
+type type_info_subgoals =
+    {ihsg: type_info_subgoals_hyp;
+     isgintro : string}
+;;
+
+let rec show_goal lh ig g gs =
+  match ig with
+    "intros" ->
+      if lh = []
+      then spe
+      else show_goal lh "standard" g gs 
+  |"standard" ->
+      (match (sort_of_type g gs) with
+        Nprop -> donnons_une_proposition ()
+      | Nformula -> montrons g
+      | Ntype -> calculons_un_element_de g
+      | Nfunction ->calculons_une_fonction_de_type g)
+  | "apply" -> show_goal lh "" g gs
+  | "simpl" ->en_simplifiant_on_obtient g
+  | "rewrite" -> on_obtient g 
+  | "equality" -> reste_a_montrer g
+  | "trivial_equality" -> reste_a_montrer g
+  | "" -> spe
+  |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ]
+;;
+
+let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s =
+  if ig="" && lh = []
+  then spe
+  else sphv [  show_goal lh ig g gs; sps s]
+;;
+
+let imaginez_une_preuve_de () =  match !natural_language with
+    French -> "Imaginez une preuve de"
+| English -> "Imagine a proof of"
+;;
+
+let donnez_un_element_de () =  match !natural_language with
+    French -> "Donnez un element de"
+| English -> "Give an element of";;
+
+let intro_not_proved_goal gs =
+   match gs with
+     Prop(Null) -> imaginez_une_preuve_de ()
+    |_ -> donnez_un_element_de ()
+;;
+
+let first_name_hyp_of_ntree {t_goal={newhyp=lh}}=
+  match lh with
+   {hyp_name=n}::_ -> n
+  | _ -> assert false
+;;
+
+let rec find_type x t=
+    match (kind_of_term (strip_outer_cast t)) with 
+      Prod(y,ty,t) ->
+	(match y with
+	  Name y -> 
+            if x=(string_of_id y) then ty
+            else find_type x t
+	| _ -> find_type x t)
+     |_-> assert false 
+;;
+
+(***********************************************************************
+Traitement des égalités
+*)
+(*
+let is_equality e =
+   match  (kind_of_term e) with
+     AppL args ->
+       (match (kind_of_term args.(0)) with
+	 Const (c,_) ->
+	   (match (string_of_sp c) with
+	     "Equal" -> true
+           | "eq" -> true
+	   | "eqT" -> true
+	   | "identityT" -> true
+	   | _ -> false)
+       | _ -> false)
+   | _ -> false
+;;
+*)
+
+let is_equality e =
+  let e= (strip_outer_cast e) in
+   match  (kind_of_term e) with
+     App (f,args) -> (Array.length args) >= 3
+   | _ -> false
+;;
+
+let terms_of_equality e =
+  let e= (strip_outer_cast e) in
+  match  (kind_of_term e) with
+     App (f,args) -> (args.(1) , args.(2))
+    | _ -> assert false
+;;
+
+let eq_term = eq_constr;;
+
+let is_equality_tac = function
+  | TacAtom (_,
+      (TacExtend
+	(_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc"
+	 |"ERewriteParallel"|"ERewriteNormal"
+	 |"RewriteLR"|"RewriteRL"|"Replace"),_)
+      | TacReduce _
+      | TacSymmetry _ | TacReflexivity
+      | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true
+  | _ -> false
+
+let equalities_ntree ig ntree =
+  let rec equalities_ntree ig ntree =
+  if not (is_equality (concl ntree)) 
+  then []
+  else
+    match (proof ntree) with
+      Notproved ->  [(ig,ntree)]
+    | Proof (tac,ltree) ->
+	if is_equality_tac tac
+      	then (match ltree with
+          [] ->  [(ig,ntree)]
+	| t::_ -> let res=(equalities_ntree ig t) in
+	          if eq_term (concl ntree) (concl t)
+		  then res
+		  else (ig,ntree)::res)
+	else  [(ig,ntree)]
+  in 
+  equalities_ntree ig ntree 
+;;
+
+let remove_seq_of_terms l =
+  let rec remove_seq_of_terms l =    match l with
+    a::b::l -> if (eq_term (fst a) (fst b))
+    then remove_seq_of_terms (b::l)
+    else a::(remove_seq_of_terms (b::l))
+  | _ -> l
+  in remove_seq_of_terms l
+;;
+
+let  list_to_eq l o=
+  let switch = fun h h' -> (if o then h else h') in
+   match l with
+      [a] -> spt (fst a) 
+   |  (a,h)::(b,h')::l ->
+       let rec list_to_eq h l =
+	 match l with
+	   [] -> []
+	 |  (b,h')::l ->
+	     (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe])
+             :: (list_to_eq (switch h' h) l)
+       in sph [spt a;  spb;
+		 spv ((sph [sps "="; spb; spt b; spb; 
+			     tag_uselemma (switch h h') spe])
+		      ::(list_to_eq (switch h' h) l))]
+  | _ -> assert false
+;;
+
+let stde = Global.env;;
+
+let dbize env = Constrintern.interp_constr Evd.empty env;;
+
+(**********************************************************************)
+let rec natural_ntree ig ntree =
+  let  {t_info=info;
+	 t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	 t_proof=p} = ntree in
+    let leq = List.rev (equalities_ntree ig ntree)  in
+    if List.length leq > 1
+    then (* Several equalities to treate ... *)
+      (
+       print_string("Several equalities to treate ...\n");
+      let l1 = ref [] in
+      let l2 = ref [] in
+      List.iter
+	(fun (_,ntree) ->
+	 let lemma =  match (proof ntree) with
+	   Proof (tac,ltree) ->
+	     (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *)
+			  (match ltree with
+			    [] ->spe
+			  | [_] -> spe
+			  | _::l -> sphv[sps ": ";
+					  prli (natural_ntree 
+					    {ihsg=All_subgoals_hyp;
+					      isgintro="standard"})
+                            		    l])])
+	      with _ -> sps "simplification"  )
+	 | Notproved -> spe
+	 in
+ 	  let (t1,t2)= terms_of_equality (concl ntree) in
+	  l2:=(t2,lemma)::(!l2);
+	  l1:=(t1,lemma)::(!l1))
+	leq;
+      l1:=remove_seq_of_terms !l1;
+      l2:=remove_seq_of_terms !l2;
+      l2:=List.rev !l2;
+      let ltext=ref [] in
+      if List.length !l1 > 1
+      then (ltext:=(!ltext)@[list_to_eq !l1 true];
+	    if List.length !l2 > 1 then
+	      (ltext:=(!ltext)@[_et()];
+	       ltext:=(!ltext)@[list_to_eq !l2 false]))
+      else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false];
+      if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext];
+      let (ig,ntree)=(List.hd leq) in
+      spv [(natural_lhyp lh ig.ihsg);
+	    (show_goal2 lh ig g (nsort gf) "");
+	    sph !ltext;
+	    
+	    natural_ntree {ihsg=All_subgoals_hyp;
+                            isgintro=
+			    let  (t1,t2)= terms_of_equality (concl ntree) in
+			    if eq_term t1 t2
+			    then "trivial_equality"
+			    else "equality"}
+	      ntree]
+      	)
+    else
+    let ntext =
+      let gs=nsort gf in
+      match p with
+   	Notproved ->  spv [ (natural_lhyp lh ig.ihsg);
+                            sph [spi; sps (intro_not_proved_goal gs); spb; 
+                                  tag_toprove g  ]
+			  ]
+
+      | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree)
+      | Proof (TacAtom (_,tac),ltree) -> 
+	 (let ntext = 
+	  match tac with
+(* Pas besoin de l'argument éventuel de la tactique *)
+	    TacIntroPattern _ -> natural_intros ig lh g gs ltree
+	  | TacIntroMove _ -> natural_intros ig lh g gs ltree
+	  | TacFix (_,n) -> natural_fix ig lh g gs n ltree
+	  | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree
+	  | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree
+	  | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree
+	  | TacRight _ -> natural_right ig lh g gs ltree
+	  | TacLeft _ -> natural_left ig lh g gs ltree
+	  | (* "Simpl" *)TacReduce (r,cl)  ->
+	      natural_reduce ig lh g gs ge r cl ltree
+	  | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree
+	  | TacAuto _ -> natural_auto ig lh g gs ltree
+	  | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree
+	  | TacTrivial _ -> natural_trivial ig lh g gs ltree
+	  | 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,_) -> 
+              natural_induction ig lh g gs ge id ltree false
+	  | TacExtend (_,"InductionIntro",[a]) -> 
+              let id=(out_gen wit_ident a) in
+              natural_induction ig lh g gs ge id ltree true
+	  | TacApply (c,_) -> natural_apply ig lh g gs c ltree
+	  | 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
+	      natural_cutintro ig lh g gs a ltree
+	  | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false
+	  | TacExtend (_,"CaseIntro",[a]) ->
+	      let c = out_gen wit_constr a in
+	      natural_case ig lh g gs ge c ltree true
+	  | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false
+	  | TacExtend (_,"ElimIntro",[a]) ->
+	      let c = out_gen wit_constr a in
+	      natural_elim ig lh g gs ge c ltree true
+	  | TacExtend (_,"Rewrite",[_;a]) ->
+	      let (c,_) = out_gen wit_constr_with_bindings a in
+	      natural_rewrite ig lh g gs c ltree
+	  | TacExtend (_,"ERewriteRL",[a]) ->
+	      let c = out_gen wit_constr a in (* TODO *)
+	      natural_rewrite ig lh g gs c ltree
+	  | TacExtend (_,"ERewriteLR",[a]) ->
+	      let c = out_gen wit_constr a in (* TODO *)
+	      natural_rewrite ig lh g gs c ltree
+	  |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree
+         in
+          ntext (* spwithtac ntext tactic*)
+          )
+      | Proof _ -> failwith "Don't know what to do with that"
+    in   
+         if info<>"not_proved"
+         then spshrink info ntext
+         else ntext
+and  natural_generic  ig lh g gs tactic tac ltree =
+  spv
+    [ (natural_lhyp lh ig.ihsg);
+      (show_goal2 lh ig g gs "");
+      on_applique_la_tactique tactic tac ;
+      (prli(natural_ntree  
+	      {ihsg=All_subgoals_hyp;
+		isgintro="standard"})
+         ltree)
+    ]
+and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree)
+(*
+    spv
+    [ (natural_lhyp lh ig.ihsg);
+      (show_goal2 lh ig g gs "");
+      (prl (natural_ntree ig) ltree)
+    ]
+*)
+and natural_intros ig lh g gs ltree =
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+            (show_goal2 lh ig g gs "");
+            (prl (natural_ntree  
+                {ihsg=All_subgoals_hyp;
+                 isgintro="intros"})
+                            ltree)
+        ]
+and natural_apply ig lh g gs arg ltree =
+  let lg = List.map concl ltree in
+  match lg with
+    [] ->
+      spv
+        [ (natural_lhyp lh ig.ihsg);
+	  de_A_il_vient_B arg g  
+        ]
+  | [sg]->
+      spv
+        [ (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh
+	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
+	                              then "standard"
+	                              else ""}
+	     g gs "");
+          grace_a_A_il_suffit_de_montrer_LA arg [spt sg];
+	  sph [spi ; natural_ntree 
+		  {ihsg=All_subgoals_hyp;
+		    isgintro="apply"} (List.hd ltree)]
+	]       
+  | _ ->
+      let ln = List.map (fun _ -> new_name()) lg in
+      spv
+        [ (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh
+	     {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply"
+	                              then "standard"
+			              else ""}
+	     g gs "");
+          grace_a_A_il_suffit_de_montrer_LA arg
+	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
+	       lg ln);
+	  sph [spi; spv (List.map2
+			   (fun x n -> sph [sps ("("^n^"):"); spb;
+					     natural_ntree 
+					       {ihsg=All_subgoals_hyp;
+						 isgintro="apply"} x])
+			   ltree ln)]
+        ]
+and natural_rem_goals ltree =
+  let lg = List.map concl ltree in
+  match lg with
+    [] -> spe
+  | [sg]->
+      spv
+        [ reste_a_montrer_LA [spt sg];
+	  sph [spi ; natural_ntree 
+		  {ihsg=All_subgoals_hyp;
+		    isgintro="apply"} (List.hd ltree)]
+	]       
+  | _ ->
+      let ln = List.map (fun _ -> new_name()) lg in
+      spv
+        [   reste_a_montrer_LA 
+	    (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g])
+	       lg ln);
+	  sph [spi; spv (List.map2
+			   (fun x n -> sph [sps ("("^n^"):"); spb;
+					     natural_ntree 
+					       {ihsg=All_subgoals_hyp;
+						 isgintro="apply"} x])
+			   ltree ln)]
+        ]
+and natural_exact ig lh g gs arg ltree =
+spv
+         [  
+             (natural_lhyp lh ig.ihsg);
+             (let {ihsg=pi;isgintro=ig}= ig in
+               (show_goal2 lh {ihsg=pi;isgintro=""}
+                   g gs ""));
+             (match gs with
+               Prop(Null) -> _A_est_immediat_par_B g arg
+              |_ -> le_resultat_est arg)
+
+        ]
+and natural_cut ig lh g gs arg ltree =
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+             (prli(natural_ntree  
+                    {ihsg=All_subgoals_hyp;isgintro="standard"})
+                            (List.rev ltree));
+             de_A_on_deduit_donc_B arg g
+        ]
+and natural_cutintro ig lh g gs arg ltree =
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+             sph [spi;
+                    (natural_ntree  
+                       {ihsg=All_subgoals_hyp;isgintro=""}
+                       (List.nth ltree 1))];
+             sph [spi;
+                    (natural_ntree  
+                       {ihsg=No_subgoals_hyp;isgintro=""}
+                       (List.nth ltree 0))]
+        ]
+and whd_betadeltaiota x = whd_betaiotaevar (Global.env()) Evd.empty x
+and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c)
+and prod_head t =
+  match (kind_of_term (strip_outer_cast t)) with 
+     Prod(_,_,c) -> prod_head c
+(*    |App(f,a) -> f *)
+    | _ -> t
+and string_of_sp sp = string_of_id (basename sp)
+and constr_of_mind mip i =
+  (string_of_id mip.mind_consnames.(i-1))
+and arity_of_constr_of_mind env indf i =
+     (get_constructors env indf).(i-1).cs_nargs
+and gLOB ge = Global.env_of_context ge  (* (Global.env()) *)
+
+and natural_case ig lh g gs ge arg1 ltree with_intros =
+ let env= (gLOB ge) 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 (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
+ if  ncti<>1
+(* Zéro ou Plusieurs constructeurs *)
+ then (   
+   spv
+         [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+             (match (nsort targ1) with
+               Prop(Null) ->
+		 (match ti with
+		   "or" ->  discutons_avec_A type_arg
+                 | _ -> utilisons_A arg1)
+             |_ -> selon_les_valeurs_de_A arg1);
+            (let ci=ref 0 in
+             (prli
+                 (fun treearg -> ci:=!ci+1;
+                      let nci=(constr_of_mind mip !ci) in
+                      let aci=if with_intros
+			      then (arity_of_constr_of_mind env indf !ci)
+		              else 0 in
+                      let ici= (!ci) in
+                    sph[ (natural_ntree  
+                          {ihsg=
+                             (match (nsort targ1) with
+                                Prop(Null) ->
+                                   Case_prop_subgoals_hyp (supposons (),arg1,ici,aci,
+                                     (List.length ltree))
+                               |_-> Case_subgoals_hyp ("",arg1,nci,aci,
+                                                (List.length ltree)));
+                           isgintro= if with_intros then "" else "standard"}
+                          treearg)
+                    ])
+                  (nrem ltree ((List.length ltree)- ncti))));
+	    (sph [spi; (natural_rem_goals
+			  (nhd ltree ((List.length ltree)- ncti)))])
+         ] )
+(* Cas d'un seul constructeur *)
+     else (  
+
+     spv
+     [ (natural_lhyp lh ig.ihsg);
+       (show_goal2 lh ig g gs "");
+       de_A_on_a arg1;
+       (let treearg=List.hd ltree in
+       let nci=(constr_of_mind mip 1) in
+       let aci=
+	 if with_intros
+         then (arity_of_constr_of_mind env indf 1)
+	 else 0 in
+       let ici= 1 in
+       sph[ (natural_ntree  
+               {ihsg=
+                 (match (nsort targ1) with
+                   Prop(Null) ->
+                     Case_prop_subgoals_hyp ("",arg1,1,aci,
+					     (List.length ltree))
+                 |_-> Case_subgoals_hyp ("",arg1,nci,aci,
+                                         (List.length ltree)));
+                 isgintro=""}
+               treearg)
+          ]);
+       (sph [spi; (natural_rem_goals
+		     (nhd ltree ((List.length ltree)- 1)))])
+     ] 
+     )
+(*    with _ ->natural_generic ig lh g gs (sps "Case")  (spt arg1) ltree *)
+
+(*****************************************************************************)
+(*
+   Elim
+*)
+and prod_list_var t =
+   match (kind_of_term (strip_outer_cast t)) with 
+      Prod(_,t,c) -> t::(prod_list_var c)
+     |_ -> []
+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 (ind,_) = dest_ind_family indf in
+         let (mib,mip) = lookup_mind_specif env ind in
+	 (string_of_id mip.mind_typename) = ti)
+    with _ -> false
+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 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
+  let ti = (string_of_id mip.mind_typename) in
+  for i=1 to a do
+     match !lp with
+     ((_,_,t)::lp1)->
+       if hd_is_mind t ti
+       then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1)
+       else (lr:=(!lr)@["arg"];lp:=lp1)
+     |  _ -> raise (Failure "mind_ind_info_hyp_constr")
+  done;
+  !lr
+(*
+ mind_ind_info_hyp_constr "le" 2;;
+donne  ["arg"; "argrec"] 
+mind_ind_info_hyp_constr "le" 1;;
+donne []
+ mind_ind_info_hyp_constr "nat" 2;;
+donne ["argrec"]
+*)
+
+and natural_elim ig lh g gs ge arg1 ltree with_intros=
+ let env= (gLOB ge) 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 (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
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+             (match (nsort targ1) with
+               Prop(Null) -> utilisons_A arg1
+	     |_ ->procedons_par_recurrence_sur_A arg1);
+            (let ci=ref 0 in
+             (prli
+                 (fun treearg -> ci:=!ci+1;
+                      let nci=(constr_of_mind mip !ci) in
+                      let aci=(arity_of_constr_of_mind env indf !ci) in
+                      let hci=
+			if with_intros
+			then mind_ind_info_hyp_constr indf  !ci
+		      	else [] in
+                      let ici= (!ci) in
+                    sph[ (natural_ntree  
+                          {ihsg=
+                             (match (nsort targ1) with
+                                Prop(Null) ->
+                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
+                                     (List.length ltree))
+                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
+                                                (List.length ltree)));
+                           isgintro= ""}
+                          treearg)
+                    ])
+                  (nhd ltree ncti)));
+	    (sph [spi; (natural_rem_goals (nrem ltree ncti))])
+        ]
+(* )
+  with _ ->natural_generic ig lh g gs (sps "Elim")  (spt arg1) ltree *)
+
+(*****************************************************************************)
+(*
+   InductionIntro n
+*) 
+and natural_induction ig lh g gs ge arg2 ltree with_intros=
+ let env = (gLOB (g_env (List.hd ltree))) in
+ 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 (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 lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *)
+ (* on les enleve des hypotheses des sous-buts *)
+ let ltree = List.map
+     (fun {t_info=info;
+	    t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge};
+	    t_proof=p} ->
+	  {t_info=info;
+	    t_goal={newhyp=(nrem lh (List.length lh1));
+		     t_concl=g;t_full_concl=gf;t_full_env=ge};
+	    t_proof=p}) ltree in
+ spv
+   [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+	   (natural_lhyp lh1 All_subgoals_hyp);
+             (match (print_string "targ1------------\n";(nsort targ1)) with
+               Prop(Null) -> utilisons_A arg1
+	     |_ -> procedons_par_recurrence_sur_A arg1);
+            (let ci=ref 0 in
+             (prli
+                 (fun treearg -> ci:=!ci+1;
+                      let nci=(constr_of_mind mip !ci) in
+                      let aci=(arity_of_constr_of_mind env indf !ci) in
+                      let hci= 
+			if with_intros
+			then mind_ind_info_hyp_constr indf  !ci
+		      	else [] in
+                      let ici= (!ci) in
+                    sph[ (natural_ntree  
+                          {ihsg=
+                             (match (nsort targ1) with
+                                Prop(Null) ->
+                                   Elim_prop_subgoals_hyp (arg1,ici,aci,hci,
+                                     (List.length ltree))
+                               |_-> Elim_subgoals_hyp (arg1,nci,aci,hci,
+                                                (List.length ltree)));
+                           isgintro= "standard"}
+                          treearg)
+                    ])
+                  ltree))
+        ]
+(************************************************************************)
+(* Points fixes *)
+
+and natural_fix ig lh g gs narg ltree =
+  let {t_info=info;
+	t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1;
+                   t_full_env=ge1};t_proof=p1}=(List.hd ltree) in
+  match lh1 with
+     {hyp_name=nfun;hyp_type=tfun}::lh2 ->
+  let ltree=[{t_info=info;
+	       t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1;
+                          t_full_env=ge1};
+	       t_proof=p1}] in
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+             calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A  nfun tfun narg;
+             (prli(natural_ntree  
+                   {ihsg=All_subgoals_hyp;isgintro=""})
+                            ltree)
+        ]
+   | _ -> assert false
+and natural_reduce ig lh g gs ge mode la ltree =
+  match la with
+    {onhyps=Some[];onconcl=true} -> 
+      spv
+        [  (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh ig g gs ""); 
+          (prl (natural_ntree 
+		  {ihsg=All_subgoals_hyp;isgintro="simpl"})
+             ltree)
+        ]
+  | {onhyps=Some[hyp]; onconcl=false} ->
+      spv
+        [  (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh ig g gs ""); 
+          (prl (natural_ntree 
+		  {ihsg=Reduce_hyp;isgintro=""})
+             ltree)
+        ]
+  | _ -> assert false
+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
+      spv
+      	[ (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh ig g gs ""); 
+	  pour_montrer_G_la_valeur_recherchee_est_A  g arg1;
+          (prl (natural_ntree 
+		  {ihsg=All_subgoals_hyp;isgintro="standard"})
+             ltree)
+        ]
+  | [] ->
+      spv
+        [ (natural_lhyp lh ig.ihsg);
+          (prli(natural_ntree  
+                  {ihsg=All_subgoals_hyp;isgintro="standard"})
+             ltree)
+        ]
+  | _ -> assert false
+and natural_generalize ig lh g gs ge la ltree =
+  match la with
+    [arg] ->
+      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_ast ge arg in*)
+      spv
+      	[ (natural_lhyp lh ig.ihsg);
+          (show_goal2 lh ig g gs ""); 
+	  on_se_sert_de_A   arg1;
+          (prl (natural_ntree 
+		  {ihsg=All_subgoals_hyp;isgintro=""})
+             ltree)
+        ]
+    | _ -> assert false
+and natural_right ig lh g gs ltree =
+  spv
+         [ (natural_lhyp lh ig.ihsg);
+            (prli(natural_ntree  
+                {ihsg=All_subgoals_hyp;isgintro="standard"})
+                            ltree); 
+            d_ou_A g  
+        ]
+and natural_left ig lh g gs ltree =
+  spv
+         [ (natural_lhyp lh ig.ihsg);
+            (prli(natural_ntree  
+                {ihsg=All_subgoals_hyp;isgintro="standard"})
+                            ltree); 
+             d_ou_A g  
+        ]
+and natural_auto ig lh g gs ltree =
+  match ig.isgintro with
+   "trivial_equality" -> spe
+  | _ -> 
+      if ltree=[]
+      then sphv [(natural_lhyp lh ig.ihsg);
+		  (show_goal2 lh ig g gs "");
+		  coq_le_demontre_seul ()]
+      else spv [(natural_lhyp lh ig.ihsg);
+		 (show_goal2 lh ig g gs "");
+		 (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}
+			  )
+                    ltree)]
+and natural_infoauto ig lh g gs ltree =
+ match ig.isgintro with
+   "trivial_equality" ->
+     spshrink "trivial_equality"
+       (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}
+		 (List.hd ltree))
+  | _ ->   sphv [(natural_lhyp lh ig.ihsg);
+	 (show_goal2 lh ig g gs "");
+	 coq_le_demontre_seul ();
+       spshrink "auto"
+		    (sph [spi;
+		       (natural_ntree
+			  {ihsg=All_subgoals_hyp;isgintro=""}
+			  (List.hd ltree))])]
+and natural_trivial ig lh g gs ltree =
+  if ltree=[]
+  then sphv [(natural_lhyp lh ig.ihsg);
+	      (show_goal2 lh ig g gs "");
+	      ce_qui_est_trivial () ]
+  else spv [(natural_lhyp lh ig.ihsg);
+	     (show_goal2 lh ig g gs ". ");
+            (prli(natural_ntree  
+                      {ihsg=All_subgoals_hyp;isgintro="standard"})
+                            ltree)]
+and natural_rewrite ig lh g gs arg ltree =
+  spv
+         [  (natural_lhyp lh ig.ihsg);
+             (show_goal2 lh ig g gs "");
+             en_utilisant_l_egalite_A arg;
+            (prli(natural_ntree  
+                 {ihsg=All_subgoals_hyp;isgintro="rewrite"})
+                            ltree)
+        ]
+;;
+
+let natural_ntree_path ig g =
+  Random.init(0);
+        natural_ntree ig g
+;;
+
+let show_proof lang gpath =
+  (match lang with
+     "fr" -> natural_language:=French
+    |"en" -> natural_language:=English
+    | _ -> natural_language:=English);
+  path:=List.rev gpath;
+  name_count:=0;
+  let ntree=(get_nproof ()) in
+  let {t_info=i;t_goal=g;t_proof=p} =ntree in
+  root_of_text_proof
+    (sph [(natural_ntree_path {ihsg=All_subgoals_hyp;
+				isgintro="standard"}
+	                      {t_info="not_proved";t_goal=g;t_proof=p});
+           spr])
+    ;;
+
+let show_nproof path =
+  pp (sp_print (sph [spi; show_proof "fr" path]));;
+
+vinterp_add "ShowNaturalProof"
+	    (fun _ ->
+		 (fun () ->show_nproof[];()));;
+
+(***********************************************************************
+debug sous cygwin:
+
+PATH=/usr/local/bin:/usr/bin:$PATH
+COQTOP=d:/Tools/coq-7avril
+CAMLLIB=/usr/local/lib/ocaml
+CAMLP4LIB=/usr/local/lib/camlp4
+export CAMLLIB
+export COQTOP
+export CAMLP4LIB 
+cd d:/Tools/pcoq/src/text
+d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax  -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history
+
+ 
+ 
+Lemma l1: (A, B : Prop) A \/ B -> B ->  A.
+Intros.
+Elim H.
+Auto.
+Qed.
+ 
+
+Drop.
+
+#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";;
+#load "xlate.cmo";;
+#load "translate.cmo";;
+#load "showproof_ct.cmo";;
+#load "showproof.cmo";;
+#load "pbp.cmo";;
+#load "debug_tac.cmo";;
+#load "name_to_ast.cmo";;
+#load "paths.cmo";;
+#load "dad.cmo";;
+#load "vtp.cmo";;
+#load "history.cmo";;
+#load "centaur.cmo";;
+Xlate.set_xlate_mut_stuff Centaur.globcv;;
+Xlate.declare_in_coq();;
+
+#use "showproof.ml";;
+
+let pproof x = pP (sp_print x);;
+Pp_control.set_depth_boxes 100;;
+#install_printer  pproof;;
+
+ep();;
+let bidon = ref (constr_of_string "O");; 
+
+#trace to_nproof;;
+***********************************************************************)
+let ep()=show_proof "fr" [];;
diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli
new file mode 100755
index 00000000..ee269458
--- /dev/null
+++ b/contrib/interface/showproof.mli
@@ -0,0 +1,23 @@
+open Environ
+open Evd
+open Names
+open Term
+open Util
+open Proof_type
+open Coqast
+open Pfedit
+open Translate
+open Term
+open Reduction
+open Clenv
+open Typing
+open Inductive
+open Vernacinterp
+open Declarations
+open Showproof_ct
+open Proof_trees
+open Sign
+open Pp
+open Printer
+
+val show_proof : string -> int list -> Ascent.ct_TEXT;;
diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml
new file mode 100644
index 00000000..ee901c5e
--- /dev/null
+++ b/contrib/interface/showproof_ct.ml
@@ -0,0 +1,185 @@
+(*****************************************************************************)
+(*
+   Vers Ctcoq
+*)
+
+open Esyntax
+open Metasyntax
+open Printer
+open Pp
+open Translate
+open Ascent
+open Vtp
+open Xlate
+
+let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);;
+
+let sps s =
+  ct_text s
+    ;;
+
+
+let sphs s =
+  ct_text s
+    ;;
+
+let spe = sphs "";;
+let spb = sps " ";;
+let spr = sps "Retour chariot pour Show proof";;
+
+let spnb n = 
+   let s = ref "" in
+   for i=1 to n do s:=(!s)^" "; done; sps !s
+;;
+
+
+let rec spclean l =
+  match l with 
+    [] -> []
+   |x::l -> if x=spe then (spclean l) else x::(spclean l)
+;;
+
+
+let spnb n = 
+   let s = ref "" in
+   for i=1 to n do s:=(!s)^" "; done; sps !s
+;;
+
+let ct_FORMULA_constr = Hashtbl.create 50;;
+
+let stde()  = (Global.env())
+
+;;
+
+let spt t =
+   let f = (translate_constr true (stde()) t) in
+   Hashtbl.add ct_FORMULA_constr f t;
+   CT_text_formula f
+;;
+
+
+
+let root_of_text_proof t=
+  CT_text_op [ct_text "root_of_text_proof";
+              t]
+    ;;
+    
+let spshrink info t =
+  CT_text_op [ct_text "shrink";
+	      CT_text_op [ct_text info;
+                          t]]
+;;
+			 
+let spuselemma intro x y =
+  CT_text_op [ct_text "uselemma";
+              ct_text intro;
+	      x;y]
+;;
+
+let sptoprove p t =
+  CT_text_op [ct_text "to_prove";
+	      CT_text_path p;
+              ct_text "goal";
+	      (spt t)]
+;;
+let sphyp p h t =
+  CT_text_op [ct_text "hyp";
+	      CT_text_path p;
+	      ct_text h;
+              (spt t)]
+;;
+let sphypt p h t =
+  CT_text_op [ct_text "hyp_with_type";
+	      CT_text_path p;
+	      ct_text h;
+              (spt t)]
+;;
+
+let spwithtac x t =
+    CT_text_op [ct_text "with_tactic";
+                ct_text t;
+                x]
+;;
+
+
+let spv l =
+   let l= spclean l in
+   CT_text_v l
+;;
+     
+let sph l =
+   let l= spclean l in
+   CT_text_h l
+;;
+
+
+let sphv l =
+   let l= spclean l in
+   CT_text_hv l
+;;
+
+let rec prlist_with_sep f g l =
+    match l with 
+      [] -> hov 0 (mt ())
+     |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1))
+;;
+   
+let rec sp_print x = 
+   match x with
+     | CT_coerce_ID_to_TEXT (CT_ident s)
+       -> (match s with
+	     | "\n" -> fnl ()
+	     | "Retour chariot pour Show proof" -> fnl ()
+	     |_ -> str s)
+     | CT_text_formula  f -> prterm (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
+	                 (CT_coerce_INT_to_SIGNED_INT
+			      (CT_int x)) -> x
+		       | _ -> raise (Failure "sp_print")) p) in
+      h 0 (str "<b>" ++ sp_print g ++ str "</b>")
+ |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma");
+              CT_coerce_ID_to_TEXT (CT_ident intro);
+	      l;g] ->
+      h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g)
+ |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp");
+	      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
+	                  (CT_coerce_INT_to_SIGNED_INT
+			      (CT_int x)) -> x
+		       | _ -> raise (Failure "sp_print")) p) in
+            h 0 (str hyp)
+
+  |   CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type");
+	      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
+                         (CT_coerce_INT_to_SIGNED_INT
+			      (CT_int x)) -> x
+		       | _ -> raise (Failure "sp_print")) p) in
+      h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>")   
+
+  | CT_text_h l ->
+      h 0 (prlist_with_sep (fun () -> mt ())
+	     (fun y -> sp_print y) l)
+  | CT_text_v l ->
+      v 0 (prlist_with_sep (fun () -> mt ())
+		(fun y -> sp_print y) l)
+  | CT_text_hv l ->
+      h 0 (prlist_with_sep (fun () -> mt ())
+	     (fun y -> sp_print y) l)
+  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink");
+	      CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]]  ->
+                   h 0 (str ("("^info^": ") ++ sp_print t ++ str ")")
+  | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof");
+              t]->
+                    sp_print t 
+  | _ -> str "..."
+;;
+  
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
new file mode 100644
index 00000000..e63baecf
--- /dev/null
+++ b/contrib/interface/translate.ml
@@ -0,0 +1,165 @@
+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;;
+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);;
+
+(*translates a named_context into a centaur-tree --> PREMISES_LIST *)
+(* this code is inspired from printer.ml (function pr_named_context_of) *)
+let translate_sign env =
+  let l = 
+    Environ.fold_named_context
+      (fun env (id,v,c) l -> 
+	 (match v with
+	      None ->
+	       	CT_premise(CT_ident(string_of_id id), translate_constr false env c)
+	    | Some v1 ->
+		CT_eval_result
+		  (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)),
+		   translate_constr false env v1,
+		   translate_constr false env c))::l)
+      env ~init:[] 
+  in
+  CT_premises_list l;;
+       
+(* the function rev_and_compact performs two operations:
+   1- it reverses the list of integers given as argument
+   2- it replaces sequences of "1" by a negative number that is
+      the length of the sequence. *)
+let rec rev_and_compact l = function
+    [] -> l
+  | 1::tl -> 
+      (match l with
+              n::tl' -> 
+        if n < 0 then
+          rev_and_compact ((n - 1)::tl') tl
+        else
+          rev_and_compact ((-1)::l) tl
+      |       [] -> rev_and_compact [-1] tl)
+  | a::tl ->
+      if a < 0 then
+      (match l with
+        n::tl' ->
+          if n < 0 then
+            rev_and_compact ((n + a)::tl') tl
+          else
+            rev_and_compact (a::l) tl
+      | [] -> rev_and_compact (a::l) tl)
+      else
+      rev_and_compact (a::l) tl;;
+
+(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *)
+let translate_path l =
+ CT_signed_int_list
+ (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n))
+    (rev_and_compact [] l));;
+
+(*translates a path and a goal into a centaur-tree --> RULE *)
+let translate_goal (g:goal) =
+ CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);;
diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli
new file mode 100644
index 00000000..65d8331b
--- /dev/null
+++ b/contrib/interface/translate.mli
@@ -0,0 +1,11 @@
+open Ascent;;
+open Evd;;
+open Proof_type;;
+open Environ;;
+open Term;;
+
+val translate_goal : goal -> ct_RULE;;
+(* The boolean argument indicates whether names from the environment should *)
+(*  be avoided (same interpretation as for prterm_env and ast_of_constr)    *)
+val translate_constr : bool -> env -> constr -> ct_FORMULA;;
+val translate_path : int list -> ct_SIGNED_INT_LIST;;
diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc
new file mode 100644
index 00000000..42b5e5ab
--- /dev/null
+++ b/contrib/interface/vernacrc
@@ -0,0 +1,12 @@
+# $Id: vernacrc,v 1.3 2004/01/14 14:52:59 bertot Exp $
+
+# This file is loaded initially by ./vernacparser.
+
+load_syntax_file 1 Notations
+load_syntax_file 2 Logic
+load_syntax_file 34 Omega
+load_syntax_file 27 Ring
+quiet_parse_string
+Goal a.
+&& END--OF--DATA
+print_version
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
new file mode 100644
index 00000000..ff418523
--- /dev/null
+++ b/contrib/interface/vtp.ml
@@ -0,0 +1,1915 @@
+open Ascent;;
+
+let fNODE s n =
+    print_string "n\n";
+    print_string ("vernac$" ^ s);
+    print_string "\n";
+    print_int n;
+    print_string "\n";;
+
+let fATOM s1 =
+    print_string "a\n";
+    print_string ("vernac$" ^ s1);
+    print_string "\n";;
+
+let f_atom_string = print_string;;
+let f_atom_int = print_int;;
+let rec fAST = function
+| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x
+| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x
+| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x
+| CT_astnode(x1, x2) ->
+   fID x1;
+   fAST_LIST x2;
+   fNODE "astnode" 2
+| CT_astpath(x1) ->
+   fID_LIST x1;
+   fNODE "astpath" 1
+| CT_astslam(x1, x2) ->
+   fID_OPT x1;
+   fAST x2;
+   fNODE "astslam" 2
+and fAST_LIST = function
+| CT_ast_list l ->
+   (List.iter fAST l);
+   fNODE "ast_list" (List.length l)
+and fBINARY = function
+| CT_binary x -> fATOM "binary";
+   (f_atom_int x);
+   print_string "\n"and fBINDER = function
+| CT_coerce_DEF_to_BINDER x -> fDEF x
+| CT_binder(x1, x2) ->
+   fID_OPT_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "binder" 2
+| CT_binder_coercion(x1, x2) ->
+   fID_OPT_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "binder_coercion" 2
+and fBINDER_LIST = function
+| CT_binder_list l ->
+   (List.iter fBINDER l);
+   fNODE "binder_list" (List.length l)
+and fBINDER_NE_LIST = function
+| CT_binder_ne_list(x,l) ->
+   fBINDER x;
+   (List.iter fBINDER l);
+   fNODE "binder_ne_list" (1 + (List.length l))
+and fBINDING = function
+| CT_binding(x1, x2) ->
+   fID_OR_INT x1;
+   fFORMULA x2;
+   fNODE "binding" 2
+and fBINDING_LIST = function
+| CT_binding_list l ->
+   (List.iter fBINDING l);
+   fNODE "binding_list" (List.length l)
+and fBOOL = function
+| CT_false -> fNODE "false" 0
+| CT_true -> fNODE "true" 0
+and fCASE = function
+| CT_case x -> fATOM "case";
+   (f_atom_string x);
+   print_string "\n"and fCLAUSE = function
+| CT_clause(x1, x2) ->
+   fHYP_LOCATION_LIST_OR_STAR x1;
+   fSTAR_OPT x2;
+   fNODE "clause" 2
+and fCOERCION_OPT = function
+| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x
+| CT_coercion_atm -> fNODE "coercion_atm" 0
+and fCOFIXTAC = function
+| CT_cofixtac(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "cofixtac" 2
+and fCOFIX_REC = function
+| CT_cofix_rec(x1, x2, x3, x4) ->
+   fID x1;
+   fBINDER_LIST x2;
+   fFORMULA x3;
+   fFORMULA x4;
+   fNODE "cofix_rec" 4
+and fCOFIX_REC_LIST = function
+| CT_cofix_rec_list(x,l) ->
+   fCOFIX_REC x;
+   (List.iter fCOFIX_REC l);
+   fNODE "cofix_rec_list" (1 + (List.length l))
+and fCOFIX_TAC_LIST = function
+| CT_cofix_tac_list l ->
+   (List.iter fCOFIXTAC l);
+   fNODE "cofix_tac_list" (List.length l)
+and fCOMMAND = function
+| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x
+| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x
+| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x
+| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x
+| CT_abort(x1) ->
+   fID_OPT_OR_ALL x1;
+   fNODE "abort" 1
+| CT_abstraction(x1, x2, x3) ->
+   fID x1;
+   fFORMULA x2;
+   fINT_LIST x3;
+   fNODE "abstraction" 3
+| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) ->
+   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
+| CT_add_natural_feature(x1, x2) ->
+   fNATURAL_FEATURE x1;
+   fID x2;
+   fNODE "add_natural_feature" 2
+| CT_addpath(x1, x2) ->
+   fSTRING x1;
+   fID_OPT x2;
+   fNODE "addpath" 2
+| CT_arguments_scope(x1, x2) ->
+   fID x1;
+   fID_OPT_LIST x2;
+   fNODE "arguments_scope" 2
+| CT_bind_scope(x1, x2) ->
+   fID x1;
+   fID_NE_LIST x2;
+   fNODE "bind_scope" 2
+| CT_cd(x1) ->
+   fSTRING_OPT x1;
+   fNODE "cd" 1
+| CT_check(x1) ->
+   fFORMULA x1;
+   fNODE "check" 1
+| CT_class(x1) ->
+   fID x1;
+   fNODE "class" 1
+| CT_close_scope(x1) ->
+   fID x1;
+   fNODE "close_scope" 1
+| CT_coercion(x1, x2, x3, x4, x5) ->
+   fLOCAL_OPT x1;
+   fIDENTITY_OPT x2;
+   fID x3;
+   fID x4;
+   fID x5;
+   fNODE "coercion" 5
+| CT_cofix_decl(x1) ->
+   fCOFIX_REC_LIST x1;
+   fNODE "cofix_decl" 1
+| CT_compile_module(x1, x2, x3) ->
+   fVERBOSE_OPT x1;
+   fID x2;
+   fSTRING_OPT x3;
+   fNODE "compile_module" 3
+| CT_declare_module(x1, x2, x3, x4) ->
+   fID x1;
+   fMODULE_BINDER_LIST x2;
+   fMODULE_TYPE_CHECK x3;
+   fMODULE_EXPR x4;
+   fNODE "declare_module" 4
+| CT_define_notation(x1, x2, x3, x4) ->
+   fSTRING x1;
+   fFORMULA x2;
+   fMODIFIER_LIST x3;
+   fID_OPT x4;
+   fNODE "define_notation" 4
+| CT_definition(x1, x2, x3, x4, x5) ->
+   fDEFN x1;
+   fID x2;
+   fBINDER_LIST x3;
+   fDEF_BODY x4;
+   fFORMULA_OPT x5;
+   fNODE "definition" 5
+| CT_delim_scope(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "delim_scope" 2
+| CT_delpath(x1) ->
+   fSTRING x1;
+   fNODE "delpath" 1
+| CT_derive_depinversion(x1, x2, x3, x4) ->
+   fINV_TYPE x1;
+   fID x2;
+   fFORMULA x3;
+   fSORT_TYPE x4;
+   fNODE "derive_depinversion" 4
+| CT_derive_inversion(x1, x2, x3, x4) ->
+   fINV_TYPE x1;
+   fINT_OPT x2;
+   fID x3;
+   fID x4;
+   fNODE "derive_inversion" 4
+| CT_derive_inversion_with(x1, x2, x3, x4) ->
+   fINV_TYPE x1;
+   fID x2;
+   fFORMULA x3;
+   fSORT_TYPE x4;
+   fNODE "derive_inversion_with" 4
+| CT_explain_proof(x1) ->
+   fINT_LIST x1;
+   fNODE "explain_proof" 1
+| CT_explain_prooftree(x1) ->
+   fINT_LIST x1;
+   fNODE "explain_prooftree" 1
+| CT_export_id(x1) ->
+   fID_NE_LIST x1;
+   fNODE "export_id" 1
+| CT_extract_to_file(x1, x2) ->
+   fSTRING x1;
+   fID_NE_LIST x2;
+   fNODE "extract_to_file" 2
+| CT_extraction(x1) ->
+   fID_OPT x1;
+   fNODE "extraction" 1
+| CT_fix_decl(x1) ->
+   fFIX_REC_LIST x1;
+   fNODE "fix_decl" 1
+| CT_focus(x1) ->
+   fINT_OPT x1;
+   fNODE "focus" 1
+| CT_go(x1) ->
+   fINT_OR_LOCN x1;
+   fNODE "go" 1
+| CT_guarded -> fNODE "guarded" 0
+| CT_hint_destruct(x1, x2, x3, x4, x5, x6) ->
+   fID x1;
+   fINT x2;
+   fDESTRUCT_LOCATION x3;
+   fFORMULA x4;
+   fTACTIC_COM x5;
+   fID_LIST x6;
+   fNODE "hint_destruct" 6
+| CT_hint_extern(x1, x2, x3, x4) ->
+   fINT x1;
+   fFORMULA x2;
+   fTACTIC_COM x3;
+   fID_LIST x4;
+   fNODE "hint_extern" 4
+| CT_hintrewrite(x1, x2, x3, x4) ->
+   fORIENTATION x1;
+   fFORMULA_NE_LIST x2;
+   fID x3;
+   fTACTIC_COM x4;
+   fNODE "hintrewrite" 4
+| CT_hints(x1, x2, x3) ->
+   fID x1;
+   fID_NE_LIST x2;
+   fID_LIST x3;
+   fNODE "hints" 3
+| CT_hints_immediate(x1, x2) ->
+   fFORMULA_NE_LIST x1;
+   fID_LIST x2;
+   fNODE "hints_immediate" 2
+| CT_hints_resolve(x1, x2) ->
+   fFORMULA_NE_LIST x1;
+   fID_LIST x2;
+   fNODE "hints_resolve" 2
+| CT_hyp_search_pattern(x1, x2) ->
+   fFORMULA x1;
+   fIN_OR_OUT_MODULES x2;
+   fNODE "hyp_search_pattern" 2
+| CT_implicits(x1, x2) ->
+   fID x1;
+   fID_LIST_OPT x2;
+   fNODE "implicits" 2
+| CT_import_id(x1) ->
+   fID_NE_LIST x1;
+   fNODE "import_id" 1
+| CT_ind_scheme(x1) ->
+   fSCHEME_SPEC_LIST x1;
+   fNODE "ind_scheme" 1
+| CT_infix(x1, x2, x3, x4) ->
+   fSTRING x1;
+   fID x2;
+   fMODIFIER_LIST x3;
+   fID_OPT x4;
+   fNODE "infix" 4
+| CT_inline(x1) ->
+   fID_NE_LIST x1;
+   fNODE "inline" 1
+| CT_inspect(x1) ->
+   fINT x1;
+   fNODE "inspect" 1
+| CT_kill_node(x1) ->
+   fINT x1;
+   fNODE "kill_node" 1
+| CT_load(x1, x2) ->
+   fVERBOSE_OPT x1;
+   fID_OR_STRING x2;
+   fNODE "load" 2
+| CT_local_close_scope(x1) ->
+   fID x1;
+   fNODE "local_close_scope" 1
+| CT_local_define_notation(x1, x2, x3, x4) ->
+   fSTRING x1;
+   fFORMULA x2;
+   fMODIFIER_LIST x3;
+   fID_OPT x4;
+   fNODE "local_define_notation" 4
+| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) ->
+   fID x1;
+   fINT x2;
+   fDESTRUCT_LOCATION x3;
+   fFORMULA x4;
+   fTACTIC_COM x5;
+   fID_LIST x6;
+   fNODE "local_hint_destruct" 6
+| CT_local_hint_extern(x1, x2, x3, x4) ->
+   fINT x1;
+   fFORMULA x2;
+   fTACTIC_COM x3;
+   fID_LIST x4;
+   fNODE "local_hint_extern" 4
+| CT_local_hints(x1, x2, x3) ->
+   fID x1;
+   fID_NE_LIST x2;
+   fID_LIST x3;
+   fNODE "local_hints" 3
+| CT_local_hints_immediate(x1, x2) ->
+   fFORMULA_NE_LIST x1;
+   fID_LIST x2;
+   fNODE "local_hints_immediate" 2
+| CT_local_hints_resolve(x1, x2) ->
+   fFORMULA_NE_LIST x1;
+   fID_LIST x2;
+   fNODE "local_hints_resolve" 2
+| CT_local_infix(x1, x2, x3, x4) ->
+   fSTRING x1;
+   fID x2;
+   fMODIFIER_LIST x3;
+   fID_OPT x4;
+   fNODE "local_infix" 4
+| CT_local_open_scope(x1) ->
+   fID x1;
+   fNODE "local_open_scope" 1
+| CT_local_reserve_notation(x1, x2) ->
+   fSTRING x1;
+   fMODIFIER_LIST x2;
+   fNODE "local_reserve_notation" 2
+| CT_locate(x1) ->
+   fID x1;
+   fNODE "locate" 1
+| CT_locate_file(x1) ->
+   fSTRING x1;
+   fNODE "locate_file" 1
+| CT_locate_lib(x1) ->
+   fID x1;
+   fNODE "locate_lib" 1
+| CT_locate_notation(x1) ->
+   fSTRING x1;
+   fNODE "locate_notation" 1
+| CT_mind_decl(x1, x2) ->
+   fCO_IND x1;
+   fIND_SPEC_LIST x2;
+   fNODE "mind_decl" 2
+| CT_ml_add_path(x1) ->
+   fSTRING x1;
+   fNODE "ml_add_path" 1
+| CT_ml_declare_modules(x1) ->
+   fSTRING_NE_LIST x1;
+   fNODE "ml_declare_modules" 1
+| CT_ml_print_modules -> fNODE "ml_print_modules" 0
+| CT_ml_print_path -> fNODE "ml_print_path" 0
+| CT_module(x1, x2, x3, x4) ->
+   fID x1;
+   fMODULE_BINDER_LIST x2;
+   fMODULE_TYPE_CHECK x3;
+   fMODULE_EXPR x4;
+   fNODE "module" 4
+| CT_module_type_decl(x1, x2, x3) ->
+   fID x1;
+   fMODULE_BINDER_LIST x2;
+   fMODULE_TYPE_OPT x3;
+   fNODE "module_type_decl" 3
+| CT_no_inline(x1) ->
+   fID_NE_LIST x1;
+   fNODE "no_inline" 1
+| CT_omega_flag(x1, x2) ->
+   fOMEGA_MODE x1;
+   fOMEGA_FEATURE x2;
+   fNODE "omega_flag" 2
+| CT_opaque(x1) ->
+   fID_NE_LIST x1;
+   fNODE "opaque" 1
+| CT_open_scope(x1) ->
+   fID x1;
+   fNODE "open_scope" 1
+| CT_print -> fNODE "print" 0
+| CT_print_about(x1) ->
+   fID x1;
+   fNODE "print_about" 1
+| CT_print_all -> fNODE "print_all" 0
+| CT_print_classes -> fNODE "print_classes" 0
+| CT_print_coercions -> fNODE "print_coercions" 0
+| CT_print_grammar(x1) ->
+   fGRAMMAR x1;
+   fNODE "print_grammar" 1
+| CT_print_graph -> fNODE "print_graph" 0
+| CT_print_hint(x1) ->
+   fID_OPT x1;
+   fNODE "print_hint" 1
+| CT_print_hintdb(x1) ->
+   fID_OR_STAR x1;
+   fNODE "print_hintdb" 1
+| CT_print_id(x1) ->
+   fID x1;
+   fNODE "print_id" 1
+| CT_print_implicit(x1) ->
+   fID x1;
+   fNODE "print_implicit" 1
+| CT_print_loadpath -> fNODE "print_loadpath" 0
+| CT_print_module(x1) ->
+   fID x1;
+   fNODE "print_module" 1
+| CT_print_module_type(x1) ->
+   fID x1;
+   fNODE "print_module_type" 1
+| CT_print_modules -> fNODE "print_modules" 0
+| CT_print_natural(x1) ->
+   fID x1;
+   fNODE "print_natural" 1
+| CT_print_natural_feature(x1) ->
+   fNATURAL_FEATURE x1;
+   fNODE "print_natural_feature" 1
+| CT_print_opaqueid(x1) ->
+   fID x1;
+   fNODE "print_opaqueid" 1
+| CT_print_path(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "print_path" 2
+| CT_print_proof(x1) ->
+   fID x1;
+   fNODE "print_proof" 1
+| CT_print_scope(x1) ->
+   fID x1;
+   fNODE "print_scope" 1
+| CT_print_scopes -> fNODE "print_scopes" 0
+| CT_print_section(x1) ->
+   fID x1;
+   fNODE "print_section" 1
+| CT_print_states -> fNODE "print_states" 0
+| CT_print_tables -> fNODE "print_tables" 0
+| CT_print_universes(x1) ->
+   fSTRING_OPT x1;
+   fNODE "print_universes" 1
+| CT_print_visibility(x1) ->
+   fID_OPT x1;
+   fNODE "print_visibility" 1
+| CT_proof(x1) ->
+   fFORMULA x1;
+   fNODE "proof" 1
+| CT_proof_no_op -> fNODE "proof_no_op" 0
+| CT_proof_with(x1) ->
+   fTACTIC_COM x1;
+   fNODE "proof_with" 1
+| CT_pwd -> fNODE "pwd" 0
+| CT_quit -> fNODE "quit" 0
+| CT_read_module(x1) ->
+   fID x1;
+   fNODE "read_module" 1
+| CT_rec_ml_add_path(x1) ->
+   fSTRING x1;
+   fNODE "rec_ml_add_path" 1
+| CT_recaddpath(x1, x2) ->
+   fSTRING x1;
+   fID_OPT x2;
+   fNODE "recaddpath" 2
+| CT_record(x1, x2, x3, x4, x5, x6) ->
+   fCOERCION_OPT x1;
+   fID x2;
+   fBINDER_LIST x3;
+   fFORMULA x4;
+   fID_OPT x5;
+   fRECCONSTR_LIST x6;
+   fNODE "record" 6
+| CT_remove_natural_feature(x1, x2) ->
+   fNATURAL_FEATURE x1;
+   fID x2;
+   fNODE "remove_natural_feature" 2
+| CT_require(x1, x2, x3) ->
+   fIMPEXP x1;
+   fSPEC_OPT x2;
+   fID_NE_LIST_OR_STRING x3;
+   fNODE "require" 3
+| CT_reserve(x1, x2) ->
+   fID_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "reserve" 2
+| CT_reserve_notation(x1, x2) ->
+   fSTRING x1;
+   fMODIFIER_LIST x2;
+   fNODE "reserve_notation" 2
+| CT_reset(x1) ->
+   fID x1;
+   fNODE "reset" 1
+| CT_reset_section(x1) ->
+   fID x1;
+   fNODE "reset_section" 1
+| CT_restart -> fNODE "restart" 0
+| CT_restore_state(x1) ->
+   fID x1;
+   fNODE "restore_state" 1
+| CT_resume(x1) ->
+   fID_OPT x1;
+   fNODE "resume" 1
+| CT_save(x1, x2) ->
+   fTHM_OPT x1;
+   fID_OPT x2;
+   fNODE "save" 2
+| CT_scomments(x1) ->
+   fSCOMMENT_CONTENT_LIST x1;
+   fNODE "scomments" 1
+| CT_search(x1, x2) ->
+   fID x1;
+   fIN_OR_OUT_MODULES x2;
+   fNODE "search" 2
+| CT_search_about(x1, x2) ->
+   fID_OR_STRING_NE_LIST x1;
+   fIN_OR_OUT_MODULES x2;
+   fNODE "search_about" 2
+| CT_search_pattern(x1, x2) ->
+   fFORMULA x1;
+   fIN_OR_OUT_MODULES x2;
+   fNODE "search_pattern" 2
+| CT_search_rewrite(x1, x2) ->
+   fFORMULA x1;
+   fIN_OR_OUT_MODULES x2;
+   fNODE "search_rewrite" 2
+| CT_section_end(x1) ->
+   fID x1;
+   fNODE "section_end" 1
+| CT_section_struct(x1, x2, x3) ->
+   fSECTION_BEGIN x1;
+   fSECTION_BODY x2;
+   fCOMMAND x3;
+   fNODE "section_struct" 3
+| CT_set_natural(x1) ->
+   fID x1;
+   fNODE "set_natural" 1
+| CT_set_natural_default -> fNODE "set_natural_default" 0
+| CT_set_option(x1) ->
+   fTABLE x1;
+   fNODE "set_option" 1
+| CT_set_option_value(x1, x2) ->
+   fTABLE x1;
+   fSINGLE_OPTION_VALUE x2;
+   fNODE "set_option_value" 2
+| CT_set_option_value2(x1, x2) ->
+   fTABLE x1;
+   fID_OR_STRING_NE_LIST x2;
+   fNODE "set_option_value2" 2
+| CT_sethyp(x1) ->
+   fINT x1;
+   fNODE "sethyp" 1
+| CT_setundo(x1) ->
+   fINT x1;
+   fNODE "setundo" 1
+| CT_show_existentials -> fNODE "show_existentials" 0
+| CT_show_goal(x1) ->
+   fINT_OPT x1;
+   fNODE "show_goal" 1
+| CT_show_implicit(x1) ->
+   fINT x1;
+   fNODE "show_implicit" 1
+| CT_show_intro -> fNODE "show_intro" 0
+| CT_show_intros -> fNODE "show_intros" 0
+| CT_show_node -> fNODE "show_node" 0
+| CT_show_proof -> fNODE "show_proof" 0
+| CT_show_proofs -> fNODE "show_proofs" 0
+| CT_show_script -> fNODE "show_script" 0
+| CT_show_tree -> fNODE "show_tree" 0
+| CT_solve(x1, x2, x3) ->
+   fINT x1;
+   fTACTIC_COM x2;
+   fDOTDOT_OPT x3;
+   fNODE "solve" 3
+| CT_suspend -> fNODE "suspend" 0
+| CT_syntax_macro(x1, x2, x3) ->
+   fID x1;
+   fFORMULA x2;
+   fINT_OPT x3;
+   fNODE "syntax_macro" 3
+| CT_tactic_definition(x1) ->
+   fTAC_DEF_NE_LIST x1;
+   fNODE "tactic_definition" 1
+| CT_test_natural_feature(x1, x2) ->
+   fNATURAL_FEATURE x1;
+   fID x2;
+   fNODE "test_natural_feature" 2
+| CT_theorem_struct(x1, x2) ->
+   fTHEOREM_GOAL x1;
+   fPROOF_SCRIPT x2;
+   fNODE "theorem_struct" 2
+| CT_time(x1) ->
+   fCOMMAND x1;
+   fNODE "time" 1
+| CT_transparent(x1) ->
+   fID_NE_LIST x1;
+   fNODE "transparent" 1
+| CT_undo(x1) ->
+   fINT_OPT x1;
+   fNODE "undo" 1
+| CT_unfocus -> fNODE "unfocus" 0
+| CT_unset_option(x1) ->
+   fTABLE x1;
+   fNODE "unset_option" 1
+| CT_unsethyp -> fNODE "unsethyp" 0
+| CT_unsetundo -> fNODE "unsetundo" 0
+| CT_user_vernac(x1, x2) ->
+   fID x1;
+   fVARG_LIST x2;
+   fNODE "user_vernac" 2
+| CT_variable(x1, x2) ->
+   fVAR x1;
+   fBINDER_NE_LIST x2;
+   fNODE "variable" 2
+| CT_write_module(x1, x2) ->
+   fID x1;
+   fSTRING_OPT x2;
+   fNODE "write_module" 2
+and fCOMMAND_LIST = function
+| CT_command_list(x,l) ->
+   fCOMMAND x;
+   (List.iter fCOMMAND l);
+   fNODE "command_list" (1 + (List.length l))
+and fCOMMENT = function
+| CT_comment x -> fATOM "comment";
+   (f_atom_string x);
+   print_string "\n"and fCOMMENT_S = function
+| CT_comment_s l ->
+   (List.iter fCOMMENT l);
+   fNODE "comment_s" (List.length l)
+and fCONSTR = function
+| CT_constr(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "constr" 2
+| CT_constr_coercion(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "constr_coercion" 2
+and fCONSTR_LIST = function
+| CT_constr_list l ->
+   (List.iter fCONSTR l);
+   fNODE "constr_list" (List.length l)
+and fCONTEXT_HYP_LIST = function
+| CT_context_hyp_list l ->
+   (List.iter fPREMISE_PATTERN l);
+   fNODE "context_hyp_list" (List.length l)
+and fCONTEXT_PATTERN = function
+| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x
+| CT_context(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "context" 2
+and fCONTEXT_RULE = function
+| CT_context_rule(x1, x2, x3) ->
+   fCONTEXT_HYP_LIST x1;
+   fCONTEXT_PATTERN x2;
+   fTACTIC_COM x3;
+   fNODE "context_rule" 3
+| CT_def_context_rule(x1) ->
+   fTACTIC_COM x1;
+   fNODE "def_context_rule" 1
+and fCONVERSION_FLAG = function
+| CT_beta -> fNODE "beta" 0
+| CT_delta -> fNODE "delta" 0
+| CT_evar -> fNODE "evar" 0
+| CT_iota -> fNODE "iota" 0
+| CT_zeta -> fNODE "zeta" 0
+and fCONVERSION_FLAG_LIST = function
+| CT_conversion_flag_list l ->
+   (List.iter fCONVERSION_FLAG l);
+   fNODE "conversion_flag_list" (List.length l)
+and fCONV_SET = function
+| CT_unf l ->
+   (List.iter fID l);
+   fNODE "unf" (List.length l)
+| CT_unfbut l ->
+   (List.iter fID l);
+   fNODE "unfbut" (List.length l)
+and fCO_IND = function
+| CT_co_ind x -> fATOM "co_ind";
+   (f_atom_string x);
+   print_string "\n"and fDECL_NOTATION_OPT = function
+| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x
+| CT_decl_notation(x1, x2, x3) ->
+   fSTRING x1;
+   fFORMULA x2;
+   fID_OPT x3;
+   fNODE "decl_notation" 3
+and fDEF = function
+| CT_def(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "def" 2
+and fDEFN = function
+| CT_defn x -> fATOM "defn";
+   (f_atom_string x);
+   print_string "\n"and fDEFN_OR_THM = function
+| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x
+| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x
+and fDEF_BODY = function
+| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x
+| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x
+| CT_type_of(x1) ->
+   fFORMULA x1;
+   fNODE "type_of" 1
+and fDEF_BODY_OPT = function
+| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x
+| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x
+and fDEP = function
+| CT_dep x -> fATOM "dep";
+   (f_atom_string x);
+   print_string "\n"and fDESTRUCTING = function
+| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x
+| CT_destructing -> fNODE "destructing" 0
+and fDESTRUCT_LOCATION = function
+| CT_conclusion_location -> fNODE "conclusion_location" 0
+| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0
+| CT_hypothesis_location -> fNODE "hypothesis_location" 0
+and fDOTDOT_OPT = function
+| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x
+| CT_dotdot -> fNODE "dotdot" 0
+and fEQN = function
+| CT_eqn(x1, x2) ->
+   fMATCH_PATTERN_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "eqn" 2
+and fEQN_LIST = function
+| CT_eqn_list l ->
+   (List.iter fEQN l);
+   fNODE "eqn_list" (List.length l)
+and fEVAL_CMD = function
+| CT_eval(x1, x2, x3) ->
+   fINT_OPT x1;
+   fRED_COM x2;
+   fFORMULA x3;
+   fNODE "eval" 3
+and fFIXTAC = function
+| CT_fixtac(x1, x2, x3) ->
+   fID x1;
+   fINT x2;
+   fFORMULA x3;
+   fNODE "fixtac" 3
+and fFIX_BINDER = function
+| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x
+| CT_fix_binder(x1, x2, x3, x4) ->
+   fID x1;
+   fINT x2;
+   fFORMULA x3;
+   fFORMULA x4;
+   fNODE "fix_binder" 4
+and fFIX_BINDER_LIST = function
+| CT_fix_binder_list(x,l) ->
+   fFIX_BINDER x;
+   (List.iter fFIX_BINDER l);
+   fNODE "fix_binder_list" (1 + (List.length l))
+and fFIX_REC = function
+| CT_fix_rec(x1, x2, x3, x4, x5) ->
+   fID x1;
+   fBINDER_NE_LIST x2;
+   fID_OPT x3;
+   fFORMULA x4;
+   fFORMULA x5;
+   fNODE "fix_rec" 5
+and fFIX_REC_LIST = function
+| CT_fix_rec_list(x,l) ->
+   fFIX_REC x;
+   (List.iter fFIX_REC l);
+   fNODE "fix_rec_list" (1 + (List.length l))
+and fFIX_TAC_LIST = function
+| CT_fix_tac_list l ->
+   (List.iter fFIXTAC l);
+   fNODE "fix_tac_list" (List.length l)
+and fFORMULA = function
+| CT_coerce_BINARY_to_FORMULA x -> fBINARY x
+| CT_coerce_ID_to_FORMULA x -> fID x
+| CT_coerce_NUM_to_FORMULA x -> fNUM x
+| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x
+| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x
+| CT_appc(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA_NE_LIST x2;
+   fNODE "appc" 2
+| CT_arrowc(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA x2;
+   fNODE "arrowc" 2
+| CT_bang(x1) ->
+   fFORMULA x1;
+   fNODE "bang" 1
+| CT_cases(x1, x2, x3) ->
+   fMATCHED_FORMULA_NE_LIST x1;
+   fFORMULA_OPT x2;
+   fEQN_LIST x3;
+   fNODE "cases" 3
+| CT_cofixc(x1, x2) ->
+   fID x1;
+   fCOFIX_REC_LIST x2;
+   fNODE "cofixc" 2
+| CT_elimc(x1, x2, x3, x4) ->
+   fCASE x1;
+   fFORMULA_OPT x2;
+   fFORMULA x3;
+   fFORMULA_LIST x4;
+   fNODE "elimc" 4
+| CT_existvarc -> fNODE "existvarc" 0
+| CT_fixc(x1, x2) ->
+   fID x1;
+   fFIX_BINDER_LIST x2;
+   fNODE "fixc" 2
+| CT_if(x1, x2, x3, x4) ->
+   fFORMULA x1;
+   fRETURN_INFO x2;
+   fFORMULA x3;
+   fFORMULA x4;
+   fNODE "if" 4
+| CT_inductive_let(x1, x2, x3, x4) ->
+   fFORMULA_OPT x1;
+   fID_OPT_NE_LIST x2;
+   fFORMULA x3;
+   fFORMULA x4;
+   fNODE "inductive_let" 4
+| CT_labelled_arg(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "labelled_arg" 2
+| CT_lambdac(x1, x2) ->
+   fBINDER_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "lambdac" 2
+| CT_let_tuple(x1, x2, x3, x4) ->
+   fID_OPT_NE_LIST x1;
+   fRETURN_INFO x2;
+   fFORMULA x3;
+   fFORMULA x4;
+   fNODE "let_tuple" 4
+| CT_letin(x1, x2) ->
+   fDEF x1;
+   fFORMULA x2;
+   fNODE "letin" 2
+| CT_notation(x1, x2) ->
+   fSTRING x1;
+   fFORMULA_LIST x2;
+   fNODE "notation" 2
+| CT_num_encapsulator(x1, x2) ->
+   fNUM_TYPE x1;
+   fFORMULA x2;
+   fNODE "num_encapsulator" 2
+| CT_prodc(x1, x2) ->
+   fBINDER_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "prodc" 2
+| CT_proj(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA_NE_LIST x2;
+   fNODE "proj" 2
+and fFORMULA_LIST = function
+| CT_formula_list l ->
+   (List.iter fFORMULA l);
+   fNODE "formula_list" (List.length l)
+and fFORMULA_NE_LIST = function
+| CT_formula_ne_list(x,l) ->
+   fFORMULA x;
+   (List.iter fFORMULA l);
+   fNODE "formula_ne_list" (1 + (List.length l))
+and fFORMULA_OPT = function
+| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x
+| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x
+and fFORMULA_OR_INT = function
+| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x
+| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x
+and fGRAMMAR = function
+| CT_grammar_none -> fNODE "grammar_none" 0
+and fHYP_LOCATION = function
+| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x
+| CT_intype(x1, x2) ->
+   fID x1;
+   fINT_LIST x2;
+   fNODE "intype" 2
+| CT_invalue(x1, x2) ->
+   fID x1;
+   fINT_LIST x2;
+   fNODE "invalue" 2
+and fHYP_LOCATION_LIST_OR_STAR = function
+| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x
+| CT_hyp_location_list l ->
+   (List.iter fHYP_LOCATION l);
+   fNODE "hyp_location_list" (List.length l)
+and fID = function
+| CT_ident x -> fATOM "ident";
+   (f_atom_string x);
+   print_string "\n"| CT_metac(x1) ->
+   fINT x1;
+   fNODE "metac" 1
+| CT_metaid x -> fATOM "metaid";
+   (f_atom_string x);
+   print_string "\n"and fIDENTITY_OPT = function
+| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x
+| CT_identity -> fNODE "identity" 0
+and fID_LIST = function
+| CT_id_list l ->
+   (List.iter fID l);
+   fNODE "id_list" (List.length l)
+and fID_LIST_LIST = function
+| CT_id_list_list l ->
+   (List.iter fID_LIST l);
+   fNODE "id_list_list" (List.length l)
+and fID_LIST_OPT = function
+| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x
+| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x
+and fID_NE_LIST = function
+| CT_id_ne_list(x,l) ->
+   fID x;
+   (List.iter fID l);
+   fNODE "id_ne_list" (1 + (List.length l))
+and fID_NE_LIST_OR_STAR = function
+| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x
+| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x
+and fID_NE_LIST_OR_STRING = function
+| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x
+| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x
+and fID_OPT = function
+| CT_coerce_ID_to_ID_OPT x -> fID x
+| CT_coerce_NONE_to_ID_OPT x -> fNONE x
+and fID_OPT_LIST = function
+| CT_id_opt_list l ->
+   (List.iter fID_OPT l);
+   fNODE "id_opt_list" (List.length l)
+and fID_OPT_NE_LIST = function
+| CT_id_opt_ne_list(x,l) ->
+   fID_OPT x;
+   (List.iter fID_OPT l);
+   fNODE "id_opt_ne_list" (1 + (List.length l))
+and fID_OPT_OR_ALL = function
+| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x
+| CT_all -> fNODE "all" 0
+and fID_OR_INT = function
+| CT_coerce_ID_to_ID_OR_INT x -> fID x
+| CT_coerce_INT_to_ID_OR_INT x -> fINT x
+and fID_OR_INT_OPT = function
+| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x
+| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x
+| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x
+and fID_OR_STAR = function
+| CT_coerce_ID_to_ID_OR_STAR x -> fID x
+| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x
+and fID_OR_STRING = function
+| CT_coerce_ID_to_ID_OR_STRING x -> fID x
+| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x
+and fID_OR_STRING_NE_LIST = function
+| CT_id_or_string_ne_list(x,l) ->
+   fID_OR_STRING x;
+   (List.iter fID_OR_STRING l);
+   fNODE "id_or_string_ne_list" (1 + (List.length l))
+and fIMPEXP = function
+| CT_coerce_NONE_to_IMPEXP x -> fNONE x
+| CT_export -> fNODE "export" 0
+| CT_import -> fNODE "import" 0
+and fIND_SPEC = function
+| CT_ind_spec(x1, x2, x3, x4, x5) ->
+   fID x1;
+   fBINDER_LIST x2;
+   fFORMULA x3;
+   fCONSTR_LIST x4;
+   fDECL_NOTATION_OPT x5;
+   fNODE "ind_spec" 5
+and fIND_SPEC_LIST = function
+| CT_ind_spec_list l ->
+   (List.iter fIND_SPEC l);
+   fNODE "ind_spec_list" (List.length l)
+and fINT = function
+| CT_int x -> fATOM "int";
+   (f_atom_int x);
+   print_string "\n"and fINTRO_PATT = function
+| CT_coerce_ID_to_INTRO_PATT x -> fID x
+| CT_disj_pattern(x,l) ->
+   fINTRO_PATT_LIST x;
+   (List.iter fINTRO_PATT_LIST l);
+   fNODE "disj_pattern" (1 + (List.length l))
+and fINTRO_PATT_LIST = function
+| CT_intro_patt_list l ->
+   (List.iter fINTRO_PATT l);
+   fNODE "intro_patt_list" (List.length l)
+and fINTRO_PATT_OPT = function
+| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x
+| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x
+and fINT_LIST = function
+| CT_int_list l ->
+   (List.iter fINT l);
+   fNODE "int_list" (List.length l)
+and fINT_NE_LIST = function
+| CT_int_ne_list(x,l) ->
+   fINT x;
+   (List.iter fINT l);
+   fNODE "int_ne_list" (1 + (List.length l))
+and fINT_OPT = function
+| CT_coerce_INT_to_INT_OPT x -> fINT x
+| CT_coerce_NONE_to_INT_OPT x -> fNONE x
+and fINT_OR_LOCN = function
+| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x
+| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x
+and fINT_OR_NEXT = function
+| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x
+| CT_next_level -> fNODE "next_level" 0
+and fINV_TYPE = function
+| CT_inv_clear -> fNODE "inv_clear" 0
+| CT_inv_regular -> fNODE "inv_regular" 0
+| CT_inv_simple -> fNODE "inv_simple" 0
+and fIN_OR_OUT_MODULES = function
+| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x
+| CT_in_modules(x1) ->
+   fID_NE_LIST x1;
+   fNODE "in_modules" 1
+| CT_out_modules(x1) ->
+   fID_NE_LIST x1;
+   fNODE "out_modules" 1
+and fLET_CLAUSE = function
+| CT_let_clause(x1, x2, x3) ->
+   fID x1;
+   fTACTIC_OPT x2;
+   fLET_VALUE x3;
+   fNODE "let_clause" 3
+and fLET_CLAUSES = function
+| CT_let_clauses(x,l) ->
+   fLET_CLAUSE x;
+   (List.iter fLET_CLAUSE l);
+   fNODE "let_clauses" (1 + (List.length l))
+and fLET_VALUE = function
+| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x
+| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x
+and fLOCAL_OPT = function
+| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x
+| CT_local -> fNODE "local" 0
+and fLOCN = function
+| CT_locn x -> fATOM "locn";
+   (f_atom_string x);
+   print_string "\n"and fMATCHED_FORMULA = function
+| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x
+| CT_formula_as(x1, x2) ->
+   fFORMULA x1;
+   fID_OPT x2;
+   fNODE "formula_as" 2
+| CT_formula_as_in(x1, x2, x3) ->
+   fFORMULA x1;
+   fID_OPT x2;
+   fFORMULA x3;
+   fNODE "formula_as_in" 3
+| CT_formula_in(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA x2;
+   fNODE "formula_in" 2
+and fMATCHED_FORMULA_NE_LIST = function
+| CT_matched_formula_ne_list(x,l) ->
+   fMATCHED_FORMULA x;
+   (List.iter fMATCHED_FORMULA l);
+   fNODE "matched_formula_ne_list" (1 + (List.length l))
+and fMATCH_PATTERN = function
+| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x
+| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x
+| CT_pattern_app(x1, x2) ->
+   fMATCH_PATTERN x1;
+   fMATCH_PATTERN_NE_LIST x2;
+   fNODE "pattern_app" 2
+| CT_pattern_as(x1, x2) ->
+   fMATCH_PATTERN x1;
+   fID_OPT x2;
+   fNODE "pattern_as" 2
+| CT_pattern_delimitors(x1, x2) ->
+   fNUM_TYPE x1;
+   fMATCH_PATTERN x2;
+   fNODE "pattern_delimitors" 2
+| CT_pattern_notation(x1, x2) ->
+   fSTRING x1;
+   fMATCH_PATTERN_LIST x2;
+   fNODE "pattern_notation" 2
+and fMATCH_PATTERN_LIST = function
+| CT_match_pattern_list l ->
+   (List.iter fMATCH_PATTERN l);
+   fNODE "match_pattern_list" (List.length l)
+and fMATCH_PATTERN_NE_LIST = function
+| CT_match_pattern_ne_list(x,l) ->
+   fMATCH_PATTERN x;
+   (List.iter fMATCH_PATTERN l);
+   fNODE "match_pattern_ne_list" (1 + (List.length l))
+and fMATCH_TAC_RULE = function
+| CT_match_tac_rule(x1, x2) ->
+   fCONTEXT_PATTERN x1;
+   fLET_VALUE x2;
+   fNODE "match_tac_rule" 2
+and fMATCH_TAC_RULES = function
+| CT_match_tac_rules(x,l) ->
+   fMATCH_TAC_RULE x;
+   (List.iter fMATCH_TAC_RULE l);
+   fNODE "match_tac_rules" (1 + (List.length l))
+and fMODIFIER = function
+| CT_entry_type(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "entry_type" 2
+| CT_format(x1) ->
+   fSTRING x1;
+   fNODE "format" 1
+| CT_lefta -> fNODE "lefta" 0
+| CT_nona -> fNODE "nona" 0
+| CT_only_parsing -> fNODE "only_parsing" 0
+| CT_righta -> fNODE "righta" 0
+| CT_set_item_level(x1, x2) ->
+   fID_NE_LIST x1;
+   fINT_OR_NEXT x2;
+   fNODE "set_item_level" 2
+| CT_set_level(x1) ->
+   fINT x1;
+   fNODE "set_level" 1
+and fMODIFIER_LIST = function
+| CT_modifier_list l ->
+   (List.iter fMODIFIER l);
+   fNODE "modifier_list" (List.length l)
+and fMODULE_BINDER = function
+| CT_module_binder(x1, x2) ->
+   fID_NE_LIST x1;
+   fMODULE_TYPE x2;
+   fNODE "module_binder" 2
+and fMODULE_BINDER_LIST = function
+| CT_module_binder_list l ->
+   (List.iter fMODULE_BINDER l);
+   fNODE "module_binder_list" (List.length l)
+and fMODULE_EXPR = function
+| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x
+| CT_module_app(x1, x2) ->
+   fMODULE_EXPR x1;
+   fMODULE_EXPR x2;
+   fNODE "module_app" 2
+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;
+   fFORMULA x3;
+   fNODE "module_type_with_def" 3
+| CT_module_type_with_mod(x1, x2, x3) ->
+   fMODULE_TYPE x1;
+   fID x2;
+   fID x3;
+   fNODE "module_type_with_mod" 3
+and fMODULE_TYPE_CHECK = function
+| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x
+| CT_only_check(x1) ->
+   fMODULE_TYPE x1;
+   fNODE "only_check" 1
+and fMODULE_TYPE_OPT = function
+| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x
+| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x
+and fNATURAL_FEATURE = function
+| CT_contractible -> fNODE "contractible" 0
+| CT_implicit -> fNODE "implicit" 0
+| CT_nat_transparent -> fNODE "nat_transparent" 0
+and fNONE = function
+| CT_none -> fNODE "none" 0
+and fNUM = function
+| CT_int_encapsulator x -> fATOM "int_encapsulator";
+   (f_atom_string x);
+   print_string "\n"and fNUM_TYPE = function
+| CT_num_type x -> fATOM "num_type";
+   (f_atom_string x);
+   print_string "\n"and fOMEGA_FEATURE = function
+| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x
+| CT_flag_action -> fNODE "flag_action" 0
+| CT_flag_system -> fNODE "flag_system" 0
+| CT_flag_time -> fNODE "flag_time" 0
+and fOMEGA_MODE = function
+| CT_set -> fNODE "set" 0
+| CT_switch -> fNODE "switch" 0
+| CT_unset -> fNODE "unset" 0
+and fORIENTATION = function
+| CT_lr -> fNODE "lr" 0
+| CT_rl -> fNODE "rl" 0
+and fPATTERN = function
+| CT_pattern_occ(x1, x2) ->
+   fINT_LIST x1;
+   fFORMULA x2;
+   fNODE "pattern_occ" 2
+and fPATTERN_NE_LIST = function
+| CT_pattern_ne_list(x,l) ->
+   fPATTERN x;
+   (List.iter fPATTERN l);
+   fNODE "pattern_ne_list" (1 + (List.length l))
+and fPATTERN_OPT = function
+| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x
+| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x
+and fPREMISE = function
+| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x
+| CT_eval_result(x1, x2, x3) ->
+   fFORMULA x1;
+   fFORMULA x2;
+   fFORMULA x3;
+   fNODE "eval_result" 3
+| CT_premise(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "premise" 2
+and fPREMISES_LIST = function
+| CT_premises_list l ->
+   (List.iter fPREMISE l);
+   fNODE "premises_list" (List.length l)
+and fPREMISE_PATTERN = function
+| CT_premise_pattern(x1, x2) ->
+   fID_OPT x1;
+   fCONTEXT_PATTERN x2;
+   fNODE "premise_pattern" 2
+and fPROOF_SCRIPT = function
+| CT_proof_script l ->
+   (List.iter fCOMMAND l);
+   fNODE "proof_script" (List.length l)
+and fRECCONSTR = function
+| CT_defrecconstr(x1, x2, x3) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fFORMULA_OPT x3;
+   fNODE "defrecconstr" 3
+| CT_defrecconstr_coercion(x1, x2, x3) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fFORMULA_OPT x3;
+   fNODE "defrecconstr_coercion" 3
+| CT_recconstr(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "recconstr" 2
+| CT_recconstr_coercion(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "recconstr_coercion" 2
+and fRECCONSTR_LIST = function
+| CT_recconstr_list l ->
+   (List.iter fRECCONSTR l);
+   fNODE "recconstr_list" (List.length l)
+and fREC_TACTIC_FUN = function
+| CT_rec_tactic_fun(x1, x2, x3) ->
+   fID x1;
+   fID_OPT_NE_LIST x2;
+   fTACTIC_COM x3;
+   fNODE "rec_tactic_fun" 3
+and fREC_TACTIC_FUN_LIST = function
+| CT_rec_tactic_fun_list(x,l) ->
+   fREC_TACTIC_FUN x;
+   (List.iter fREC_TACTIC_FUN l);
+   fNODE "rec_tactic_fun_list" (1 + (List.length l))
+and fRED_COM = function
+| CT_cbv(x1, x2) ->
+   fCONVERSION_FLAG_LIST x1;
+   fCONV_SET x2;
+   fNODE "cbv" 2
+| CT_fold(x1) ->
+   fFORMULA_LIST x1;
+   fNODE "fold" 1
+| CT_hnf -> fNODE "hnf" 0
+| CT_lazy(x1, x2) ->
+   fCONVERSION_FLAG_LIST x1;
+   fCONV_SET x2;
+   fNODE "lazy" 2
+| CT_pattern(x1) ->
+   fPATTERN_NE_LIST x1;
+   fNODE "pattern" 1
+| CT_red -> fNODE "red" 0
+| CT_simpl(x1) ->
+   fPATTERN_OPT x1;
+   fNODE "simpl" 1
+| CT_unfold(x1) ->
+   fUNFOLD_NE_LIST x1;
+   fNODE "unfold" 1
+and fRETURN_INFO = function
+| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x
+| CT_as_and_return(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "as_and_return" 2
+| CT_return(x1) ->
+   fFORMULA x1;
+   fNODE "return" 1
+and fRULE = function
+| CT_rule(x1, x2) ->
+   fPREMISES_LIST x1;
+   fFORMULA x2;
+   fNODE "rule" 2
+and fRULE_LIST = function
+| CT_rule_list l ->
+   (List.iter fRULE l);
+   fNODE "rule_list" (List.length l)
+and fSCHEME_SPEC = function
+| CT_scheme_spec(x1, x2, x3, x4) ->
+   fID x1;
+   fDEP x2;
+   fFORMULA x3;
+   fSORT_TYPE x4;
+   fNODE "scheme_spec" 4
+and fSCHEME_SPEC_LIST = function
+| CT_scheme_spec_list(x,l) ->
+   fSCHEME_SPEC x;
+   (List.iter fSCHEME_SPEC l);
+   fNODE "scheme_spec_list" (1 + (List.length l))
+and fSCOMMENT_CONTENT = function
+| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x
+| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x
+and fSCOMMENT_CONTENT_LIST = function
+| CT_scomment_content_list l ->
+   (List.iter fSCOMMENT_CONTENT l);
+   fNODE "scomment_content_list" (List.length l)
+and fSECTION_BEGIN = function
+| CT_section(x1) ->
+   fID x1;
+   fNODE "section" 1
+and fSECTION_BODY = function
+| CT_section_body l ->
+   (List.iter fCOMMAND l);
+   fNODE "section_body" (List.length l)
+and fSIGNED_INT = function
+| CT_coerce_INT_to_SIGNED_INT x -> fINT x
+| CT_minus(x1) ->
+   fINT x1;
+   fNODE "minus" 1
+and fSIGNED_INT_LIST = function
+| CT_signed_int_list l ->
+   (List.iter fSIGNED_INT l);
+   fNODE "signed_int_list" (List.length l)
+and fSINGLE_OPTION_VALUE = function
+| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x
+| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x
+and fSORT_TYPE = function
+| CT_sortc x -> fATOM "sortc";
+   (f_atom_string x);
+   print_string "\n"and fSPEC_LIST = function
+| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x
+| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x
+and fSPEC_OPT = function
+| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x
+| CT_spec -> fNODE "spec" 0
+and fSTAR = function
+| CT_star -> fNODE "star" 0
+and fSTAR_OPT = function
+| CT_coerce_NONE_to_STAR_OPT x -> fNONE x
+| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x
+and fSTRING = function
+| CT_string x -> fATOM "string";
+   (f_atom_string x);
+   print_string "\n"and fSTRING_NE_LIST = function
+| CT_string_ne_list(x,l) ->
+   fSTRING x;
+   (List.iter fSTRING l);
+   fNODE "string_ne_list" (1 + (List.length l))
+and fSTRING_OPT = function
+| CT_coerce_NONE_to_STRING_OPT x -> fNONE x
+| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x
+and fTABLE = function
+| CT_coerce_ID_to_TABLE x -> fID x
+| CT_table(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "table" 2
+and fTACTIC_ARG = function
+| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x
+| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x
+| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x
+| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x
+| CT_void -> fNODE "void" 0
+and fTACTIC_ARG_LIST = function
+| CT_tactic_arg_list(x,l) ->
+   fTACTIC_ARG x;
+   (List.iter fTACTIC_ARG l);
+   fNODE "tactic_arg_list" (1 + (List.length l))
+and fTACTIC_COM = function
+| CT_abstract(x1, x2) ->
+   fID_OPT x1;
+   fTACTIC_COM x2;
+   fNODE "abstract" 2
+| CT_absurd(x1) ->
+   fFORMULA x1;
+   fNODE "absurd" 1
+| CT_any_constructor(x1) ->
+   fTACTIC_OPT x1;
+   fNODE "any_constructor" 1
+| CT_apply(x1, x2) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fNODE "apply" 2
+| CT_assert(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "assert" 2
+| CT_assumption -> fNODE "assumption" 0
+| CT_auto(x1) ->
+   fINT_OPT x1;
+   fNODE "auto" 1
+| CT_auto_with(x1, x2) ->
+   fINT_OPT x1;
+   fID_NE_LIST_OR_STAR x2;
+   fNODE "auto_with" 2
+| CT_autorewrite(x1, x2) ->
+   fID_NE_LIST x1;
+   fTACTIC_OPT x2;
+   fNODE "autorewrite" 2
+| CT_autotdb(x1) ->
+   fINT_OPT x1;
+   fNODE "autotdb" 1
+| CT_case_type(x1) ->
+   fFORMULA x1;
+   fNODE "case_type" 1
+| CT_casetac(x1, x2) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fNODE "casetac" 2
+| CT_cdhyp(x1) ->
+   fID x1;
+   fNODE "cdhyp" 1
+| CT_change(x1, x2) ->
+   fFORMULA x1;
+   fCLAUSE x2;
+   fNODE "change" 2
+| CT_change_local(x1, x2, x3) ->
+   fPATTERN x1;
+   fFORMULA x2;
+   fCLAUSE x3;
+   fNODE "change_local" 3
+| CT_clear(x1) ->
+   fID_NE_LIST x1;
+   fNODE "clear" 1
+| CT_clear_body(x1) ->
+   fID_NE_LIST x1;
+   fNODE "clear_body" 1
+| CT_cofixtactic(x1, x2) ->
+   fID_OPT x1;
+   fCOFIX_TAC_LIST x2;
+   fNODE "cofixtactic" 2
+| CT_condrewrite_lr(x1, x2, x3, x4) ->
+   fTACTIC_COM x1;
+   fFORMULA x2;
+   fSPEC_LIST x3;
+   fID_OPT x4;
+   fNODE "condrewrite_lr" 4
+| CT_condrewrite_rl(x1, x2, x3, x4) ->
+   fTACTIC_COM x1;
+   fFORMULA x2;
+   fSPEC_LIST x3;
+   fID_OPT x4;
+   fNODE "condrewrite_rl" 4
+| CT_constructor(x1, x2) ->
+   fINT x1;
+   fSPEC_LIST x2;
+   fNODE "constructor" 2
+| CT_contradiction -> fNODE "contradiction" 0
+| CT_contradiction_thm(x1, x2) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fNODE "contradiction_thm" 2
+| CT_cut(x1) ->
+   fFORMULA x1;
+   fNODE "cut" 1
+| CT_cutrewrite_lr(x1, x2) ->
+   fFORMULA x1;
+   fID_OPT x2;
+   fNODE "cutrewrite_lr" 2
+| CT_cutrewrite_rl(x1, x2) ->
+   fFORMULA x1;
+   fID_OPT x2;
+   fNODE "cutrewrite_rl" 2
+| CT_dauto(x1, x2) ->
+   fINT_OPT x1;
+   fINT_OPT x2;
+   fNODE "dauto" 2
+| CT_dconcl -> fNODE "dconcl" 0
+| CT_decompose_list(x1, x2) ->
+   fID_NE_LIST x1;
+   fFORMULA x2;
+   fNODE "decompose_list" 2
+| CT_decompose_record(x1) ->
+   fFORMULA x1;
+   fNODE "decompose_record" 1
+| CT_decompose_sum(x1) ->
+   fFORMULA x1;
+   fNODE "decompose_sum" 1
+| CT_depinversion(x1, x2, x3, x4) ->
+   fINV_TYPE x1;
+   fID_OR_INT x2;
+   fINTRO_PATT_OPT x3;
+   fFORMULA_OPT x4;
+   fNODE "depinversion" 4
+| CT_deprewrite_lr(x1) ->
+   fID x1;
+   fNODE "deprewrite_lr" 1
+| CT_deprewrite_rl(x1) ->
+   fID x1;
+   fNODE "deprewrite_rl" 1
+| CT_destruct(x1) ->
+   fID_OR_INT x1;
+   fNODE "destruct" 1
+| CT_dhyp(x1) ->
+   fID x1;
+   fNODE "dhyp" 1
+| CT_discriminate_eq(x1) ->
+   fID_OR_INT_OPT x1;
+   fNODE "discriminate_eq" 1
+| CT_do(x1, x2) ->
+   fID_OR_INT x1;
+   fTACTIC_COM x2;
+   fNODE "do" 2
+| CT_eapply(x1, x2) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fNODE "eapply" 2
+| CT_eauto(x1, x2) ->
+   fID_OR_INT_OPT x1;
+   fID_OR_INT_OPT x2;
+   fNODE "eauto" 2
+| CT_eauto_with(x1, x2, x3) ->
+   fID_OR_INT_OPT x1;
+   fID_OR_INT_OPT x2;
+   fID_NE_LIST_OR_STAR x3;
+   fNODE "eauto_with" 3
+| CT_elim(x1, x2, x3) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fUSING x3;
+   fNODE "elim" 3
+| CT_elim_type(x1) ->
+   fFORMULA x1;
+   fNODE "elim_type" 1
+| CT_exact(x1) ->
+   fFORMULA x1;
+   fNODE "exact" 1
+| CT_exists(x1) ->
+   fSPEC_LIST x1;
+   fNODE "exists" 1
+| CT_fail(x1, x2) ->
+   fID_OR_INT x1;
+   fSTRING_OPT x2;
+   fNODE "fail" 2
+| CT_first(x,l) ->
+   fTACTIC_COM x;
+   (List.iter fTACTIC_COM l);
+   fNODE "first" (1 + (List.length l))
+| CT_firstorder(x1) ->
+   fTACTIC_OPT x1;
+   fNODE "firstorder" 1
+| CT_firstorder_using(x1, x2) ->
+   fTACTIC_OPT x1;
+   fID_NE_LIST x2;
+   fNODE "firstorder_using" 2
+| CT_firstorder_with(x1, x2) ->
+   fTACTIC_OPT x1;
+   fID_NE_LIST x2;
+   fNODE "firstorder_with" 2
+| CT_fixtactic(x1, x2, x3) ->
+   fID_OPT x1;
+   fINT x2;
+   fFIX_TAC_LIST x3;
+   fNODE "fixtactic" 3
+| CT_formula_marker(x1) ->
+   fFORMULA x1;
+   fNODE "formula_marker" 1
+| CT_fresh(x1) ->
+   fSTRING_OPT x1;
+   fNODE "fresh" 1
+| CT_generalize(x1) ->
+   fFORMULA_NE_LIST x1;
+   fNODE "generalize" 1
+| CT_generalize_dependent(x1) ->
+   fFORMULA x1;
+   fNODE "generalize_dependent" 1
+| CT_idtac(x1) ->
+   fSTRING_OPT x1;
+   fNODE "idtac" 1
+| CT_induction(x1) ->
+   fID_OR_INT x1;
+   fNODE "induction" 1
+| CT_info(x1) ->
+   fTACTIC_COM x1;
+   fNODE "info" 1
+| CT_injection_eq(x1) ->
+   fID_OR_INT_OPT x1;
+   fNODE "injection_eq" 1
+| CT_instantiate(x1, x2, x3) ->
+   fINT x1;
+   fFORMULA x2;
+   fCLAUSE x3;
+   fNODE "instantiate" 3
+| CT_intro(x1) ->
+   fID_OPT x1;
+   fNODE "intro" 1
+| CT_intro_after(x1, x2) ->
+   fID_OPT x1;
+   fID x2;
+   fNODE "intro_after" 2
+| CT_intros(x1) ->
+   fINTRO_PATT_LIST x1;
+   fNODE "intros" 1
+| CT_intros_until(x1) ->
+   fID_OR_INT x1;
+   fNODE "intros_until" 1
+| CT_inversion(x1, x2, x3, x4) ->
+   fINV_TYPE x1;
+   fID_OR_INT x2;
+   fINTRO_PATT_OPT x3;
+   fID_LIST x4;
+   fNODE "inversion" 4
+| CT_left(x1) ->
+   fSPEC_LIST x1;
+   fNODE "left" 1
+| CT_let_ltac(x1, x2) ->
+   fLET_CLAUSES x1;
+   fLET_VALUE x2;
+   fNODE "let_ltac" 2
+| CT_lettac(x1, x2, x3) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fCLAUSE x3;
+   fNODE "lettac" 3
+| CT_match_context(x,l) ->
+   fCONTEXT_RULE x;
+   (List.iter fCONTEXT_RULE l);
+   fNODE "match_context" (1 + (List.length l))
+| CT_match_context_reverse(x,l) ->
+   fCONTEXT_RULE x;
+   (List.iter fCONTEXT_RULE l);
+   fNODE "match_context_reverse" (1 + (List.length l))
+| CT_match_tac(x1, x2) ->
+   fTACTIC_COM x1;
+   fMATCH_TAC_RULES x2;
+   fNODE "match_tac" 2
+| CT_move_after(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "move_after" 2
+| CT_new_destruct(x1, x2, x3) ->
+   fFORMULA_OR_INT x1;
+   fUSING x2;
+   fINTRO_PATT_OPT x3;
+   fNODE "new_destruct" 3
+| CT_new_induction(x1, x2, x3) ->
+   fFORMULA_OR_INT x1;
+   fUSING x2;
+   fINTRO_PATT_OPT x3;
+   fNODE "new_induction" 3
+| CT_omega -> fNODE "omega" 0
+| CT_orelse(x1, x2) ->
+   fTACTIC_COM x1;
+   fTACTIC_COM x2;
+   fNODE "orelse" 2
+| CT_parallel(x,l) ->
+   fTACTIC_COM x;
+   (List.iter fTACTIC_COM l);
+   fNODE "parallel" (1 + (List.length l))
+| CT_pose(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "pose" 2
+| CT_progress(x1) ->
+   fTACTIC_COM x1;
+   fNODE "progress" 1
+| CT_prolog(x1, x2) ->
+   fFORMULA_LIST x1;
+   fINT x2;
+   fNODE "prolog" 2
+| CT_rec_tactic_in(x1, x2) ->
+   fREC_TACTIC_FUN_LIST x1;
+   fTACTIC_COM x2;
+   fNODE "rec_tactic_in" 2
+| CT_reduce(x1, x2) ->
+   fRED_COM x1;
+   fCLAUSE x2;
+   fNODE "reduce" 2
+| CT_refine(x1) ->
+   fFORMULA x1;
+   fNODE "refine" 1
+| CT_reflexivity -> fNODE "reflexivity" 0
+| CT_rename(x1, x2) ->
+   fID x1;
+   fID x2;
+   fNODE "rename" 2
+| CT_repeat(x1) ->
+   fTACTIC_COM x1;
+   fNODE "repeat" 1
+| CT_replace_with(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA x2;
+   fNODE "replace_with" 2
+| CT_rewrite_lr(x1, x2, x3) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fID_OPT x3;
+   fNODE "rewrite_lr" 3
+| CT_rewrite_rl(x1, x2, x3) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fID_OPT x3;
+   fNODE "rewrite_rl" 3
+| CT_right(x1) ->
+   fSPEC_LIST x1;
+   fNODE "right" 1
+| CT_ring(x1) ->
+   fFORMULA_LIST x1;
+   fNODE "ring" 1
+| CT_simple_user_tac(x1, x2) ->
+   fID x1;
+   fTACTIC_ARG_LIST x2;
+   fNODE "simple_user_tac" 2
+| CT_simplify_eq(x1) ->
+   fID_OR_INT_OPT x1;
+   fNODE "simplify_eq" 1
+| CT_specialize(x1, x2, x3) ->
+   fINT_OPT x1;
+   fFORMULA x2;
+   fSPEC_LIST x3;
+   fNODE "specialize" 3
+| CT_split(x1) ->
+   fSPEC_LIST x1;
+   fNODE "split" 1
+| CT_subst(x1) ->
+   fID_LIST x1;
+   fNODE "subst" 1
+| CT_superauto(x1, x2, x3, x4) ->
+   fINT_OPT x1;
+   fID_LIST x2;
+   fDESTRUCTING x3;
+   fUSINGTDB x4;
+   fNODE "superauto" 4
+| CT_symmetry(x1) ->
+   fCLAUSE x1;
+   fNODE "symmetry" 1
+| CT_tac_double(x1, x2) ->
+   fID_OR_INT x1;
+   fID_OR_INT x2;
+   fNODE "tac_double" 2
+| CT_tacsolve(x,l) ->
+   fTACTIC_COM x;
+   (List.iter fTACTIC_COM l);
+   fNODE "tacsolve" (1 + (List.length l))
+| CT_tactic_fun(x1, x2) ->
+   fID_OPT_NE_LIST x1;
+   fTACTIC_COM x2;
+   fNODE "tactic_fun" 2
+| CT_then(x,l) ->
+   fTACTIC_COM x;
+   (List.iter fTACTIC_COM l);
+   fNODE "then" (1 + (List.length l))
+| CT_transitivity(x1) ->
+   fFORMULA x1;
+   fNODE "transitivity" 1
+| CT_trivial -> fNODE "trivial" 0
+| CT_trivial_with(x1) ->
+   fID_NE_LIST_OR_STAR x1;
+   fNODE "trivial_with" 1
+| CT_truecut(x1, x2) ->
+   fID_OPT x1;
+   fFORMULA x2;
+   fNODE "truecut" 2
+| CT_try(x1) ->
+   fTACTIC_COM x1;
+   fNODE "try" 1
+| CT_use(x1) ->
+   fFORMULA x1;
+   fNODE "use" 1
+| CT_use_inversion(x1, x2, x3) ->
+   fID_OR_INT x1;
+   fFORMULA x2;
+   fID_LIST x3;
+   fNODE "use_inversion" 3
+| CT_user_tac(x1, x2) ->
+   fID x1;
+   fTARG_LIST x2;
+   fNODE "user_tac" 2
+and fTACTIC_OPT = function
+| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x
+| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x
+and fTAC_DEF = function
+| CT_tac_def(x1, x2) ->
+   fID x1;
+   fTACTIC_COM x2;
+   fNODE "tac_def" 2
+and fTAC_DEF_NE_LIST = function
+| CT_tac_def_ne_list(x,l) ->
+   fTAC_DEF x;
+   (List.iter fTAC_DEF l);
+   fNODE "tac_def_ne_list" (1 + (List.length l))
+and fTARG = function
+| CT_coerce_BINDING_to_TARG x -> fBINDING x
+| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x
+| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x
+| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x
+| CT_coerce_PATTERN_to_TARG x -> fPATTERN x
+| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x
+| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x
+| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x
+| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x
+| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x
+| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x
+| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x
+| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x
+and fTARG_LIST = function
+| CT_targ_list l ->
+   (List.iter fTARG l);
+   fNODE "targ_list" (List.length l)
+and fTERM_CHANGE = function
+| CT_check_term(x1) ->
+   fFORMULA x1;
+   fNODE "check_term" 1
+| CT_inst_term(x1, x2) ->
+   fID x1;
+   fFORMULA x2;
+   fNODE "inst_term" 2
+and fTEXT = function
+| CT_coerce_ID_to_TEXT x -> fID x
+| CT_text_formula(x1) ->
+   fFORMULA x1;
+   fNODE "text_formula" 1
+| CT_text_h l ->
+   (List.iter fTEXT l);
+   fNODE "text_h" (List.length l)
+| CT_text_hv l ->
+   (List.iter fTEXT l);
+   fNODE "text_hv" (List.length l)
+| CT_text_op l ->
+   (List.iter fTEXT l);
+   fNODE "text_op" (List.length l)
+| CT_text_path(x1) ->
+   fSIGNED_INT_LIST x1;
+   fNODE "text_path" 1
+| CT_text_v l ->
+   (List.iter fTEXT l);
+   fNODE "text_v" (List.length l)
+and fTHEOREM_GOAL = function
+| CT_goal(x1) ->
+   fFORMULA x1;
+   fNODE "goal" 1
+| CT_theorem_goal(x1, x2, x3, x4) ->
+   fDEFN_OR_THM x1;
+   fID x2;
+   fBINDER_LIST x3;
+   fFORMULA x4;
+   fNODE "theorem_goal" 4
+and fTHM = function
+| CT_thm x -> fATOM "thm";
+   (f_atom_string x);
+   print_string "\n"and fTHM_OPT = function
+| CT_coerce_NONE_to_THM_OPT x -> fNONE x
+| CT_coerce_THM_to_THM_OPT x -> fTHM x
+and fTYPED_FORMULA = function
+| CT_typed_formula(x1, x2) ->
+   fFORMULA x1;
+   fFORMULA x2;
+   fNODE "typed_formula" 2
+and fUNFOLD = function
+| CT_coerce_ID_to_UNFOLD x -> fID x
+| CT_unfold_occ(x1, x2) ->
+   fID x1;
+   fINT_NE_LIST x2;
+   fNODE "unfold_occ" 2
+and fUNFOLD_NE_LIST = function
+| CT_unfold_ne_list(x,l) ->
+   fUNFOLD x;
+   (List.iter fUNFOLD l);
+   fNODE "unfold_ne_list" (1 + (List.length l))
+and fUSING = function
+| CT_coerce_NONE_to_USING x -> fNONE x
+| CT_using(x1, x2) ->
+   fFORMULA x1;
+   fSPEC_LIST x2;
+   fNODE "using" 2
+and fUSINGTDB = function
+| CT_coerce_NONE_to_USINGTDB x -> fNONE x
+| CT_usingtdb -> fNODE "usingtdb" 0
+and fVAR = function
+| CT_var x -> fATOM "var";
+   (f_atom_string x);
+   print_string "\n"and fVARG = function
+| CT_coerce_AST_to_VARG x -> fAST x
+| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x
+| CT_coerce_BINDER_to_VARG x -> fBINDER x
+| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x
+| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x
+| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x
+| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x
+| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x
+| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x
+| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x
+| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x
+| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x
+| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x
+| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x
+| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x
+and fVARG_LIST = function
+| CT_varg_list l ->
+   (List.iter fVARG l);
+   fNODE "varg_list" (List.length l)
+and fVERBOSE_OPT = function
+| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x
+| CT_verbose -> fNODE "verbose" 0
+;;
diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli
new file mode 100644
index 00000000..fe30b317
--- /dev/null
+++ b/contrib/interface/vtp.mli
@@ -0,0 +1,15 @@
+open Ascent;;
+
+val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;;
+val fCOMMAND : ct_COMMAND -> unit;;
+val fTACTIC_COM : ct_TACTIC_COM -> unit;;
+val fFORMULA : ct_FORMULA -> unit;;
+val fID : ct_ID -> unit;;
+val fSTRING : ct_STRING -> unit;;
+val fINT : ct_INT -> unit;;
+val fRULE_LIST : ct_RULE_LIST -> unit;;
+val fRULE : ct_RULE -> unit;;
+val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;;
+val fPREMISES_LIST : ct_PREMISES_LIST -> unit;;
+val fID_LIST : ct_ID_LIST -> unit;;
+val fTEXT : ct_TEXT -> unit;;
\ No newline at end of file
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
new file mode 100644
index 00000000..ed51b9cb
--- /dev/null
+++ b/contrib/interface/xlate.ml
@@ -0,0 +1,2118 @@
+(** Translation from coq abstract syntax trees to centaur vernac
+   *)
+open String;;
+open Char;;
+open Util;;
+open Ast;;
+open Names;;
+open Ascent;;
+open Genarg;;
+open Rawterm;;
+open Tacexpr;;
+open Vernacexpr;;
+open Decl_kinds;;
+open Topconstr;;
+open Libnames;;
+open Goptions;;
+
+
+let in_coq_ref = ref false;;
+
+let declare_in_coq () = in_coq_ref:=true;;
+
+let in_coq () = !in_coq_ref;;
+
+(* // Verify whether this is dead code, as of coq version 7 *)
+(* The following three sentences have been added to cope with a change 
+of strategy from the Coq team in the way rules construct ast's.  The
+problem is that now grammar rules will refer to identifiers by giving
+their absolute name, using the mutconstruct when needed.  Unfortunately,
+when you have a mutconstruct structure, you don't have a way to guess
+the corresponding identifier without an environment, and the parser
+does not have an environment.  We add one, only for the constructs
+that are always loaded. *)
+let type_table = ((Hashtbl.create 17) :
+      (string, ((string array) array)) Hashtbl.t);;
+
+Hashtbl.add type_table "Coq.Init.Logic.and"
+  [|[|"dummy";"conj"|]|];;
+
+Hashtbl.add type_table "Coq.Init.Datatypes.prod"
+  [|[|"dummy";"pair"|]|];;
+
+Hashtbl.add type_table "Coq.Init.Datatypes.nat"
+  [|[|"";"O"; "S"|]|];;
+
+Hashtbl.add type_table "Coq.ZArith.fast_integer.Z"
+[|[|"";"ZERO";"POS";"NEG"|]|];;
+
+
+Hashtbl.add type_table "Coq.ZArith.fast_integer.positive"
+[|[|"";"xI";"xO";"xH"|]|];;
+
+(*The following two codes are added to cope with the distinction
+  between ocaml and caml-light syntax while using ctcaml to
+  manipulate the program *)
+let code_plus = code (get "+" 0);;
+
+let code_minus = code (get "-" 0);;
+
+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 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 ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;;
+
+let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;;
+
+let ctf_STRING_OPT = function
+  | None -> ctf_STRING_OPT_NONE
+  | Some s -> ctf_STRING_OPT_SOME (CT_string s)
+
+let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;;
+
+let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;;
+
+let ctv_ID_OPT_OR_ALL_NONE =
+ CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);;
+
+let ctv_FORMULA_OPT_NONE =
+  CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);;
+
+let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;;
+
+let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT 
+			      ctv_FORMULA_OPT_NONE;;
+
+let ctf_ID_OPT_OR_ALL_SOME s =
+ CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);;
+
+let ctv_ID_OPT_OR_ALL_ALL = CT_all;;
+
+let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;;
+
+let ct_coerce_FORMULA_to_DEF_BODY x =
+    CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
+    (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);;
+
+let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;;
+
+let varc x = CT_coerce_ID_to_FORMULA x;;
+
+let xlate_ident id = CT_ident (string_of_id id)
+
+let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);;
+
+let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);;
+
+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);;
+
+type iTARG =   Targ_command of ct_FORMULA
+             | Targ_intropatt of ct_INTRO_PATT_LIST
+             | Targ_id_list of ct_ID_LIST
+             | Targ_spec_list of ct_SPEC_LIST
+             | Targ_binding_com of ct_FORMULA
+             | Targ_ident of ct_ID
+             | Targ_int of ct_INT
+             | Targ_binding of ct_BINDING
+             | Targ_pattern of ct_PATTERN
+             | Targ_unfold of ct_UNFOLD
+	     | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST
+             | Targ_string of ct_STRING
+             | Targ_fixtac of ct_FIXTAC
+             | Targ_cofixtac of ct_COFIXTAC
+             | Targ_tacexp of ct_TACTIC_COM
+             | Targ_redexp of ct_RED_COM;;
+
+type iVARG =   Varg_binder of ct_BINDER
+             | Varg_binderlist of ct_BINDER_LIST
+             | Varg_bindernelist of ct_BINDER_NE_LIST
+             | Varg_call of ct_ID * iVARG list
+             | Varg_constr of ct_FORMULA
+             | Varg_sorttype of ct_SORT_TYPE
+             | Varg_constrlist of ct_FORMULA list
+             | Varg_ident of ct_ID
+             | Varg_int of ct_INT
+             | Varg_intlist of ct_INT_LIST
+             | Varg_none
+             | Varg_string of ct_STRING
+             | Varg_tactic of ct_TACTIC_COM
+             | Varg_ast of ct_AST
+             | Varg_astlist of ct_AST_LIST
+             | Varg_tactic_arg of iTARG
+             | Varg_varglist of iVARG list;;
+
+
+let coerce_iVARG_to_FORMULA =
+ function
+    | Varg_constr x -> x
+    | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x
+    | Varg_ident id -> CT_coerce_ID_to_FORMULA id
+    | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";;
+
+let coerce_iVARG_to_ID =
+ function Varg_ident id -> id
+    | _ -> xlate_error "coerce_iVARG_to_ID";;
+
+let coerce_VARG_to_ID =
+ function
+    | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) ->
+     x
+    | _ -> xlate_error "coerce_VARG_to_ID";;
+
+let xlate_ident_opt =
+  function
+    | None -> ctv_ID_OPT_NONE
+    | Some id -> ctf_ID_OPT_SOME (xlate_ident id)
+
+let xlate_id_to_id_or_int_opt s =
+   CT_coerce_ID_OPT_to_ID_OR_INT_OPT
+     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));;
+
+let xlate_int_to_id_or_int_opt n =
+   CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
+     (CT_coerce_INT_to_ID_OR_INT (CT_int n));;
+
+let none_in_id_or_int_opt =
+  CT_coerce_ID_OPT_to_ID_OR_INT_OPT
+    (CT_coerce_NONE_to_ID_OPT(CT_none));;
+
+let xlate_int_opt = function
+  | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n)
+  | None ->  CT_coerce_NONE_to_INT_OPT CT_none
+
+let tac_qualid_to_ct_ID ref = 
+  CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
+
+let loc_qualid_to_ct_ID ref =
+  CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
+
+let int_of_meta n = int_of_string (string_of_id n)
+let is_int_meta n = try let _ = int_of_meta n in true with _ -> false
+
+let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l)
+
+let reference_to_ct_ID = function
+  | Ident (_,id) -> CT_ident (Names.string_of_id id)
+  | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid)
+
+let xlate_class = function
+  | FunClass -> CT_ident "FUNCLASS"
+  | SortClass -> CT_ident "SORTCLASS"
+  | RefClass qid -> loc_qualid_to_ct_ID qid
+
+let id_to_pattern_var ctid =
+ match ctid with
+ | CT_metaid _ -> xlate_error "metaid not expected in pattern_var"
+ | CT_ident "_" -> 
+     CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none)
+ | CT_ident id_string ->
+     CT_coerce_ID_OPT_to_MATCH_PATTERN 
+       (CT_coerce_ID_to_ID_OPT (CT_ident id_string))
+ | CT_metac _ -> assert false;;
+
+exception Not_natural;;
+
+let xlate_sort =
+  function
+    | RProp Term.Pos -> CT_sortc "Set"
+    | RProp Term.Null -> CT_sortc "Prop"
+    | RType None -> CT_sortc "Type"
+    | RType (Some u) -> xlate_error "xlate_sort";;
+
+
+let xlate_qualid a =
+  let d,i = Libnames.repr_qualid a in
+  let l = Names.repr_dirpath d in
+  List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;;
+   
+(* // The next two functions should be modified to make direct reference
+  to a notation operator *)
+let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);;
+
+let xlate_reference = function
+    Ident(_,i) -> CT_ident (string_of_id i)
+  | Qualid(_, q) -> CT_ident (xlate_qualid q);;
+let rec xlate_match_pattern =
+ function
+   | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference  s)
+   | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_")
+   | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f)
+   | CPatCstr (_, f1 , (arg1 :: args)) ->
+     CT_pattern_app
+      (id_to_pattern_var (xlate_reference  f1),
+      CT_match_pattern_ne_list
+       (xlate_match_pattern arg1, 
+	List.map xlate_match_pattern args))
+    | CPatAlias  (_,  pattern, id) ->
+     CT_pattern_as
+      (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id))
+    | CPatDelimiters(_, key, p) -> 
+	CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p)
+    | CPatNumeral(_,n) ->
+ 	CT_coerce_NUM_to_MATCH_PATTERN
+	  (CT_int_encapsulator(Bignat.bigint_to_string n))
+    | CPatNotation(_, s, l) -> 
+	CT_pattern_notation(CT_string s,
+			    CT_match_pattern_list(List.map xlate_match_pattern l))
+;;
+
+
+let xlate_id_opt_aux = function
+    Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id))
+  | Anonymous -> ctv_ID_OPT_NONE;;
+
+let xlate_id_opt (_, v) = xlate_id_opt_aux v;;
+
+let xlate_id_opt_ne_list = function
+    [] -> assert false
+  | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);;
+
+
+let rec last = function
+    [] -> assert false
+  | [a] -> a
+  | a::tl -> last tl;;
+
+let rec decompose_last = function
+    [] -> assert false
+  | [a] -> [], a
+  | a::tl -> let rl, b = decompose_last tl in (a::rl), b;;
+
+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";;
+
+
+let rec xlate_binder = function
+    (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+and xlate_return_info = function
+| (Some Anonymous, None) | (None, None) ->
+   CT_coerce_NONE_to_RETURN_INFO CT_none
+| (None, Some t) -> CT_return(xlate_formula t)
+| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t)
+| (Some _, None) -> assert false
+and xlate_formula_opt =
+  function
+    | None -> ctv_FORMULA_OPT_NONE
+    | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e)
+
+and  xlate_binder_l = function
+    LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+  | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n,
+						       xlate_formula v))
+and 
+  xlate_match_pattern_ne_list = function
+    [] -> assert false
+  | 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)
+and 
+  xlate_binder_ne_list = function
+    [] -> assert false
+  | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l)
+and 
+  xlate_binder_list = function
+  l -> CT_binder_list( List.map xlate_binder_l l)
+and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
+
+     CRef r -> varc (xlate_reference r)
+   | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b)
+   | CProdN(_,ll,b) as whole_term -> 
+       let rec gather_binders = function
+	   CProdN(_, ll, b) ->
+	     ll@(gather_binders b)
+	 | _ -> [] in
+       let rec fetch_ultimate_body = function
+	   CProdN(_, _, b) -> fetch_ultimate_body b
+	 | a -> a in
+	 CT_prodc(xlate_binder_ne_list (gather_binders whole_term), 
+		  xlate_formula (fetch_ultimate_body b))
+   | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b)
+   | CLetIn(_, v, a, b) -> 
+       CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b)
+   | CAppExpl(_, (Some n, r), l) -> 
+       let l', last = decompose_last l in
+	 CT_proj(xlate_formula last,
+		 CT_formula_ne_list
+		   (CT_bang(varc (xlate_reference r)),
+		    List.map xlate_formula l'))
+   | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r))
+   | CAppExpl(_, (None, r), l) -> 
+       CT_appc(CT_bang(varc (xlate_reference r)),
+	       xlate_formula_ne_list l)
+   | CApp(_, (Some n,f), l) -> 
+       let l', last = decompose_last l in
+       CT_proj(xlate_formula_expl last, 
+	       CT_formula_ne_list
+		 (xlate_formula f, List.map xlate_formula_expl l'))
+   | 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)->
+       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),
+		   xlate_return_info ret_info,
+		   xlate_formula c,
+		   xlate_formula b)
+   | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()"
+   | CIf (_,c, ret_info, b1, b2) -> 
+       CT_if
+	 (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))
+   | 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) -> 
+       CT_coerce_TYPED_FORMULA_to_FORMULA
+	 (CT_typed_formula(xlate_formula e, xlate_formula t))
+   | CPatVar (_, (_,i)) when is_int_meta i ->
+       CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i)))
+   | CPatVar (_, (false, s)) ->
+       CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s))
+   | CPatVar (_, (true, s)) ->
+       xlate_error "Second order variable not supported"
+   | CEvar (_, _) -> xlate_error "CEvar not supported"
+   | CCoFix (_, (_, id), lm::lmi) -> 
+     let strip_mutcorec (fid, bl,arf, ardef) =
+	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
+                      xlate_formula arf, xlate_formula ardef) in
+        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 (struct_arg,bl,arf,ardef) =
+         if bl = [] then
+           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
+        let ardef = xlate_formula ardef in
+	match xlate_binder_list bl with
+	  | CT_binder_list (b :: bl) ->
+	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl),
+			  struct_arg, arf, ardef)
+          | _ -> xlate_error "mutual recursive" in
+       CT_fixc (xlate_ident id, 
+         	CT_fix_binder_list
+		  (CT_coerce_FIX_REC_to_FIX_BINDER 
+		     (strip_mutrec lm), List.map 
+		       (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x))
+		       lmi)) 
+   | CCoFix _ -> assert false
+   | CFix _ -> assert false
+and xlate_matched_formula = function
+    (f, (Some x, Some y)) ->
+      CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y)
+  | (f, (None, Some y)) ->
+      CT_formula_in(xlate_formula f, xlate_formula y)
+  | (f, (Some x, None)) ->
+      CT_formula_as(xlate_formula f, xlate_id_opt_aux x)
+  | (f, (None, None)) -> 
+      CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f)
+and xlate_formula_expl = function
+    (a, None) -> xlate_formula a
+  | (a, Some (_,ExplByPos i)) -> 
+      xlate_error "explicitation of implicit by rank not supported"
+  | (a, Some (_,ExplByName i)) ->
+      CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a)
+and xlate_formula_expl_ne_list = function
+    [] -> assert false
+  | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l)
+and xlate_formula_ne_list = function 
+    [] -> assert false
+  | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);;
+
+let (xlate_ident_or_metaid:
+      Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function
+    AI (_, x) -> xlate_ident x
+  | MetaId(_, x) -> CT_metaid x;;
+
+let xlate_hyp = function
+  | AI (_,id) -> xlate_ident id
+  | MetaId _ -> xlate_error "MetaId should occur only in quotations"
+
+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,_) ->
+      CT_coerce_UNFOLD_to_HYP_LOCATION 
+	(CT_coerce_ID_to_UNFOLD (xlate_ident id))
+  | AI (_,id), a::l, (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 _, _,_ -> 
+      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
+    	None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star
+      | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in
+  CT_clause
+    (hyps_info, 
+     if cls.onconcl then 
+       CT_coerce_STAR_to_STAR_OPT CT_star
+     else
+       CT_coerce_NONE_to_STAR_OPT CT_none)
+
+(** Tactics
+   *)
+let strip_targ_spec_list =
+ function
+    | Targ_spec_list x -> x
+    | _ -> xlate_error "strip tactic: non binding-list argument";;
+
+let strip_targ_binding =
+ function
+    | Targ_binding x -> x
+    | _ -> xlate_error "strip tactic: non-binding argument";;
+
+let strip_targ_command =
+ function
+    | Targ_command x -> x
+    | Targ_binding_com x -> x
+    | _ -> xlate_error "strip tactic: non-command argument";;
+
+let strip_targ_ident =
+ function
+    | Targ_ident x -> x
+    | _ -> xlate_error "strip tactic: non-ident argument";;
+
+let strip_targ_int =
+ function
+    | Targ_int x -> x
+    | _ -> xlate_error "strip tactic: non-int argument";;
+
+let strip_targ_pattern =
+ function
+    | Targ_pattern x -> x
+    | _ -> xlate_error "strip tactic: non-pattern argument";;
+
+let strip_targ_unfold =
+ function
+    | Targ_unfold x -> x
+    | _ -> xlate_error "strip tactic: non-unfold argument";;
+
+let strip_targ_fixtac =
+ function
+    | Targ_fixtac x -> x
+    | _ -> xlate_error "strip tactic: non-fixtac argument";;
+
+let strip_targ_cofixtac =
+ function
+    | Targ_cofixtac x -> x
+    | _ -> xlate_error "strip tactic: non-cofixtac argument";;
+
+(*Need to transform formula to id for "Prolog" tactic problem *)
+let make_ID_from_FORMULA =
+ function
+    | CT_coerce_ID_to_FORMULA id -> id
+    | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";;
+
+let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);;
+
+let xlate_quantified_hypothesis = function
+  | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
+  | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id)
+
+let xlate_quantified_hypothesis_opt = function
+  | None -> 
+      CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE
+  | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n
+  | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;;
+
+let xlate_id_or_int = function
+    ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n)
+  | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);;
+
+let xlate_explicit_binding (loc,h,c) = 
+  CT_binding (xlate_quantified_hypothesis h, xlate_formula c)
+
+let xlate_bindings = function
+  | ImplicitBindings l ->
+      CT_coerce_FORMULA_LIST_to_SPEC_LIST
+        (CT_formula_list (List.map xlate_formula l))
+  | ExplicitBindings l ->
+      CT_coerce_BINDING_LIST_to_SPEC_LIST
+        (CT_binding_list (List.map xlate_explicit_binding l))
+  | NoBindings ->
+      CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list [])
+
+let strip_targ_spec_list =
+ function
+    | Targ_spec_list x -> x
+    | _ -> xlate_error "strip_tar_spec_list";;
+
+let strip_targ_intropatt =
+ function
+    | Targ_intropatt x -> x
+    | _ -> xlate_error "strip_targ_intropatt";;
+
+let get_flag r =
+  let conv_flags, red_ids = 
+    if r.rDelta then
+      [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst)
+    else
+      (if r.rConst = []
+      then (* probably useless: just for compatibility *) []
+      else [CT_delta]),
+      CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in
+  let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in
+  let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in
+  let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in
+  (* Rem: EVAR flag obsolète *)
+  conv_flags, red_ids
+
+let rec xlate_intro_pattern =
+ function
+  | IntroOrAndPattern [] -> assert false
+  | IntroOrAndPattern (fp::ll) ->
+      CT_disj_pattern
+      	(CT_intro_patt_list(List.map xlate_intro_pattern fp),
+	 List.map 
+	   (fun l ->
+	      CT_intro_patt_list(List.map xlate_intro_pattern l))
+	   ll)
+  | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" )
+  | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c)
+
+let compute_INV_TYPE = function
+   FullInversionClear -> CT_inv_clear
+ | SimpleInversion -> CT_inv_simple
+ | FullInversion -> CT_inv_regular
+
+let is_tactic_special_case = function
+    "AutoRewrite" -> true
+  | _ -> false;;
+
+let xlate_context_pattern = function
+  | Term v -> 
+      CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v)
+  | Subterm (idopt, v) ->
+      CT_context(xlate_ident_opt idopt, xlate_formula v)
+
+
+let xlate_match_context_hyps = function
+  | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b);;
+
+let xlate_arg_to_id_opt = function
+    Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id))
+  | None -> ctv_ID_OPT_NONE;;
+
+let xlate_largs_to_id_opt largs =
+  match List.map xlate_arg_to_id_opt largs with
+      fst::rest -> fst, rest
+    | _ -> assert false;;
+
+let xlate_int_or_constr = function
+    ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
+  | ElimOnIdent(_,i) ->
+      CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+      	(CT_coerce_ID_to_ID_OR_INT(xlate_ident i))
+  | ElimOnAnonHyp i -> 
+      CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	(CT_coerce_INT_to_ID_OR_INT(CT_int i));;
+
+let xlate_using = function
+    None -> CT_coerce_NONE_to_USING(CT_none)
+  | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);;
+
+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);;
+
+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 rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) =
+  function
+    | TacVoid ->
+	CT_void
+    | Tacexp t -> 
+	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t)
+    | Integer n ->
+	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
+    | Reference r ->
+	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	     (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r)))
+    | TacDynamic _ ->
+	failwith "Dynamics not treated in xlate_ast"
+    | ConstrMayEval (ConstrTerm c) ->
+	CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG
+	  (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c))
+    | ConstrMayEval(ConstrEval(r,c)) ->
+	CT_coerce_EVAL_CMD_to_TACTIC_ARG
+	  (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r,
+		   xlate_formula c))
+    | ConstrMayEval(ConstrTypeOf(c)) -> 
+	CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c))
+    | MetaIdArg _ ->
+	xlate_error "MetaIdArg should only be used in quotations"
+    | t ->
+	CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t)
+
+and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) =
+ function
+   (* Moved from xlate_tactic *)
+    | TacCall (_, r, a::l) ->
+	CT_simple_user_tac
+	  (reference_to_ct_ID r,
+	    CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l))
+    | Reference (Ident (_,s)) -> ident_tac s
+    | ConstrMayEval(ConstrTerm a) ->
+	CT_formula_marker(xlate_formula a)
+    | TacFreshId s -> CT_fresh(ctf_STRING_OPT s)
+    | t -> xlate_error "TODO LATER: result other than tactic or constr"
+
+and xlate_red_tactic =
+ function
+  | Red true -> xlate_error ""
+  | Red false -> CT_red
+  | 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)))
+  | Cbv flag_list ->
+     let conv_flags, red_ids = get_flag flag_list in
+     CT_cbv (CT_conversion_flag_list conv_flags, red_ids)
+  | Lazy flag_list ->
+     let conv_flags, red_ids = get_flag flag_list in
+     CT_lazy (CT_conversion_flag_list conv_flags, red_ids)
+  | Unfold unf_list ->
+     let ct_unf_list = List.map xlate_one_unfold_block unf_list in
+     (match ct_unf_list with
+      | first :: others -> CT_unfold (CT_unfold_ne_list (first, others))
+      | [] -> error "there should be at least one thing to unfold")
+  | Fold formula_list -> 
+      CT_fold(CT_formula_list(List.map xlate_formula formula_list))
+  | Pattern l ->
+     let pat_list = List.map (fun (nums,c) ->
+          CT_pattern_occ
+           (CT_int_list (List.map (fun x -> CT_int x) nums),
+            xlate_formula c)) l in
+     (match pat_list with
+      | first :: others -> CT_pattern (CT_pattern_ne_list (first, others))
+      | [] -> error "Expecting at least one pattern in a Pattern command")
+  | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)"
+
+and xlate_local_rec_tac = function 
+ (* TODO LATER: local recursive tactics and global ones should be handled in
+    the same manner *)
+  | ((_,x),(argl,tac)) ->
+      let fst, rest = xlate_largs_to_id_opt argl in
+	CT_rec_tactic_fun(xlate_ident x,
+			  CT_id_opt_ne_list(fst, rest),
+			  xlate_tactic tac)
+
+and xlate_tactic =
+ function
+   | TacFun (largs, t) ->
+       let fst, rest =  xlate_largs_to_id_opt largs in
+       CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t)
+   | TacThen (t1,t2) -> 
+       (match xlate_tactic t1 with
+            CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2])
+	  | t -> CT_then (t,[xlate_tactic t2]))
+   | TacThens(t1,[]) -> assert false
+   | TacThens(t1,t::l) ->
+       let ct = xlate_tactic t in
+       let cl = List.map xlate_tactic l in
+       (match xlate_tactic t1 with
+	    CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)])
+	  | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)]))
+   | TacFirst([]) -> assert false
+   | 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)
+   | 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)
+   | TacAbstract(t,id_opt) -> 
+       CT_abstract((match id_opt with
+		       	None -> ctv_ID_OPT_NONE
+		      | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))),
+		   xlate_tactic t)
+   | TacProgress t -> CT_progress(xlate_tactic t)
+   | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2)
+   | TacMatch (exp, rules) ->
+        CT_match_tac(xlate_tactic exp,
+                     match List.map 
+                       (function 
+                          | Pat ([],p,tac) ->
+                              CT_match_tac_rule(xlate_context_pattern p,
+                                                mk_let_value tac)
+                          | Pat (_,p,tac) -> xlate_error"No hyps in pure Match"
+                          | All tac ->
+                              CT_match_tac_rule
+                                (CT_coerce_FORMULA_to_CONTEXT_PATTERN
+                                   CT_existvarc, 
+                                   mk_let_value tac)) rules with
+                         | [] -> assert false
+                         | fst::others ->
+                             CT_match_tac_rules(fst, others))
+   | TacMatchContext (_,[]) -> failwith ""
+   | TacMatchContext (false,rule1::rules) ->
+         CT_match_context(xlate_context_rule rule1,
+                          List.map xlate_context_rule rules)
+   | TacMatchContext (true,rule1::rules) ->
+         CT_match_context_reverse(xlate_context_rule rule1,
+                          List.map xlate_context_rule rules)
+   | TacLetIn (l, t) ->
+       let cvt_clause =
+         function
+             ((_,s),None,ConstrMayEval v) ->
+                 CT_let_clause(xlate_ident s,
+			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
+                               CT_coerce_DEF_BODY_to_LET_VALUE
+                               (formula_to_def_body v))
+           | ((_,s),None,Tacexp t) -> 
+                 CT_let_clause(xlate_ident s,
+			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
+                               CT_coerce_TACTIC_COM_to_LET_VALUE
+                               (xlate_tactic t))
+           | ((_,s),None,t) -> 
+                 CT_let_clause(xlate_ident s,
+			       CT_coerce_NONE_to_TACTIC_OPT CT_none,
+                               CT_coerce_TACTIC_COM_to_LET_VALUE
+                               (xlate_call_or_tacarg t))
+           | ((_,s),Some c,t) -> 
+	       CT_let_clause(xlate_ident s,
+			     CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c),
+                               CT_coerce_TACTIC_COM_to_LET_VALUE
+				 (xlate_call_or_tacarg t)) in
+         let cl_l = List.map cvt_clause l in
+         (match cl_l with
+            | [] -> assert false 
+            | fst::others ->
+                CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t))
+   | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition"
+   | TacLetRecIn(f1::l, t) -> 
+       let tl =  CT_rec_tactic_fun_list
+		   (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,
+				   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))
+   | 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
+	 | 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
+	      [] -> CT_firstorder t1
+	    | [l1] -> 
+		(match genarg_tag l1 with
+		     List1ArgType PreIdentArgType -> 
+		       let l2 = List.map 
+				  (fun x -> CT_ident x)
+				  (out_gen (wit_list1 rawwit_pre_ident) l1) in
+		       let fst,l3 = 
+			 match l2 with fst::l3 -> fst,l3 | [] -> assert false in
+		      	 CT_firstorder_using(t1, CT_id_ne_list(fst, l3))
+		   | List1ArgType RefArgType ->
+		       let l2 = List.map reference_to_ct_ID 
+				  (out_gen (wit_list1 rawwit_ref) l1) in
+		       let fst,l3 =
+			 match  l2 with fst::l3 -> fst, l3 | [] -> assert false in
+			 CT_firstorder_with(t1, CT_id_ne_list(fst, l3))
+		   | _ -> assert false)
+	    | _ -> assert false)
+    | TacExtend (_, "refine", [c]) ->
+       CT_refine (xlate_formula (out_gen rawwit_casted_open_constr c))
+    | TacExtend (_,"absurd",[c]) ->
+       CT_absurd (xlate_formula (out_gen rawwit_constr c))
+    | TacExtend (_,"contradiction",[opt_c]) ->
+	(match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with
+	     None -> CT_contradiction
+	   | Some(c, b) ->
+	       let c1 = xlate_formula c in
+	       let bindings = xlate_bindings b in
+		 CT_contradiction_thm(c1, bindings))
+    | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b)
+    | 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), 
+			 xlate_formula c),
+	  xlate_formula f,
+	  xlate_clause b)
+    | TacExtend (_,"contradiction",[]) -> CT_contradiction
+    | TacDoubleInduction (n1, n2) ->
+	CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2)
+    | TacExtend (_,"discriminate", [idopt]) ->
+     CT_discriminate_eq
+         (xlate_quantified_hypothesis_opt
+	    (out_gen (wit_opt rawwit_quant_hyp) idopt))
+    | TacExtend (_,"deq", [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
+		(CT_coerce_NONE_to_ID_OPT CT_none)
+	  | Some v ->
+	      CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT
+	      	(xlate_quantified_hypothesis v) in
+	  CT_simplify_eq idopt2
+    | TacExtend (_,"injection", [idopt]) ->
+     CT_injection_eq
+         (xlate_quantified_hypothesis_opt
+	    (out_gen (wit_opt rawwit_quant_hyp) idopt))
+    | TacFix (idopt, n) ->
+     CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
+    | TacMutualFix (id, n, fixtac_list) ->
+     let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in
+     CT_fixtactic
+      (ctf_ID_OPT_SOME (xlate_ident id), CT_int n,
+      CT_fix_tac_list (List.map f fixtac_list))
+    | TacCofix idopt ->
+       CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list [])
+    | TacMutualCofix (id, cofixtac_list) ->
+     let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in
+     CT_cofixtactic
+      (CT_coerce_ID_to_ID_OPT (xlate_ident id),
+      CT_cofix_tac_list (List.map f cofixtac_list))
+    | TacIntrosUntil (NamedHyp id) -> 
+	CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id))
+    | TacIntrosUntil (AnonHyp n) -> 
+	CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n))
+    | TacIntroMove (Some id1, Some (_,id2)) ->
+     CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_ident id2)
+    | TacIntroMove (None, Some (_,id2)) ->
+	CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_ident id2)
+    | TacMove (true, id1, id2) ->
+	CT_move_after(xlate_hyp id1, xlate_hyp id2)
+    | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal"
+    | TacIntroPattern patt_list ->
+	CT_intros
+	  (CT_intro_patt_list (List.map xlate_intro_pattern patt_list))
+    | TacIntroMove (Some id, None) ->
+     CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)])
+    | TacIntroMove (None, None) ->  CT_intro (CT_coerce_NONE_to_ID_OPT CT_none)
+    | TacLeft bindl -> CT_left (xlate_bindings bindl)
+    | 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
+     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
+     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_condrewrite_lr (xlate_tactic t, c, bindl, id)
+     else CT_condrewrite_rl (xlate_tactic t, c, bindl, id)
+    | TacExtend (_,"dependentrewrite", [b; id_or_constr]) ->
+      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
+	    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*)
+      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
+      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]) ->
+	CT_subst
+	  (CT_id_list
+	     (List.map (fun x -> CT_ident (string_of_id x))
+		(out_gen (wit_list1 rawwit_ident) l)))
+    | TacReflexivity -> CT_reflexivity
+    | TacSymmetry cls -> CT_symmetry(xlate_clause cls)
+    | TacTransitivity c -> CT_transitivity (xlate_formula c)
+    | TacAssumption -> CT_assumption
+    | TacExact c -> CT_exact (xlate_formula c)
+    | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id)
+    | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id)
+    | TacDestructConcl -> CT_dconcl
+    | TacSuperAuto (nopt,l,a3,a4) ->
+      CT_superauto(
+        xlate_int_opt nopt,
+        xlate_qualid_list l,
+        (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_opt nopt)
+    | TacAuto (nopt, None) ->
+ 	CT_auto_with (xlate_int_opt nopt,
+		      CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
+    | TacAuto (nopt, Some (id1::idl)) ->
+	CT_auto_with(xlate_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)))
+    |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
+       let fst, (id_list1: ct_ID list) =
+	 match id_list with [] -> assert false | a::tl -> a,tl in
+       let t1 =
+	 match t with
+	     [t0] -> 
+	       CT_coerce_TACTIC_COM_to_TACTIC_OPT
+		 (xlate_tactic(out_gen rawwit_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]) ->
+	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
+	    | 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
+	    | None -> none_in_id_or_int_opt in
+	let idl = out_gen Eauto.rawwit_hintbases idl in
+          (match idl with
+	    None -> CT_eauto_with(first_n,
+				  second_n,
+				  CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
+	  | Some [] -> CT_eauto(first_n, second_n)
+	  | Some (a::l) -> 
+	      CT_eauto_with(first_n, second_n,
+			    CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR
+			      (CT_id_ne_list
+				 (CT_ident a,
+				  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
+	| 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 -> 
+	CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
+    | 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))))
+    | TacReduce (red, l) ->
+     CT_reduce (xlate_red_tactic red, xlate_clause l)
+    | TacApply (c,bindl) ->
+     CT_apply (xlate_formula c, xlate_bindings bindl)
+    | TacConstructor (n_or_meta, bindl) ->
+	let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error ""
+	in CT_constructor (CT_int n, xlate_bindings bindl)
+    | TacSpecialize (nopt, (c,sl)) ->
+     CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl)
+    | TacGeneralize [] -> xlate_error ""
+    | TacGeneralize (first :: cl) ->
+     CT_generalize
+      (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl))
+    | TacGeneralizeDep c ->
+	CT_generalize_dependent (xlate_formula c)
+    | TacElimType c -> CT_elim_type (xlate_formula c)
+    | TacCaseType c -> CT_case_type (xlate_formula c)
+    | TacElim ((c1,sl), u) ->
+     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)
+    | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h)
+    | TacCut c -> CT_cut (xlate_formula c)
+    | TacLApply c -> CT_use (xlate_formula c)
+    | TacDecompose ([],c) ->
+	xlate_error "Decompose : empty list of identifiers?"
+    | TacDecompose (id::l,c) ->
+	let id' = tac_qualid_to_ct_ID id in
+	let l' = List.map tac_qualid_to_ct_ID l in
+        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 [] ->
+	xlate_error "Clear expects a non empty list of identifiers"
+    | TacClear (id::idl) ->
+       let idl' = List.map xlate_hyp idl in
+       CT_clear (CT_id_ne_list (xlate_hyp id, idl'))
+    | (*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,
+	             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)
+    | TacInversion (InversionUsing (c,idlist), id) ->
+	let id = xlate_quantified_hypothesis id in
+	  CT_use_inversion (id, xlate_formula c,
+	    CT_id_list (List.map xlate_hyp idlist))
+    | TacExtend (_,"omega", []) -> CT_omega
+    | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2)
+    | TacClearBody([]) -> assert false
+    | TacClearBody(a::l) -> 
+	CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l))
+    | TacDAuto (a, b) -> CT_dauto(xlate_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) -> 
+        CT_instantiate(CT_int a, xlate_formula b,
+		       xlate_clause cl)
+    | 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)
+    | TacAnyConstructor(Some tac) -> 
+	CT_any_constructor
+	(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
+    | TacAnyConstructor(None) -> 
+	CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none)
+    | TacExtend(_, "ring", [args]) -> 
+	CT_ring
+	  (CT_formula_list
+	     (List.map xlate_formula
+		(out_gen (wit_list0 rawwit_constr) args)))
+    | TacExtend (_,id, l) ->
+     CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l))
+    | TacAlias _ -> xlate_error "Alias not supported"
+
+and coerce_genarg_to_TARG x =
+ match Genarg.genarg_tag x with
+  (* Basic types *)
+  | BoolArgType -> xlate_error "TODO: generic boolean argument"
+  | IntArgType ->
+      let n = out_gen rawwit_int x in
+	CT_coerce_FORMULA_OR_INT_to_TARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
+	     (CT_coerce_INT_to_ID_OR_INT (CT_int n)))
+  | IntOrVarArgType ->
+      let x = match out_gen rawwit_int_or_var x with
+	| ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n)
+	| ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in
+	CT_coerce_FORMULA_OR_INT_to_TARG
+	  (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x)
+  | StringArgType ->
+     let s = CT_string (out_gen rawwit_string x) in
+       CT_coerce_SCOMMENT_CONTENT_to_TARG
+	 (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
+	    (CT_coerce_STRING_to_ID_OR_STRING s))
+  | PreIdentArgType ->
+      let id = CT_ident (out_gen rawwit_pre_ident 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))
+  | IntroPatternArgType ->
+      xlate_error "TODO"
+  | IdentArgType ->
+      let id = xlate_ident (out_gen rawwit_ident 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))
+  | HypArgType ->
+      xlate_error "TODO (similar to IdentArgType)"
+  | RefArgType ->
+      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref 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))
+  (* Specific types *)
+  | SortArgType ->
+      CT_coerce_SCOMMENT_CONTENT_to_TARG
+      (CT_coerce_FORMULA_to_SCOMMENT_CONTENT
+        (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
+  | ConstrArgType ->
+      CT_coerce_SCOMMENT_CONTENT_to_TARG
+      (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
+  | CastedOpenConstrArgType -> 
+      CT_coerce_SCOMMENT_CONTENT_to_TARG
+      	(CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula
+						 (out_gen
+						    rawwit_casted_open_constr x)))
+  | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
+  | BindingsArgType -> xlate_error "TODO: generic with bindings"
+  | RedExprArgType -> xlate_error "TODO: generic red expr"
+  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
+  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
+  | OptArgType x -> xlate_error "TODO: optional generic arguments"
+  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
+  | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments"
+and xlate_context_rule =
+  function
+    | Pat (hyps, concl_pat, tactic) ->
+	CT_context_rule
+	  (CT_context_hyp_list (List.map xlate_match_context_hyps hyps),
+	   xlate_context_pattern concl_pat, xlate_tactic tactic)
+    | All tactic ->
+        CT_def_context_rule (xlate_tactic tactic)
+and formula_to_def_body =
+  function
+    | ConstrEval (red, f) ->
+        CT_coerce_EVAL_CMD_to_DEF_BODY(
+	CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
+                xlate_red_tactic red, xlate_formula f))
+    | ConstrContext((_, id), f) ->
+       	CT_coerce_CONTEXT_PATTERN_to_DEF_BODY
+	  (CT_context
+	     (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)),
+	      xlate_formula f))
+    | ConstrTypeOf f -> CT_type_of (xlate_formula f)
+    | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c)
+
+and mk_let_value = function 
+    TacArg (ConstrMayEval v) ->
+      CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v)
+  | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);;
+
+let coerce_genarg_to_VARG x =
+ match Genarg.genarg_tag x with
+  (* Basic types *)
+  | BoolArgType -> xlate_error "TODO: generic boolean argument"
+  | IntArgType ->
+      let n = out_gen rawwit_int x in
+      CT_coerce_ID_OR_INT_OPT_to_VARG
+	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
+	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
+  | IntOrVarArgType ->
+      (match out_gen rawwit_int_or_var x with
+	| ArgArg n -> 
+      CT_coerce_ID_OR_INT_OPT_to_VARG
+	(CT_coerce_INT_OPT_to_ID_OR_INT_OPT
+	   (CT_coerce_INT_to_INT_OPT (CT_int n)))
+	| ArgVar (_,id) ->
+	    CT_coerce_ID_OPT_OR_ALL_to_VARG
+	      (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL
+	        (CT_coerce_ID_to_ID_OPT (xlate_ident id))))
+  | StringArgType ->
+     let s = CT_string (out_gen rawwit_string x) in
+     CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s)
+  | PreIdentArgType ->
+      let id = CT_ident (out_gen rawwit_pre_ident 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))
+  | IntroPatternArgType ->
+      xlate_error "TODO"
+  | IdentArgType ->
+      let id = xlate_ident (out_gen rawwit_ident 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))
+  | HypArgType ->
+      xlate_error "TODO (similar to IdentArgType)"
+  | RefArgType ->
+      let id = tac_qualid_to_ct_ID (out_gen rawwit_ref 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))
+  (* Specific types *)
+  | SortArgType ->
+     CT_coerce_FORMULA_OPT_to_VARG 
+      (CT_coerce_FORMULA_to_FORMULA_OPT
+	(CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))))
+  | ConstrArgType ->
+     CT_coerce_FORMULA_OPT_to_VARG 
+      (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
+      CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t)
+  | CastedOpenConstrArgType -> 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"
+  | List0ArgType l -> xlate_error "TODO: lists of generic arguments"
+  | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments"
+  | OptArgType x -> xlate_error "TODO: optional generic arguments"
+  | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments"
+  | 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_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_var x = CT_var (match x with
+ | (Global,Definitional) -> "Parameter"
+ | (Global,Logical) -> "Axiom"
+ | (Local,Definitional) -> "Variable"
+ | (Local,Logical) -> "Hypothesis"
+ | (Global,Conjectural) -> "Conjecture"
+ | (Local,Conjectural) -> xlate_error "No local conjecture");;
+
+
+let xlate_dep =
+ function
+    | true -> CT_dep "Induction for"
+    | false -> CT_dep "Minimality for";;
+
+let xlate_locn =
+ function
+    | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n)
+    | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top")
+    | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev")
+    | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next")
+
+let xlate_search_restr =
+  function
+    | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none
+    | SearchInside (m1::l1) ->
+	CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
+	List.map loc_qualid_to_ct_ID l1))
+    | SearchOutside (m1::l1) ->
+	CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1,
+	List.map loc_qualid_to_ct_ID l1))
+    | SearchInside [] -> xlate_error "bad extra argument for Search"
+
+let xlate_check =
+ function
+    | "CHECK" -> "Check"
+    | "PRINTTYPE" -> "Type"
+    | _ -> xlate_error "xlate_check";;
+
+let build_constructors l =
+ let f (coe,((_,id),c)) =
+   if coe then CT_constr_coercion (xlate_ident id, xlate_formula c)
+   else CT_constr (xlate_ident id, xlate_formula c) in
+ CT_constr_list (List.map f l)
+
+let build_record_field_list l =
+ let build_record_field (coe,d) = match d with
+  | AssumExpr (id,c) ->
+      if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c)
+      else
+	CT_recconstr(xlate_id_opt id, xlate_formula c)
+  | DefExpr (id,c,topt) ->
+      if coe then
+ 	CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c,
+			      xlate_formula_opt topt)
+      else
+ 	CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in
+ CT_recconstr_list (List.map build_record_field l);;
+
+let get_require_flags impexp spec =
+ let ct_impexp =
+  match impexp with
+  | None -> CT_coerce_NONE_to_IMPEXP CT_none
+  | Some false -> CT_import
+  | Some true -> CT_export in
+ let ct_spec =
+  match spec with
+  | None -> ctv_SPEC_OPT_NONE
+  | Some true -> CT_spec
+  | Some false -> ctv_SPEC_OPT_NONE in
+ ct_impexp, ct_spec;;
+
+let cvt_optional_eval_for_definition c1 optional_eval =
+  match optional_eval with
+    None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1)
+  | Some red ->
+      CT_coerce_EVAL_CMD_to_DEF_BODY(
+      CT_eval(CT_coerce_NONE_to_INT_OPT CT_none,
+	      xlate_red_tactic red,
+	      xlate_formula c1))
+
+let cvt_vernac_binder = function
+  | b,(id::idl,c) ->
+      let l,t = 
+	CT_id_opt_ne_list 
+          (xlate_ident_opt (Some (snd id)),
+           List.map (fun id -> xlate_ident_opt (Some (snd id))) idl),
+          xlate_formula c in
+	if b then
+	  CT_binder_coercion(l,t)
+	else
+	  CT_binder(l,t)
+  | _, _ -> xlate_error "binder with no left part, rejected";;
+
+let cvt_vernac_binders = function
+    a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args)
+  | [] -> assert false;;
+
+
+let xlate_comment = function
+    CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c)
+  | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT
+      (CT_coerce_STRING_to_ID_OR_STRING(CT_string s))
+  | CommentInt n ->
+      CT_coerce_FORMULA_to_SCOMMENT_CONTENT
+	(CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));;
+
+let translate_opt_notation_decl = function
+    None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none)
+  |  Some(s, f, sc) ->
+       let tr_sc = 
+	 match sc with 
+	     None -> ctv_ID_OPT_NONE
+	   | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in
+       CT_decl_notation(CT_string s, xlate_formula f, tr_sc);;
+
+let xlate_level = function
+    Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n)
+  | Extend.NextLevel -> CT_next_level;;
+
+let xlate_syntax_modifier = function
+    Extend.SetItemLevel((s::sl), level) ->
+      CT_set_item_level
+	(CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl),
+	 xlate_level level)
+  | Extend.SetItemLevel([], _) -> assert false
+  | Extend.SetLevel level -> CT_set_level (CT_int level)
+  | Extend.SetAssoc Gramext.LeftA -> CT_lefta
+  | Extend.SetAssoc Gramext.RightA -> CT_righta
+  | Extend.SetAssoc Gramext.NonA -> CT_nona
+  | Extend.SetEntryType(x,typ) ->
+      CT_entry_type(CT_ident x,
+		 match typ with
+		     Extend.ETIdent -> CT_ident "ident"
+		   | Extend.ETReference -> CT_ident "global"
+		   | Extend.ETBigint -> CT_ident "bigint"
+		   | _ -> xlate_error "syntax_type not parsed")
+  | Extend.SetOnlyParsing -> CT_only_parsing
+  | Extend.SetFormat(_,s) -> CT_format(CT_string s);;
+
+
+let rec xlate_module_type = function
+  | CMTEident(_, qid) -> 
+      CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid))
+  | 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, 
+				       CT_ident (xlate_qualid qid)));;
+
+let xlate_module_binder_list (l:module_binder list) =
+  CT_module_binder_list
+    (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
+		     [] -> assert false
+		   | fst::idl2 -> fst,idl2 in
+		 CT_module_binder
+		   (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);;
+
+let xlate_module_type_check_opt = function
+    None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
+ 	(CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE)
+  | Some(mty, true) -> CT_only_check(xlate_module_type mty)
+  | Some(mty, false) -> 
+      CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK
+	(CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
+	   (xlate_module_type mty));;
+
+let rec xlate_module_expr = function
+    CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR
+	(CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid)))
+  | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1,
+					 xlate_module_expr me2)
+
+let rec xlate_vernac =
+ function
+   | VernacDeclareTacticDefinition (true, tacs) ->
+       (match List.map 
+	 (function
+	      ((_, id), body) ->
+		CT_tac_def(CT_ident (string_of_id id), xlate_tactic body))
+	 tacs with
+	     [] -> assert false
+	   | fst::tacs1 ->
+	       CT_tactic_definition
+		 (CT_tac_def_ne_list(fst, tacs1)))
+   | VernacDeclareTacticDefinition(false, _) -> 
+       xlate_error "obsolete tactic definition not handled"
+    | VernacLoad (verbose,s) ->
+      CT_load (
+       (match verbose with
+        | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none
+        | true -> CT_verbose),
+       CT_coerce_STRING_to_ID_OR_STRING (CT_string s))
+    | VernacCheckMayEval (Some red, numopt, f) ->
+      let red = xlate_red_tactic red in
+      CT_coerce_EVAL_CMD_to_COMMAND
+       (CT_eval (xlate_int_opt numopt, red, xlate_formula f))
+    |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s)
+    | VernacAddLoadPath (false,str,None) ->
+ 	CT_addpath (CT_string str, ctv_ID_OPT_NONE)
+    | VernacAddLoadPath (false,str,Some x) ->
+ 	CT_addpath (CT_string str,
+		    CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
+    | VernacAddLoadPath (true,str,None) ->
+ 	CT_recaddpath (CT_string str, ctv_ID_OPT_NONE)
+    | VernacAddLoadPath (_,str, Some x) ->
+	CT_recaddpath (CT_string str,
+		       CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x)))
+    | VernacRemoveLoadPath str -> CT_delpath (CT_string str)
+    | VernacToplevelControl Quit -> CT_quit
+    | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported"
+      (*ML commands *)
+    | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str)
+    | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str)
+    | VernacDeclareMLModule [] -> failwith ""
+    | VernacDeclareMLModule (str :: l) ->
+      CT_ml_declare_modules
+       (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l))
+    | VernacGoal c ->
+	CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c))
+    | VernacAbort (Some (_,id)) ->
+	CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id))
+    | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE
+    | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL
+    | VernacRestart -> CT_restart
+    | VernacSolve (n, tac, b) -> 
+	CT_solve (CT_int n, xlate_tactic tac,
+		  if b then CT_dotdot
+                  else CT_coerce_NONE_to_DOTDOT_OPT CT_none)
+    | VernacFocus nopt -> CT_focus (xlate_int_opt nopt)
+    | VernacUnfocus -> CT_unfocus
+    |VernacExtend("Extraction", [f;l]) ->
+       let file = out_gen rawwit_string f in
+       let l1 = out_gen (wit_list1 rawwit_ref) l in
+       let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in
+	 CT_extract_to_file(CT_string file, 
+		       CT_id_ne_list(loc_qualid_to_ct_ID fst,
+				     List.map loc_qualid_to_ct_ID l2))
+    | VernacExtend("ExtractionInline", [l]) ->
+	let l1 = out_gen (wit_list1 rawwit_ref) l in
+	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
+	CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst,
+				List.map loc_qualid_to_ct_ID l2))
+    | VernacExtend("ExtractionNoInline", [l]) ->
+	let l1 = out_gen (wit_list1 rawwit_ref) l in
+	let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in
+	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]) ->
+	(match List.map (fun v -> xlate_formula(out_gen rawwit_constr v))
+                   [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;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)
+	   |_ -> 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
+      let ct_orient = match orient with
+	| true  -> CT_lr
+	| false -> CT_rl in
+      let f_ne_list = match List.map xlate_formula formula_list with
+	  (fst::rest) -> CT_formula_ne_list(fst,rest)
+	| _ -> assert false in
+      CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t)
+  | VernacHints (local,dbnames,h) ->
+      let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in
+      (match h with
+	| HintsConstructors (None, l) ->
+	 let n1, names = match List.map tac_qualid_to_ct_ID l with
+	     n1 :: names -> n1, names
+	   | _  -> failwith "" in
+	   if local then
+	     CT_local_hints(CT_ident "Constructors",
+			    CT_id_ne_list(n1, names), dblist)
+	   else
+	     CT_hints(CT_ident "Constructors",
+		      CT_id_ne_list(n1, names), dblist)
+	| HintsExtern (None, 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
+	     a :: tl -> a, tl
+	   | _  -> failwith "" in
+	 let l' = CT_formula_ne_list(f1, formulas) in
+	   if local then
+             (match h with 
+		  HintsResolve _ ->
+		    CT_local_hints_resolve(l', dblist)
+	       	| HintsImmediate _ ->
+		    CT_local_hints_immediate(l', dblist)
+	       	| _ -> assert false)
+	   else
+	     (match h with
+		  HintsResolve _ -> CT_hints_resolve(l', dblist)
+		| 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
+	     n1 :: names -> n1, names
+	   | _  -> failwith "" in
+	   if local then
+             CT_local_hints(CT_ident "Unfold",
+			    CT_id_ne_list(n1, names), dblist)
+	   else	     
+             CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist)
+       	| HintsDestruct(id, n, loc, f, t) ->
+	    let dl = match loc with
+		ConclLocation() -> CT_conclusion_location
+	      | HypLocation true -> CT_discardable_hypothesis
+	      | HypLocation false -> CT_hypothesis_location in
+	     if local then
+               CT_local_hint_destruct
+		 (xlate_ident id, CT_int n,
+		  dl, xlate_formula f, xlate_tactic t, dblist)
+	     else
+	       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)
+  | VernacEndProof (Proved (false,None)) ->
+      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE)
+  | VernacEndProof (Proved (b,Some ((_,s), Some kind))) ->
+      CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind),
+       ctf_ID_OPT_SOME (xlate_ident s))
+  | VernacEndProof (Proved (b,Some ((_,s),None))) ->
+      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"),
+       ctf_ID_OPT_SOME (xlate_ident s))
+  | VernacEndProof Admitted ->
+      CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE)
+  | VernacSetOpacity (false, id :: idl) ->
+            CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id,
+                   List.map loc_qualid_to_ct_ID idl))
+  | VernacSetOpacity (true, id :: idl)
+            -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id,
+                   List.map loc_qualid_to_ct_ID idl))
+  | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur"
+  | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n))
+  | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt)
+  | VernacShow ShowNode -> CT_show_node
+  | VernacShow ShowProof -> CT_show_proof
+  | VernacShow ShowTree -> CT_show_tree
+  | VernacShow ShowProofNames -> CT_show_proofs
+  | VernacShow (ShowIntros true) -> CT_show_intros
+  | VernacShow (ShowIntros false) -> CT_show_intro
+  | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1)
+  | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n)
+  | VernacShow ShowExistentials -> CT_show_existentials
+  | VernacShow ShowScript -> CT_show_script
+  | VernacGo arg -> CT_go (xlate_locn arg)
+  | 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 ->
+      (match p with
+	  PrintFullContext -> CT_print_all
+	| PrintName id -> CT_print_id (loc_qualid_to_ct_ID id)
+	| PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id)
+	| PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id)
+	| PrintModules -> CT_print_modules
+	| PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none
+	| 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))
+	| 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
+	| PrintLoadPath -> CT_print_loadpath
+	| PrintMLLoadPath -> CT_ml_print_path
+	| PrintMLModules -> CT_ml_print_modules
+	| PrintGraph -> CT_print_graph
+	| PrintClasses -> CT_print_classes
+	| PrintCoercions -> CT_print_coercions
+	| PrintCoercionPaths (id1, id2) -> 
+	    CT_print_path (xlate_class id1, xlate_class id2)
+	| PrintInspect n -> CT_inspect (CT_int n)
+	| PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s)
+	| PrintLocalContext -> CT_print
+	| 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)
+        | PrintScopes -> CT_print_scopes
+        | PrintScope id -> CT_print_scope (CT_ident id)
+	| PrintVisibility id_opt ->
+	    CT_print_visibility 
+	      (match id_opt with
+		   Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id)
+		 | None -> ctv_ID_OPT_NONE)
+        | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid)
+	| PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid))
+  | VernacBeginSection (_,id) ->
+      CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id))
+  | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id)
+  | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) ->
+      CT_coerce_THEOREM_GOAL_to_COMMAND(
+	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))
+  | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
+      CT_coerce_THEOREM_GOAL_to_COMMAND
+	(CT_theorem_goal
+	   (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k),
+	    xlate_ident s, xlate_binder_list bl, xlate_formula typ))
+  | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) ->
+      CT_definition
+	(xlate_defn kind, xlate_ident s, xlate_binder_list bl,
+	   cvt_optional_eval_for_definition c red_option,
+           xlate_formula_opt typ_opt)
+  | VernacAssumption (kind, b) ->
+      CT_variable (xlate_var kind, cvt_vernac_binders b)
+  | VernacCheckMayEval (None, numopt, c) ->
+      CT_check (xlate_formula c)
+  | VernacSearch (s,x) ->
+      let translated_restriction = xlate_search_restr x in
+      (match s with
+	| SearchPattern c ->
+	    CT_search_pattern(xlate_formula c, translated_restriction)
+	| SearchHead id ->
+	    CT_search(loc_qualid_to_ct_ID id, translated_restriction)
+	| SearchRewrite c ->
+	    CT_search_rewrite(xlate_formula c, translated_restriction)
+	| SearchAbout (a::l) ->
+	    let xlate_search_about_item it =
+	      match it with
+		  SearchRef x -> 
+		    CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
+		| SearchString s -> 
+		    CT_coerce_STRING_to_ID_OR_STRING(CT_string s) in
+	    CT_search_about
+	      (CT_id_or_string_ne_list(xlate_search_about_item a,
+				       List.map xlate_search_about_item l),
+	       translated_restriction)
+  	| SearchAbout [] -> assert false)
+
+  | (*Record from tactics/Record.v *)
+    VernacRecord 
+      (_, (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
+      CT_record
+       ((if add_coercion then CT_coercion_atm else
+          CT_coerce_NONE_to_COERCION_OPT(CT_none)),
+        xlate_ident s, xlate_binder_list binders, 
+	xlate_formula c1, record_constructor,
+         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) =
+          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) =
+        let (struct_arg,bl,arf,ardef) =
+         if bl = [] then
+           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
+        let ardef = xlate_formula ardef in
+	match xlate_binder_list bl with
+	  | CT_binder_list (b :: bl) ->
+	      CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), 
+			  struct_arg, arf, ardef)
+          | _ -> 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) =
+	CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
+                      xlate_formula arf, xlate_formula ardef) in
+        CT_cofix_decl
+	  (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))
+   | VernacScheme [] -> xlate_error "induction scheme"
+   | VernacScheme (lm :: lmi) ->
+      let strip_ind ((_,id), depstr, inde, sort) =
+           CT_scheme_spec
+            (xlate_ident id, xlate_dep depstr, 
+	    CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
+	     xlate_sort sort) in
+        CT_ind_scheme
+	  (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi))
+   | VernacSyntacticDefinition (id, c, false, _) ->
+       CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None)
+   | VernacSyntacticDefinition (id, c, true, _) ->
+       xlate_error "TODO: Local abbreviations"
+  (* Modules and Module Types *)
+  | VernacDeclareModuleType((_, id), bl, mty_o)  -> 
+      CT_module_type_decl(xlate_ident id,
+			  xlate_module_binder_list bl,
+			  match mty_o with
+			      None ->
+				CT_coerce_ID_OPT_to_MODULE_TYPE_OPT
+				  ctv_ID_OPT_NONE
+			    | Some mty1 ->
+				CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT
+				  (xlate_module_type mty1))
+   | 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) -> 
+       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)
+   | VernacRequire (impexp, spec, id::idl) ->
+      let ct_impexp, ct_spec = get_require_flags impexp spec in
+      CT_require (ct_impexp, ct_spec, 
+		  CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING(
+		  CT_id_ne_list(loc_qualid_to_ct_ID id,
+				List.map loc_qualid_to_ct_ID idl)))
+   | VernacRequire (_,_,[]) ->
+       xlate_error "Require should have at least one id argument"
+   | VernacRequireFrom (impexp, spec, filename) ->
+      let ct_impexp, ct_spec = get_require_flags impexp spec in
+      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) -> 
+       CT_arguments_scope(loc_qualid_to_ct_ID qid,
+		       CT_id_opt_list
+		       (List.map
+			  (fun x ->
+				  match x with
+				      None -> ctv_ID_OPT_NONE
+				    | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l))
+   | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2)
+   | VernacBindScope(id, a::l) -> 
+       let xlate_class_rawexpr = function
+	   FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass"
+	 | RefClass qid -> loc_qualid_to_ct_ID qid in
+       CT_bind_scope(CT_ident id,
+		     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) -> 
+       let translated_s = CT_string s in
+       let formula = xlate_formula c in
+       let translated_modif_list = 
+	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
+       let translated_scope = match opt_scope with
+	   None -> ctv_ID_OPT_NONE
+	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
+       if b then
+       CT_local_define_notation
+	 (translated_s, formula, translated_modif_list, translated_scope)
+       else
+	 CT_define_notation(translated_s, formula, 
+			    translated_modif_list, translated_scope)
+   | VernacSyntaxExtension(b,Some(s,modif_list), None) -> 
+       let translated_s = CT_string s in
+       let translated_modif_list = 
+	 CT_modifier_list(List.map xlate_syntax_modifier modif_list) in
+       if b then
+	 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) ->
+       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
+       let translated_scope = match opt_scope with
+	   None -> ctv_ID_OPT_NONE
+	 | Some x -> ctf_ID_OPT_SOME(CT_ident x) in
+	 if b then
+	   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 =
+       match s with
+       (* Cannot decide whether it is a global or a Local but at toplevel *)
+       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
+       | Local -> CT_local in
+      CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1,
+        xlate_class id2, xlate_class id3)
+
+   | VernacIdentityCoercion (s, (_,id1), id2, id3) ->
+      let id_opt = CT_identity in
+      let local_opt =
+       match s with
+       (* Cannot decide whether it is a global or a Local but at toplevel *)
+       | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none
+       | Local -> CT_local in
+      CT_coercion (local_opt, id_opt, xlate_ident id1,
+        xlate_class id2, xlate_class id3)
+  | VernacResetName id -> CT_reset (xlate_ident (snd id))
+  | VernacResetInitial -> CT_restore_state (CT_ident "Initial")
+  | 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) ->
+      CT_implicits
+	(reference_to_ct_ID id,
+	 match opt_positions with
+	     None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none
+	   | Some l -> 
+	       CT_coerce_ID_LIST_to_ID_LIST_OPT
+	       (CT_id_list
+	       (List.map
+		  (function ExplByPos x
+		       -> xlate_error
+			   "explication argument by rank is obsolete"
+		     | ExplByName id -> CT_ident (string_of_id id)) l)))
+  | VernacReserve((_,a)::l, f) ->
+      CT_reserve(CT_id_ne_list(xlate_ident a, 
+			       List.map (fun (_,x) -> xlate_ident x) l),
+		 xlate_formula f)
+  | 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(LocateFile s) -> CT_locate_file(CT_string s)
+  | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s)
+  | VernacTime(v) -> CT_time(xlate_vernac v)
+  | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[])
+  |VernacExactProof f -> CT_proof(xlate_formula f)
+  | VernacSetOption (table, BoolValue true) -> 
+      let table1 = 
+	match table with
+	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	CT_set_option(table1)
+  | VernacSetOption (table, v) -> 
+      let table1 = 
+	match table with
+	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+      let value =
+	match v with
+	  | BoolValue _ -> assert false
+	  | StringValue s ->
+	      CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s)
+	  | IntValue n ->
+	      CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in
+	CT_set_option_value(table1, value)
+  | VernacUnsetOption(table) ->
+      let table1 = 
+	match table with
+	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	CT_unset_option(table1)
+  | VernacAddOption (table, l) ->
+      let values =
+	List.map
+	  (function
+	     | QualidRefValue x -> 
+		 CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x)
+	     | StringRefValue x -> 
+		 CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in
+      let fst, values1 = 
+	match values with [] -> assert false | a::b -> (a,b) in
+      let table1 = 
+	match table with
+	    PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
+	  | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+	CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1))
+  | VernacImport(true, a::l) ->
+      CT_export_id(CT_id_ne_list(reference_to_ct_ID a,
+				 List.map reference_to_ct_ID l))
+  | VernacImport(false, a::l) ->
+      CT_import_id(CT_id_ne_list(reference_to_ct_ID a,
+				 List.map reference_to_ct_ID l))
+  | VernacImport(_, []) -> assert false
+  | VernacProof t -> CT_proof_with(xlate_tactic t)
+  | VernacVar _ -> xlate_error "Grammar vernac obsolete"
+  | (VernacGlobalCheck _|VernacPrintOption _|
+     VernacMemOption (_, _)|VernacRemoveOption (_, _)
+  | VernacBack _|VernacRestoreState _| VernacWriteState _|
+    VernacSolveExistential (_, _)|VernacCanonical _ | VernacDistfix _|
+     VernacTacticGrammar _)
+    -> xlate_error "TODO: vernac";;
+
+let rec xlate_vernac_list =
+ function
+   | 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/interface/xlate.mli b/contrib/interface/xlate.mli
new file mode 100644
index 00000000..bedb4ac8
--- /dev/null
+++ b/contrib/interface/xlate.mli
@@ -0,0 +1,9 @@
+open Ascent;;
+
+val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;;
+val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;;
+val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;;
+val xlate_ident : Names.identifier -> ct_ID;;
+val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;;
+
+val declare_in_coq : (unit -> unit);;
diff --git a/contrib/jprover/README b/contrib/jprover/README
new file mode 100644
index 00000000..ec654a03
--- /dev/null
+++ b/contrib/jprover/README
@@ -0,0 +1,76 @@
+An intuitionistic first-order theorem prover -- JProver.
+
+Usage:
+
+Require JProver.
+Jp [num].
+
+Whem [num] is provided, proof is done automatically with
+the multiplicity limit [num], otherwise no limit is forced
+and JProver may not terminate.
+
+Example:
+
+Require JProver.
+Coq < Goal (P:Prop) P->P.
+1 subgoal
+
+============================
+ (P:Prop)P->P
+
+Unnamed_thm < Jp 1.
+Proof is built.
+Subtree proved!
+-----------------------------------------
+
+Description:
+JProver is a theorem prover for first-order intuitionistic logic.
+It is originally implemented by Stephan Schmitt and then integrated into
+MetaPRL by Aleksey Nogin (see jall.ml). After this, Huang extracted the
+necessary ML-codes from MetaPRL and then integrated it into Coq.
+The MetaPRL URL is http://metaprl.org/. For more information on 
+integrating JProver into interactive proof assistants, please refer to
+
+   "Stephan Schmitt, Lori Lorigo, Christoph Kreitz, and Aleksey Nogin, 
+   Jprover: Integrating connection-based theorem proving into interactive 
+   proof assistants. In International Joint Conference on Automated 
+   Reasoning, volume 2083 of Lecture Notes in Artificial Intelligence, 
+   pages 421-426. Springer-Verlag, 2001" - 
+   http://www.cs.cornell.edu/nogin/papers/jprover.html
+ 
+
+Structure of this directory:
+This directory contains
+
+        README          ------  this file
+        jall.ml         ------  the main module of JProver
+        jtunify.ml      ------  string unification procedures for jall.ml
+        jlogic.ml       ------  interface module of jall.ml
+        jterm.ml
+        opname.ml       ------  implement the infrastructure for jall.ml
+        jprover.ml4     ------  the interface of jall.ml to Coq
+        JProver.v       ------  declaration for Coq
+        Makefile        ------  the makefile
+        go              ------  batch file to load JProver to Coq dynamically
+
+
+Comments:
+1. The original <jall.ml> is located in meta-prl/refiner/reflib of the
+MetaPRL directory. Some parts of this file are modified by Huang.
+
+2. <jtunify.ml> is also located in meta-prl/refiner/reflib with no modification.
+
+3. <jlogic.ml> is modified from meta-prl/refiner/reflib/jlogic_sig.mlz.
+
+4. <jterm.ml> and <opname.ml> are modified from the standard term module
+of MetaPRL in meta-prl/refiner/term_std.
+
+5. The Jp tactic currently cannot prove formula such as
+   ((x:nat) (P x)) -> (EX y:nat| (P y)), which requires extra constants
+in the domain when the left-All rule is applied.
+
+
+
+by Huang Guan-Shieng (Guan-Shieng.Huang@lri.fr), March 2002.
+
+
diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml
new file mode 100644
index 00000000..876dc6c0
--- /dev/null
+++ b/contrib/jprover/jall.ml
@@ -0,0 +1,4701 @@
+(*
+ * JProver first-order automated prover. See the interface file
+ * for more information and a list of references for JProver.
+ *
+ * ----------------------------------------------------------------
+ *
+ * This file is part of MetaPRL, a modular, higher order
+ * logical framework that provides a logical programming
+ * environment for OCaml and other languages.
+ *
+ * See the file doc/index.html for information on Nuprl,
+ * OCaml, and more information about this system.
+ *
+ * Copyright (C) 2000 Stephan Schmitt
+ *
+ * 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 (at your option) 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * Author: Stephan Schmitt <schmitts@spmail.slu.edu>
+ * Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
+ *)
+
+(*: All of Huang's modifications of this file are quoted or denoted
+    by comments followed by a colon.
+:*)
+
+(*:
+open Mp_debug
+
+open Refiner.Refiner
+open Term
+open TermType
+open TermOp
+open TermSubst
+open TermMan
+open RefineError
+open Opname
+:*)
+
+open Jterm
+open Opname
+open Jlogic
+open Jtunify
+
+let ruletable = Jlogic.ruletable
+
+(*:
+let free_var_op = make_opname ["free_variable";"Jprover"]
+let jprover_op = make_opname ["string";"Jprover"]
+:*)
+let free_var_op = make_opname ["free_variable"; "Jprover"]
+let jprover_op = make_opname ["jprover"; "string"]
+
+module JProver (JLogic : JLogicSig) =
+struct
+   type polarity = I | O
+
+   type connective = And | Or | Neg | Imp | All | Ex | At | Null
+
+   type ptype = Alpha | Beta | Gamma | Delta | Phi | Psi | PNull
+
+   type stype =
+      Alpha_1 | Alpha_2 | Beta_1 | Beta_2 | Gamma_0 | Delta_0
+    | Phi_0 | Psi_0 | PNull_0
+
+   type pos  = {name : string;
+                address : int list;
+                op :  connective;
+                pol : polarity;
+                pt : ptype;
+                st : stype;
+                label : term}
+
+   type 'pos ftree =
+      Empty
+    | NodeAt of 'pos
+    | NodeA of 'pos * ('pos ftree) array
+
+   type atom  = {aname : string;
+                 aaddress : int list;
+                 aprefix : string list;
+                 apredicate :  operator;
+                 apol : polarity;
+                 ast : stype;
+                 alabel : term}
+
+   type atom_relations = atom * atom list * atom list
+(* all atoms except atom occur in [alpha_set] and [beta_set] of atom*)
+
+(* beta proofs *)
+
+   type bproof = BEmpty
+    | RNode of string list * bproof
+    | CNode of (string * string)
+    | BNode of string * (string list * bproof) * (string list * bproof)
+    | AtNode of string * (string * string)
+
+(* Assume only constants for instantiations, not adapted to terms yet *)
+   type inf = rule * term  * term
+
+(* proof tree for pretty print and permutation *)
+   type 'inf ptree =
+      PEmpty
+    | PNodeAx of 'inf
+    | PNodeA of 'inf * 'inf ptree
+    | PNodeB of 'inf * 'inf ptree * 'inf ptree
+
+   module OrderedAtom =
+   struct
+      type t = atom
+      let compare a1 a2 = if (a1.aname) = (a2.aname) then 0 else
+      if (a1.aname) < (a2.aname) then -1 else 1
+   end
+
+   module AtomSet = Set.Make(OrderedAtom)
+
+   module OrderedString =
+   struct
+      type t = string
+      let compare a1 a2 = if a1 = a2 then 0 else
+      if a1 < a2 then -1 else 1
+   end
+
+   module StringSet = Set.Make(OrderedString)
+
+(*i   let _ =
+      show_loading "Loading Jall%t" i*)
+
+   let debug_jprover =
+      create_debug (**)
+         { debug_name = "jprover";
+           debug_description = "Display Jprover operations";
+           debug_value = false
+         }
+
+   let jprover_bug = Invalid_argument "Jprover bug (Jall module)"
+
+(*****************************************************************)
+
+(************* printing function *************************************)
+
+(************ printing T-string unifiers ****************************)
+
+(* ******* printing ********** *)
+
+   let rec list_to_string s =
+      match s with
+         [] -> ""
+       | f::r ->
+            f^"."^(list_to_string r)
+
+   let rec print_eqlist eqlist =
+      match eqlist with
+         [] ->
+            print_endline ""
+       | (atnames,f)::r ->
+            let (s,t) = f in
+            let ls = list_to_string s
+            and lt = list_to_string t in
+            begin
+               print_endline ("Atom names: "^(list_to_string atnames));
+               print_endline (ls^" = "^lt);
+               print_eqlist r
+            end
+
+   let print_equations eqlist =
+      begin
+         Format.open_box 0;
+         Format.force_newline ();
+         print_endline "Equations:";
+         print_eqlist eqlist;
+         Format.force_newline ();
+      end
+
+   let rec print_subst sigma =
+      match sigma with
+         [] ->
+            print_endline ""
+       | f::r ->
+            let (v,s) = f in
+            let ls = list_to_string s in
+            begin
+               print_endline (v^" = "^ls);
+               print_subst r
+            end
+
+   let print_tunify sigma =
+      let (n,subst) = sigma in
+      begin
+         print_endline " ";
+         print_endline ("MaxVar = "^(string_of_int (n-1)));
+         print_endline " ";
+         print_endline "Substitution:";
+         print_subst subst;
+         print_endline " "
+      end
+
+(*****************************************************)
+
+(********* printing atoms and their relations ***********************)
+
+   let print_stype st =
+      match st with
+         Alpha_1 -> Format.print_string "Alpha_1"
+       | Alpha_2 -> Format.print_string "Alpha_2"
+       | Beta_1  -> Format.print_string "Beta_1"
+       | Beta_2  -> Format.print_string "Beta_2"
+       | Gamma_0 -> Format.print_string "Gamma_0"
+       | Delta_0 -> Format.print_string "Delta_0"
+       | Phi_0   -> Format.print_string "Phi_0"
+       | Psi_0   -> Format.print_string "Psi_0"
+       | PNull_0 -> Format.print_string "PNull_0"
+
+   let print_pol pol =
+      if pol = O then
+         Format.print_string "O"
+      else
+         Format.print_string "I"
+
+   let rec print_address int_list =
+      match int_list with
+         [] ->
+            Format.print_string ""
+       | hd::rest ->
+            begin
+               Format.print_int hd;
+               print_address rest
+            end
+
+   let rec print_prefix prefix_list =
+      match prefix_list with
+         [] -> Format.print_string ""
+       | f::r ->
+            begin
+               Format.print_string f;
+               print_prefix r
+            end
+
+   let print_atom at tab =
+      let ({aname=x; aaddress=y; aprefix=z; apredicate=p; apol=a; ast=b; alabel=label}) = at in
+      begin
+         Format.print_string ("{aname="^x^"; address=");
+         print_address y;
+         Format.print_string "; ";
+         Format.force_newline ();
+         Format.print_break (tab+1) (tab+1);
+         Format.print_string "prefix=";
+         print_prefix z;
+         Format.print_string "; predicate=<abstr>; ";
+         Format.print_break (tab+1) (tab+1);
+         Format.print_break (tab+1) (tab+1);
+         Format.print_string "pol=";
+         print_pol a;
+         Format.print_string "; stype=";
+         print_stype b;
+         Format.print_string "; arguments=[<abstr>]";
+         Format.print_string "\n    alabel=";
+         print_term stdout label;
+         Format.print_string "}"
+      end
+
+   let rec print_atom_list set tab =
+      match set with
+         []  -> Format.print_string ""
+       | (f::r) ->
+            begin
+               Format.force_newline ();
+               Format.print_break (tab) (tab);
+               print_atom f tab;
+               print_atom_list r (tab)
+            end
+
+   let rec print_atom_info atom_relation =
+      match atom_relation with
+         [] -> Format.print_string ""
+       | (a,b,c)::r ->
+            begin
+               Format.print_string "atom:";
+               Format.force_newline ();
+               Format.print_break 3 3;
+               print_atom a 3;
+               Format.force_newline ();
+               Format.print_break 0 0;
+               Format.print_string "alpha_set:";
+               print_atom_list b 3;
+               Format.force_newline ();
+               Format.print_break 0 0;
+               Format.print_string "beta_set:";
+               print_atom_list c 3;
+               Format.force_newline ();
+               Format.force_newline ();
+               Format.print_break 0 0;
+               print_atom_info r
+            end
+
+(*************** print formula tree, tree ordering etc. ***********)
+
+   let print_ptype pt =
+      match pt with
+         Alpha -> Format.print_string "Alpha"
+       | Beta  -> Format.print_string "Beta"
+       | Gamma -> Format.print_string "Gamma"
+       | Delta -> Format.print_string "Delta"
+       | Phi   -> Format.print_string "Phi"
+       | Psi   -> Format.print_string "Psi"
+       | PNull -> Format.print_string "PNull"
+
+   let print_op op =
+      match op with
+         At   -> Format.print_string "Atom"
+       | Neg  -> Format.print_string "Neg"
+       | And  -> Format.print_string "And"
+       | Or   -> Format.print_string  "Or"
+       | Imp  -> Format.print_string  "Imp"
+       | Ex   -> Format.print_string "Ex"
+       | All  -> Format.print_string "All"
+       | Null -> Format.print_string "Null"
+
+   let print_position position tab =
+      let ({name=x; address=y; op=z; pol=a; pt=b; st=c; label=t}) = position in
+      begin
+         Format.print_string ("{name="^x^"; address=");
+         print_address y;
+         Format.print_string "; ";
+         Format.force_newline ();
+         Format.print_break (tab+1) 0;
+(*   Format.print_break 0 3; *)
+         Format.print_string "op=";
+         print_op z;
+         Format.print_string "; pol=";
+         print_pol a;
+         Format.print_string "; ptype=";
+         print_ptype b;
+         Format.print_string "; stype=";
+         print_stype c;
+         Format.print_string ";";
+         Format.force_newline ();
+         Format.print_break (tab+1) 0;
+         Format.print_string "label=";
+         Format.print_break 0 0;
+         Format.force_newline ();
+         Format.print_break tab 0;
+         print_term stdout t;
+         Format.print_string "}"
+      end
+
+   let rec pp_ftree_list tree_list tab =
+      let rec pp_ftree ftree new_tab =
+         let dummy = String.make (new_tab-2) ' ' in
+         match ftree with
+            Empty -> Format.print_string ""
+          | NodeAt(position) ->
+               begin
+                  Format.force_newline ();
+                  Format.print_break new_tab 0;
+                  print_string (dummy^"AtomNode: ");
+(*     Format.force_newline ();
+   Format.print_break 0 3;
+*)
+                  print_position position new_tab;
+                  Format.force_newline ();
+                  Format.print_break new_tab 0
+               end
+          | NodeA(position,subtrees) ->
+               let tree_list = Array.to_list subtrees in
+               begin
+                  Format.force_newline ();
+                  Format.print_break new_tab 0;
+                  Format.print_break 0 0;
+                  print_string (dummy^"InnerNode: ");
+                  print_position position new_tab;
+                  Format.force_newline ();
+                  Format.print_break 0 0;
+                  pp_ftree_list tree_list (new_tab-3)
+               end
+      in
+      let new_tab = tab+5 in
+      match tree_list with
+         [] -> Format.print_string ""
+       | first::rest ->
+            begin
+               pp_ftree first new_tab;
+               pp_ftree_list rest tab
+            end
+
+   let print_ftree ftree =
+      begin
+         Format.open_box 0;
+         Format.print_break 3 0;
+         pp_ftree_list [ftree] 0;
+         Format.print_flush ()
+      end
+
+   let rec stringlist_to_string stringlist =
+      match stringlist with
+         [] -> "."
+       | f::r ->
+            let  rest_s = stringlist_to_string r in
+            (f^"."^rest_s)
+
+   let rec print_stringlist slist =
+      match slist with
+         [] ->
+            Format.print_string ""
+       | f::r ->
+            begin
+               Format.print_string (f^".");
+               print_stringlist r
+            end
+
+   let rec pp_bproof_list tree_list tab =
+      let rec pp_bproof ftree new_tab =
+         let dummy = String.make (new_tab-2) ' ' in
+         match ftree with
+            BEmpty -> Format.print_string ""
+          | CNode((c1,c2)) ->
+               begin
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_break (new_tab-10) 0;
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_string (dummy^"CloseNode: connection = ("^c1^","^c2^")");
+                  Format.print_flush();
+(*      Format.force_newline ();
+   Format.print_break 0 3;
+*)
+                  Format.open_box 0;
+                  Format.print_break new_tab 0;
+                  Format.print_flush()
+               end
+          | AtNode(posname,(c1,c2)) ->
+               begin
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_break (new_tab-10) 0;
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_string (dummy^"AtNode: pos = "^posname^" conneciton = ("^c1^","^c2^")");
+                  Format.print_flush();
+(*      Format.force_newline ();
+   Format.print_break 0 3;
+*)
+                  Format.open_box 0;
+                  Format.print_break new_tab 0;
+                  Format.print_flush()
+               end
+          | RNode(alpha_layer,bproof) ->
+               let alpha_string = stringlist_to_string alpha_layer in
+               begin
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_break new_tab 0;
+                  Format.print_break 0 0;
+                  Format.force_newline ();
+                  Format.print_flush();
+                  Format.open_box 0;
+                  print_string (dummy^"RootNode: "^alpha_string);
+                  Format.print_flush();
+                  Format.open_box 0;
+                  Format.print_break 0 0;
+                  Format.print_flush();
+                  pp_bproof_list [bproof] (new_tab-3)
+               end
+          | BNode(posname,(alph1,bproof1),(alph2,bproof2)) ->
+               let alpha_string1 = stringlist_to_string alph1
+               and alpha_string2 = stringlist_to_string alph2 in
+               begin
+                  Format.open_box 0;
+                  Format.force_newline ();
+                  Format.print_break new_tab 0;
+                  Format.print_break 0 0;
+                  Format.force_newline ();
+                  Format.print_flush();
+                  Format.open_box 0;
+                  print_string (dummy^"BetaNode: pos = "^posname^" layer1 = "^alpha_string1^" layer2 = "^alpha_string2);
+                  Format.print_flush();
+                  Format.open_box 0;
+                  Format.print_break 0 0;
+                  Format.print_flush();
+                  pp_bproof_list [bproof1;bproof2] (new_tab-3)
+               end
+      in
+      let new_tab = tab+5 in
+      match tree_list with
+         [] -> Format.print_string ""
+       | first::rest ->
+            begin
+               pp_bproof first new_tab;
+               pp_bproof_list rest tab
+            end
+
+   let rec print_pairlist pairlist =
+      match pairlist with
+         [] -> Format.print_string ""
+       | (a,b)::rest ->
+            begin
+               Format.print_break 1 1;
+               Format.print_string ("("^a^","^b^")");
+               print_pairlist rest
+            end
+
+   let print_beta_proof bproof =
+      begin
+         Format.open_box 0;
+         Format.force_newline ();
+         Format.force_newline ();
+         Format.print_break 3 0;
+         pp_bproof_list [bproof] 0;
+         Format.force_newline ();
+         Format.force_newline ();
+         Format.force_newline ();
+         Format.print_flush ()
+      end
+
+   let rec print_treelist treelist =
+      match treelist with
+         [] ->
+            print_endline "END";
+       | f::r ->
+            begin
+               print_ftree f;
+               Format.open_box 0;
+               print_endline "";
+               print_endline "";
+               print_endline "NEXT TREE";
+               print_endline "";
+               print_endline "";
+               print_treelist r;
+               Format.print_flush ()
+            end
+
+   let rec print_set_list set_list =
+      match set_list with
+         [] -> ""
+       | f::r ->
+            (f.aname)^" "^(print_set_list r)
+
+   let print_set  set =
+      let set_list = AtomSet.elements set in
+      if set_list = [] then "empty"
+      else
+         print_set_list set_list
+
+   let print_string_set  set =
+      let set_list = StringSet.elements set in
+      print_stringlist set_list
+
+   let rec print_list_sets list_of_sets =
+      match list_of_sets with
+         [] -> Format.print_string ""
+       | (pos,fset)::r ->
+            begin
+               Format.print_string (pos^": ");   (* first element = node which successors depend on *)
+               print_stringlist (StringSet.elements fset);
+               Format.force_newline ();
+               print_list_sets r
+            end
+
+   let print_ordering list_of_sets =
+      begin
+         Format.open_box 0;
+         print_list_sets list_of_sets;
+         Format.print_flush ()
+      end
+
+   let rec print_triplelist triplelist =
+      match triplelist with
+         [] -> Format.print_string ""
+       | ((a,b),i)::rest ->
+            begin
+               Format.print_break 1 1;
+               Format.print_string ("(("^a^","^b^"),"^(string_of_int i)^")");
+               print_triplelist rest
+            end
+
+   let print_pos_n  pos_n =
+      Format.print_int pos_n
+
+   let print_formula_info ftree ordering pos_n =
+      begin
+         print_ftree ftree;
+         Format.open_box 0;
+         Format.force_newline ();
+         print_ordering ordering;
+         Format.force_newline ();
+         Format.force_newline ();
+         Format.print_string "number of positions: ";
+         print_pos_n pos_n;
+         Format.force_newline ();
+         print_endline "";
+         print_endline "";
+         Format.print_flush ()
+      end
+
+(* print sequent proof tree *)
+
+   let pp_rule (pos,r,formula,term) tab =
+      let rep = ruletable r in
+      if List.mem rep ["Alll";"Allr";"Exl";"Exr"] then
+         begin
+            Format.open_box 0;
+(*          Format.force_newline (); *)
+            Format.print_break tab 0;
+            Format.print_string (pos^": "^rep^" ");
+            Format.print_flush ();
+(*          Format.print_break tab 0;
+   Format.force_newline ();
+   Format.print_break tab 0;
+*)
+
+            Format.open_box 0;
+            print_term stdout formula;
+            Format.print_flush ();
+            Format.open_box 0;
+            Format.print_string "  ";
+            Format.print_flush ();
+            Format.open_box 0;
+            print_term stdout term;
+            Format.force_newline ();
+            Format.force_newline ();
+            Format.print_flush ()
+         end
+      else
+         begin
+            Format.open_box 0;
+            Format.print_break tab 0;
+            Format.print_string (pos^": "^rep^" ");
+            Format.print_flush ();
+            Format.open_box 0;
+(*          Format.print_break tab 0; *)
+            Format.force_newline ();
+(*          Format.print_break tab 0; *)
+            print_term stdout formula;
+            Format.force_newline ()
+         end
+
+   let last addr =
+      if addr = ""
+      then ""
+      else
+         String.make 1 (String.get addr (String.length addr-1))
+
+   let rest addr =
+      if addr = ""
+      then ""
+      else
+         String.sub addr 0 ((String.length addr) - 1)
+
+   let rec get_r_chain addr =
+      if addr = "" then
+         0
+      else
+         let l = last addr in
+         if l = "l" then
+            0
+         else (* l = "r" *)
+            let rs = rest addr in
+            1 + (get_r_chain rs)
+
+   let rec tpp seqtree tab addr =
+      match seqtree with
+       | PEmpty -> raise jprover_bug
+       | PNodeAx(rule) ->
+            let (pos,r,p,pa) = rule in
+            begin
+               pp_rule (pos,r,p,pa) tab;
+(*      Format.force_newline (); *)
+(*      let mult = get_r_chain addr in  *)
+(*        Format.print_break 100 (tab - (3 * mult)) *)
+            end
+       | PNodeA(rule,left) ->
+            let (pos,r,p,pa) = rule in
+            begin
+               pp_rule (pos,r,p,pa) tab;
+               tpp left tab addr
+            end
+       | PNodeB(rule,left,right) ->
+            let (pos,r,p,pa) = rule in
+            let newtab = tab + 3 in
+            begin
+               pp_rule (pos,r,p,pa) tab;
+(*             Format.force_newline (); *)
+(*             Format.print_break 100 newtab; *)
+               (tpp left newtab (addr^"l"));
+               (tpp right newtab (addr^"r"))
+            end
+
+   let tt seqtree =
+      begin
+         Format.open_box 0;
+         tpp seqtree 0 "";
+         Format.force_newline ();
+         Format.close_box ();
+         Format.print_newline ()
+      end
+
+(************ END printing functions  *********************************)
+
+(************ Beta proofs and redundancy deletion **********************)
+
+   let rec remove_dups_connections connection_list =
+      match connection_list with
+         [] -> []
+       | (c1,c2)::r ->
+            if (List.mem (c1,c2) r) or (List.mem (c2,c1) r) then
+  (* only one direction variant of a connection stays *)
+               remove_dups_connections r
+            else
+               (c1,c2)::(remove_dups_connections r)
+
+   let rec remove_dups_list list =
+      match list with
+         [] -> []
+       | f::r ->
+            if List.mem f  r then
+               remove_dups_list r
+            else
+               f::(remove_dups_list r)
+
+   let beta_pure alpha_layer connections beta_expansions =
+      let (l1,l2) = List.split connections in
+      let test_list = l1 @ l2 @ beta_expansions in
+      begin
+(*       Format.open_box 0;
+         print_endline "";
+         print_stringlist alpha_layer;
+         Format.print_flush();
+         Format.open_box 0;
+         print_endline "";
+         print_stringlist test_list;
+         print_endline "";
+         Format.print_flush();
+*)
+         not (List.exists (fun x -> (List.mem x test_list)) alpha_layer)
+      end
+
+   let rec apply_bproof_purity  bproof =
+      match bproof with
+         BEmpty ->
+            raise jprover_bug
+       | CNode((c1,c2)) ->
+            bproof,[(c1,c2)],[]
+       | AtNode(_,(c1,c2)) ->
+            bproof,[(c1,c2)],[]
+       | RNode(alpha_layer,subproof) ->
+            let (opt_subproof,min_connections,beta_expansions) =
+               apply_bproof_purity  subproof in
+            (RNode(alpha_layer,opt_subproof),min_connections,beta_expansions)
+       | BNode(pos,(alph1,subp1),(alph2,subp2)) ->
+            let (opt_subp1,min_conn1,beta_exp1) = apply_bproof_purity subp1 in
+            if beta_pure alph1 min_conn1 beta_exp1 then
+               begin
+(*       print_endline ("Left layer of "^pos); *)
+                  (opt_subp1,min_conn1,beta_exp1)
+               end
+            else
+               let (opt_subp2,min_conn2,beta_exp2) = apply_bproof_purity subp2 in
+               if beta_pure alph2 min_conn2 beta_exp2 then
+                  begin
+(*       print_endline ("Right layer of "^pos); *)
+                     (opt_subp2,min_conn2,beta_exp2)
+                  end
+               else
+                  let min_conn = remove_dups_connections (min_conn1 @ min_conn2)
+                  and beta_exp = remove_dups_list ([pos] @ beta_exp1 @ beta_exp2) in
+                  (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2)),min_conn,beta_exp)
+
+   let bproof_purity bproof =
+      let (opt_bproof,min_connections,_) = apply_bproof_purity bproof in
+      opt_bproof,min_connections
+
+(*********** split permutation *****************)
+
+   let rec apply_permutation bproof rep_name direction act_blayer =
+      match bproof with
+         BEmpty | RNode(_,_) ->
+            raise jprover_bug
+       | AtNode(cx,(c1,c2)) ->
+            bproof,act_blayer
+       | CNode((c1,c2)) ->
+            bproof,act_blayer
+       | BNode(pos,(alph1,subp1),(alph2,subp2)) ->
+            if rep_name = pos then
+               let (new_blayer,replace_branch) =
+                  if direction = "left" then
+                     (alph1,subp1)
+                  else (* direciton = "right" *)
+                     (alph2,subp2)
+               in
+               (match replace_branch with
+                  CNode((c1,c2)) ->
+                     (AtNode(c1,(c1,c2))),new_blayer (* perform atom expansion at c1 *)
+                | _ ->
+                     replace_branch,new_blayer
+               )
+            else
+               let pproof1,new_blayer1 = apply_permutation subp1 rep_name direction act_blayer in
+               let pproof2,new_blayer2 = apply_permutation subp2 rep_name direction new_blayer1 in
+               (BNode(pos,(alph1,pproof1),(alph2,pproof2))),new_blayer2
+
+   let split_permutation pname opt_bproof =
+      match opt_bproof with
+         RNode(alayer,BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) ->
+            if pos = pname then
+(* if topmost beta expansion agrees with pname, then *)
+(* only split the beta proof and give back the two subproofs *)
+               let (osubp1,min_con1) = bproof_purity opt_subp1
+               and (osubp2,min_con2) = bproof_purity opt_subp2 in
+(* there will be no purity reductions in the beta subproofs. We use this *)
+(* predicate to collect the set of used leaf-connections in each subproof*)
+               ((RNode((alayer @ alph1),osubp1),min_con1),
+                (RNode((alayer @ alph2),osubp2),min_con2)
+               )
+(* we combine the branch after topmost beta expansion at pos into one root alpha layer *)
+(* -- the beta expansion node pos will not be needed in this root layer *)
+            else
+               let perm_bproof1,balph1 = apply_permutation
+                     (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "left" []
+               and perm_bproof2,balph2 = apply_permutation
+                     (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "right" [] in
+
+               begin
+(*                print_endline " ";
+                  print_beta_proof perm_bproof1;
+                  print_endline" " ;
+                  print_beta_proof perm_bproof2;
+                  print_endline" ";
+*)
+                  let (osubp1,min_con1) = bproof_purity perm_bproof1
+                  and (osubp2,min_con2) = bproof_purity perm_bproof2 in
+                  ((RNode((alayer @ balph1),osubp1),min_con1),
+                   (RNode((alayer @ balph2),osubp2),min_con2)
+                  )
+               end
+(* we combine the branch after the NEW topmost beta expansion at bpos *)
+(* into one root alpha layer -- the beta expansion node bpos will not be *)
+(* needed in this root layer *)
+       | _ ->
+            raise jprover_bug
+
+(*********** END split permutation *****************)
+
+   let rec list_del list_el el_list  =
+      match el_list with
+         [] ->
+            raise jprover_bug
+       | f::r ->
+            if list_el = f then
+               r
+            else
+               f::(list_del list_el r)
+
+   let rec list_diff del_list check_list =
+      match del_list with
+         [] ->
+            []
+       | f::r ->
+            if List.mem f check_list then
+               list_diff r check_list
+            else
+               f::(list_diff r check_list)
+
+(* let rec compute_alpha_layer ftree_list =
+      match ftree_list with
+         [] ->
+            [],[],[]
+       | f::r ->
+            (match f with
+               Empty ->
+                  raise jprover_bug
+             | NodeAt(pos) ->
+                  let pn = pos.name
+                  and (rnode,ratom,borderings) = compute_alpha_layer r in
+                  ((pn::rnode),(pn::ratom),borderings)
+             | NodeA(pos,suctrees) ->
+                  let pn = pos.name in
+                  if pos.pt = Beta then
+                     let (rnode,ratom,borderings) = compute_alpha_layer r in
+                     ((pn::rnode),(ratom),(f::borderings))
+                  else
+                     let suclist = Array.to_list suctrees in
+                     compute_alpha_layer (suclist @ r)
+            )
+
+   let rec compute_connection alpha_layer union_atoms connections =
+      match connections with
+         [] -> ("none","none")
+       | (c,d)::r ->
+            if (List.mem c union_atoms) & (List.mem d union_atoms) then
+               let (c1,c2) =
+                  if List.mem c alpha_layer then
+                     (c,d)
+                  else
+                     if List.mem d alpha_layer then
+                        (d,c) (* then, d is supposed to occur in [alpha_layer] *)
+                     else
+                        raise (Invalid_argument "Jprover bug: connection match failure")
+               in
+               (c1,c2)
+            else
+               compute_connection alpha_layer union_atoms r
+
+   let get_beta_suctrees btree =
+      match btree with
+         Empty | NodeAt(_) -> raise jprover_bug
+       | NodeA(pos,suctrees) ->
+            let b1tree = suctrees.(0)
+            and b2tree = suctrees.(1) in
+            (pos.name,b1tree,b2tree)
+
+   let rec build_beta_proof alpha_layer union_atoms beta_orderings connections =
+      let (c1,c2) = compute_connection alpha_layer union_atoms connections in
+(* [c1] is supposed to occur in the lowmost alpha layer of the branch, *)
+(* i.e. [aplha_layer] *)
+      if (c1,c2) = ("none","none") then
+         (match beta_orderings with
+            [] -> raise jprover_bug
+          | btree::r ->
+               let (beta_pos,suctree1,suctree2) = get_beta_suctrees btree in
+               let (alpha_layer1, atoms1, bordering1) = compute_alpha_layer [suctree1]
+               and (alpha_layer2, atoms2, bordering2) = compute_alpha_layer [suctree2] in
+               let bproof1,beta1,closure1 =
+                  build_beta_proof alpha_layer1 (atoms1 @ union_atoms)
+                     (bordering1 @ r) connections
+               in
+               let bproof2,beta2,closure2 =
+                  build_beta_proof alpha_layer2 (atoms2 @ union_atoms)
+                     (bordering2 @ r) connections in
+               (BNode(beta_pos,(alpha_layer1,bproof1),(alpha_layer2,bproof2))),(1+beta1+beta2),(closure1+closure2)
+         )
+      else
+         CNode((c1,c2)),0,1
+
+   let construct_beta_proof ftree connections =
+      let (root_node,root_atoms,beta_orderings) = compute_alpha_layer [ftree]
+      in
+      let beta_proof,beta_exp,closures =
+         build_beta_proof root_node root_atoms beta_orderings connections in
+      (RNode(root_node,beta_proof)),beta_exp,closures
+*)
+
+
+(* *********** New Version with direct computation from extension proof **** *)
+(* follows a DIRECT step from proof histories via pr-connection orderings to opt. beta-proofs *)
+
+   let rec compute_alpha_layer ftree_list =
+      match ftree_list with
+         [] ->
+            []
+       | f::r ->
+            (match f with
+               Empty ->
+                  raise jprover_bug
+             | NodeAt(pos) ->
+                  let rnode = compute_alpha_layer r in
+                  (pos.name::rnode)
+             | NodeA(pos,suctrees) ->
+                  if pos.pt = Beta then
+                     let rnode = compute_alpha_layer r in
+                     (pos.name::rnode)
+                  else
+                     let suclist = Array.to_list suctrees in
+                     compute_alpha_layer (suclist @ r)
+            )
+
+   let rec compute_beta_difference c1_context c2_context act_context =
+      match c1_context,c2_context with
+         ([],c2_context) ->
+            (list_diff c2_context act_context)
+(* both connection partners in the same submatrix; [c1] already isolated *)
+       | ((fc1::rc1),[]) ->
+            []  (* [c2] is a reduction step, i.e. isolated before [c1] *)
+       | ((fc1::rc1),(fc2::rc2)) ->
+            if fc1 = fc2 then    (* common initial beta-expansions *)
+               compute_beta_difference rc1 rc2 act_context
+            else
+               (list_diff c2_context act_context)
+
+   let rec non_closed beta_proof_list =
+      match beta_proof_list with
+         [] ->
+            false
+       | bpf::rbpf ->
+            (match bpf with
+               RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+             | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+             | BEmpty -> true
+             | CNode(_) -> non_closed rbpf
+             | BNode(pos,(_,bp1),(_,bp2)) -> non_closed ([bp1;bp2] @ rbpf)
+            )
+
+   let rec cut_context pos context =
+      match context with
+         [] ->
+            raise (Invalid_argument "Jprover bug: invalid context element")
+       | (f,num)::r ->
+            if pos = f then
+               context
+            else
+               cut_context pos r
+
+   let compute_tree_difference beta_proof c1_context =
+      match beta_proof with
+         RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+       | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+       | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+       | BEmpty -> c1_context
+       | BNode(pos,_,_) ->
+(*    print_endline ("actual root: "^pos); *)
+            cut_context pos c1_context
+
+   let print_context conn bcontext =
+      begin
+         Format.open_box 0;
+         Format.print_string conn;
+         Format.print_string ":    ";
+         List.iter (fun x -> let (pos,num) = x in Format.print_string (pos^" "^(string_of_int num)^"")) bcontext;
+         print_endline " ";
+         Format.print_flush ()
+      end
+
+   let rec build_opt_beta_proof beta_proof ext_proof beta_atoms beta_layer_list act_context =
+      let rec add_c2_tree (c1,c2) c2_diff_context =
+         match c2_diff_context with
+            [] ->
+               (CNode(c1,c2),0)
+          | (f,num)::c2_diff_r ->
+               let next_beta_proof,next_exp =
+                  add_c2_tree (c1,c2) c2_diff_r in
+               let (layer1,layer2) = List.assoc f beta_layer_list in
+               let new_bproof =
+                  if num = 1 then
+                     BNode(f,(layer1,next_beta_proof),(layer2,BEmpty))
+                  else (* num = 2*)
+                     BNode(f,(layer1,BEmpty),(layer2,next_beta_proof))
+               in
+               (new_bproof,(next_exp+1))
+      in
+      let rec add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context new_act_context =
+         match c1_diff_context with
+            [] ->
+               let (n_c1,n_c2) =
+                  if c2_diff_context = [] then  (* make sure that leaf-connection is first element *)
+                     (c1,c2)
+                  else
+                     (c2,c1)
+               in
+               let c2_bproof,c2_exp = add_c2_tree (n_c1,n_c2) c2_diff_context in
+               if c2_exp <> 0 then (* at least one open branch was generated to isloate [c2] *)
+                  begin
+(*   print_endline "start with new beta-proof"; *)
+                     let new_bproof,new_exp,new_closures,new_rest_proof  =
+                        build_opt_beta_proof c2_bproof rest_ext_proof beta_atoms beta_layer_list (act_context @ new_act_context) in
+                     (new_bproof,(new_exp+c2_exp),(new_closures+1),new_rest_proof)
+                  end
+               else
+                  begin
+(*   print_endline "proceed with old beta-proof"; *)
+                     (c2_bproof,c2_exp,1,rest_ext_proof)
+                  end
+          | (f,num)::c1_diff_r ->
+               let (layer1,layer2) = List.assoc f beta_layer_list in
+               let next_beta_proof,next_exp,next_closures,next_ext_proof =
+                  add_beta_expansions (c1,c2) rest_ext_proof c1_diff_r c2_diff_context new_act_context in
+               let new_bproof =
+                  if num = 1 then
+                     BNode(f,(layer1,next_beta_proof),(layer2,BEmpty))
+                  else (* num = 2*)
+                     BNode(f,(layer1,BEmpty),(layer2,next_beta_proof))
+               in
+               (new_bproof,(next_exp+1),next_closures,next_ext_proof)
+
+      in
+      let rec insert_connection beta_proof (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context =
+         begin
+(*   print_context c1 c1_diff_context;
+   print_endline "";
+   print_context c2 c2_diff_context;
+   print_endline "";
+*)
+            match beta_proof with
+               RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+             | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+             | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof")
+             | BEmpty ->
+                  add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context
+             | BNode(pos,(layer1,sproof1),(layer2,sproof2)) ->
+(*   print_endline (c1^" "^c2^" "^pos); *)
+                  (match c1_diff_context with
+                     [] ->
+                        raise (Invalid_argument "Jprover bug: invalid beta-proof")
+                   | (f,num)::rest_context -> (* f = pos must hold!! *)
+                        if num = 1 then
+                           let (next_bproof,next_exp,next_closure,next_ext_proof) =
+                              insert_connection sproof1 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in
+                           (BNode(pos,(layer1,next_bproof),(layer2,sproof2)),next_exp,next_closure,next_ext_proof)
+                        else (* num = 2 *)
+                           let (next_bproof,next_exp,next_closure,next_ext_proof) =
+                              insert_connection sproof2 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in
+                           (BNode(pos,(layer1,sproof1),(layer2,next_bproof)),next_exp,next_closure,next_ext_proof)
+                  )
+         end
+
+      in
+      match ext_proof with
+         [] ->
+            beta_proof,0,0,[]
+       | (c1,c2)::rproof ->
+(*  print_endline ("actual connection: "^c1^" "^c2); *)
+            let c1_context = List.assoc c1 beta_atoms
+            and c2_context = List.assoc c2 beta_atoms in
+            let c2_diff_context = compute_beta_difference c1_context c2_context act_context
+            and c1_diff_context = compute_tree_difference beta_proof c1_context in (* wrt. actual beta-proof *)
+            let (next_beta_proof,next_exp,next_closures,next_ext_proof) =
+               insert_connection beta_proof (c1,c2) rproof c1_diff_context c2_diff_context c1_diff_context in
+            if non_closed [next_beta_proof] then  (* at least one branch was generated to isolate [c1] *)
+               let rest_beta_proof,rest_exp,rest_closures,rest_ext_proof =
+                  build_opt_beta_proof next_beta_proof next_ext_proof beta_atoms beta_layer_list act_context in
+               rest_beta_proof,(next_exp+rest_exp),(next_closures+rest_closures),rest_ext_proof
+            else
+               next_beta_proof,next_exp,next_closures,next_ext_proof
+
+   let rec annotate_atoms beta_context atlist treelist =
+      let rec annotate_tree beta_context tree atlist =
+         match tree with
+            Empty ->
+               (atlist,[],[])
+          | NodeAt(pos) ->
+               if List.mem pos.name atlist then
+                  let new_atlist = list_del pos.name atlist in
+                  (new_atlist,[(pos.name,beta_context)],[])
+               else
+                  (atlist,[],[])
+          | NodeA(pos,suctrees) ->
+               if pos.pt = Beta then
+                  let s1,s2 = suctrees.(0),suctrees.(1) in
+                  let alayer1 = compute_alpha_layer [s1]
+                  and alayer2 = compute_alpha_layer [s2]
+                  and new_beta_context1 = beta_context @ [(pos.name,1)]
+                  and new_beta_context2 = beta_context @ [(pos.name,2)] in
+                  let atlist1,annotates1,blayer_list1 =
+                     annotate_atoms new_beta_context1 atlist [s1] in
+                  let atlist2,annotates2,blayer_list2 =
+                     annotate_atoms new_beta_context2 atlist1 [s2]
+                  in
+                  (atlist2,(annotates1 @ annotates2),((pos.name,(alayer1,alayer2))::(blayer_list1 @ blayer_list2)))
+               else
+                  annotate_atoms beta_context atlist (Array.to_list suctrees)
+      in
+      match treelist with
+         [] -> (atlist,[],[])
+       | f::r ->
+            let (next_atlist,f_annotates,f_beta_layers) = annotate_tree beta_context f atlist in
+            let (rest_atlist,rest_annotates,rest_beta_layers) = (annotate_atoms beta_context next_atlist r)
+            in
+            (rest_atlist, (f_annotates  @ rest_annotates),(f_beta_layers @ rest_beta_layers))
+
+   let construct_opt_beta_proof ftree ext_proof =
+      let con1,con2 = List.split ext_proof in
+      let con_atoms = remove_dups_list (con1 @ con2) in
+      let (empty_atoms,beta_atoms,beta_layer_list) = annotate_atoms [] con_atoms [ftree] in
+      let root_node = compute_alpha_layer [ftree] in
+      let (beta_proof,beta_exp,closures,_) =
+         build_opt_beta_proof BEmpty ext_proof beta_atoms beta_layer_list [] in
+      (RNode(root_node,beta_proof)),beta_exp,closures
+
+(************* permutation ljmc -> lj *********************************)
+
+(* REAL PERMUTATION STAFF *)
+
+   let subf1 n m  subrel = List.mem ((n,m),1) subrel
+   let subf2 n m  subrel = List.mem ((n,m),2) subrel
+   let tsubf n m  tsubrel = List.mem (n,m) tsubrel
+
+(* Transforms all normal form layers in an LJ proof *)
+
+   let rec modify prooftree (subrel,tsubrel) =
+      match prooftree with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx((pos,inf,form,term)) ->
+            prooftree,pos
+       | PNodeA((pos,inf,form,term),left)  ->
+            let t,qpos = modify left (subrel,tsubrel) in
+            if List.mem inf [Impr;Negr;Allr] then
+               PNodeA((pos,inf,form,term),t),pos    (* layer bound *)
+            else if qpos = "Orl-True" then
+               PNodeA((pos,inf,form,term),t),qpos
+            else if List.mem inf [Andl;Alll;Exl] then
+               PNodeA((pos,inf,form,term),t),qpos  (* simply propagation *)
+            else if inf = Exr then
+               if (subf1 pos qpos subrel) then
+                  PNodeA((pos,inf,form,term),t),pos
+               else t,qpos
+            else if inf = Negl then
+               if (subf1 pos qpos subrel) then
+                  PNodeA((pos,inf,form,term),t),""  (* empty string *)
+               else t,qpos
+            else                     (* x = Orr *)
+               if (subf1 pos qpos subrel) then
+                  PNodeA((pos,Orr1,form,term),t),pos    (* make Orr for LJ *)
+               else if (subf2 pos qpos subrel) then
+                  PNodeA((pos,Orr2,form,term),t),pos     (* make Orr for LJ *)
+               else t,qpos
+       | PNodeB((pos,inf,form,term),left,right) ->
+            let t,qpos = modify left (subrel,tsubrel) in
+            if inf = Andr then
+               if (or) (qpos = "Orl-True") (subf1 pos qpos subrel) then
+                  let s,rpos = modify right (subrel,tsubrel) in  (* Orl-True -> subf *)
+                  if (or) (rpos = "Orl-True") (subf2 pos rpos subrel) then
+                     PNodeB((pos,inf,form,term),t,s),pos
+                  else s,rpos
+               else t,qpos                (* not subf -> not Orl-True *)
+            else if inf = Impl then
+               if  (subf1 pos qpos subrel) then
+                  let s,rpos = modify right (subrel,tsubrel) in
+                  PNodeB((pos,inf,form,term),t,s),"" (* empty string *)
+               else t,qpos
+            else                           (* x = Orl *)
+               let s,rpos = modify right (subrel,tsubrel) in
+               PNodeB((pos,inf,form,term),t,s),"Orl-True"
+
+(* transforms the subproof into an LJ proof between
+   the beta-inference rule (excluded) and
+   layer boundary in the branch ptree *)
+
+   let rec rec_modify ptree (subrel,tsubrel) =
+      match ptree with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx((pos,inf,form,term)) ->
+            ptree,pos
+       | PNodeA((pos,inf,form,term),left)  ->
+            if List.mem inf [Impr;Negr;Allr] then
+               ptree,pos    (* layer bound, stop transforming! *)
+            else
+               let t,qpos = rec_modify left (subrel,tsubrel) in
+               if List.mem inf [Andl;Alll;Exl] then
+                  PNodeA((pos,inf,form,term),t),qpos   (* simply propagation*)
+               else if inf = Exr then
+                  if (subf1 pos qpos subrel) then
+                     PNodeA((pos,inf,form,term),t),pos
+                  else t,qpos
+               else if inf = Negl then
+                  if (subf1 pos qpos subrel) then
+                     PNodeA((pos,inf,form,term),t),""  (* empty string *)
+                  else t,qpos
+               else                     (* x = Orr *)
+                  if (subf1 pos qpos subrel) then
+                     PNodeA((pos,Orr1,form,term),t),pos    (* make Orr for LJ *)
+                  else if (subf2 pos qpos subrel) then
+                     PNodeA((pos,Orr2,form,term),t),pos     (* make Orr for LJ *)
+                  else t,qpos
+       | PNodeB((pos,inf,form,term),left,right) ->
+            let t,qpos = rec_modify left (subrel,tsubrel) in
+            if inf = Andr then
+               if (subf1 pos qpos subrel) then
+                  let s,rpos = rec_modify right (subrel,tsubrel) in
+                  if (subf2 pos rpos subrel) then
+                     PNodeB((pos,inf,form,term),t,s),pos
+                  else s,rpos
+               else t,qpos
+            else (* x = Impl since x= Orl cannot occur in the partial layer ptree *)
+
+               if  (subf1 pos qpos subrel) then
+                  let s,rpos = rec_modify right (subrel,tsubrel) in
+                  PNodeB((pos,inf,form,term),t,s),"" (* empty string *)
+               else t,qpos
+
+   let weak_modify rule ptree (subrel,tsubrel) =   (* recall rule = or_l  *)
+      let (pos,inf,formlua,term) = rule in
+      if inf = Orl then
+         ptree,true
+      else
+         let ptreem,qpos = rec_modify ptree (subrel,tsubrel) in
+         if (subf1 pos qpos subrel) then  (* weak_modify will always be applied on left branches *)
+            ptreem,true
+         else
+            ptreem,false
+
+(* Now, the permutation stuff .... *)
+
+(* Permutation schemes *)
+
+(* corresponds to local permutation lemma -- Lemma 3 in the paper -- *)
+(* with eigenvariablen renaming and branch modification *)
+
+(* eigenvariablen renaming and branch modification over *)
+(* the whole proofs, i.e. over layer boundaries, too *)
+
+
+(* global variable vor eigenvariable renaming during permutations *)
+
+   let eigen_counter = ref 1
+
+(* append renamed paramater "r" to non-quantifier subformulae
+   of renamed quantifier formulae *)
+
+(*: BUG :*)
+(*:
+   let make_new_eigenvariable term =
+      let op = (dest_term term).term_op in
+      let opn = (dest_op op).op_name in
+      let opnam = dest_opname opn in
+      match opnam with
+         [] ->
+            raise jprover_bug
+       | ofirst::orest ->
+            let ofname = List.hd orest in
+            let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in
+            eigen_counter := !eigen_counter + 1;
+(*        print_endline ("New Counter :"^(string_of_int (!eigen_counter))); *)
+            mk_string_term jprover_op new_eigen_var
+:*)
+
+   let make_new_eigenvariable term =
+      let op = (dest_term term).term_op in
+      let opa = (dest_op op).op_params in
+      let oppar = dest_param opa in
+      match oppar with
+         | String ofname::_ ->
+            let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in
+            eigen_counter := !eigen_counter + 1;
+            mk_string_term jprover_op new_eigen_var
+         | _ -> raise jprover_bug
+
+
+   let replace_subterm term oldt rept  =
+      let v_term = var_subst term oldt "dummy_var" in
+      subst1 v_term "dummy_var" rept
+
+   let rec eigen_rename old_parameter new_parameter ptree =
+      match ptree with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx((pos,inf,form,term)) ->
+            let new_form = replace_subterm form old_parameter new_parameter in
+            PNodeAx((pos,inf,new_form,term))
+       | PNodeA((pos,inf,form,term), left) ->
+            let new_form = replace_subterm form old_parameter new_parameter
+            and new_term = replace_subterm term old_parameter new_parameter in
+            let ren_left = eigen_rename old_parameter new_parameter left in
+            PNodeA((pos,inf,new_form,new_term), ren_left)
+       | PNodeB((pos,inf,form,term),left, right) ->
+            let new_form = replace_subterm form old_parameter new_parameter in
+            let ren_left  = eigen_rename old_parameter new_parameter left  in
+            let ren_right  = eigen_rename old_parameter new_parameter right  in
+            PNodeB((pos,inf,new_form,term), ren_left, ren_right)
+
+   let rec update_ptree rule subtree direction tsubrel =
+      match subtree with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx(r) ->
+            subtree
+       | PNodeA((pos,inf,formula,term), left) ->
+            if (pos,inf,formula,term) = rule then
+               left
+          (* don't delete rule if subformula belongs to renamed instance of quantifiers; *)
+          (* but this can never occur now since (renamed) formula is part of rule *)
+            else
+               let (posn,infn,formn,termn) = rule in
+               if (&) (List.mem infn [Exl;Allr] ) (term = termn) then
+    (* this can only occur if eigenvariable rule with same term as termn has been permuted; *)
+    (* the application of the same eigenvariable introduction on the same subformula with *)
+    (* different instantiated variables might occur! *)
+    (* termn cannot occur in terms of permuted quantifier rules due to substitution split *)
+    (* during reconstruciton of the ljmc proof *)
+                  let new_term =  make_new_eigenvariable term in
+(*              print_endline "Eigenvariable renaming!!!"; *)
+                  eigen_rename termn new_term subtree
+               else
+                  let left_del =
+                     update_ptree rule left direction tsubrel
+                  in
+                  PNodeA((pos,inf,formula,term), left_del)
+       | PNodeB((pos,inf,formula,term), left, right) ->
+            if (pos,inf,formula,term) = rule then
+               if direction = "l" then
+                  left
+               else
+                  right   (* direction = "r" *)
+            else
+               let left_del = update_ptree rule left direction tsubrel in
+               let right_del = update_ptree rule right direction tsubrel in
+               PNodeB((pos,inf,formula,term),left_del,right_del)
+
+   let permute r1 r2 ptree  la tsubrel =
+(*  print_endline "permute in"; *)
+      match ptree,la with
+         PNodeA(r1, PNodeA(r2,left)),la ->
+(*        print_endline "1-o-1";   *)
+            PNodeA(r2, PNodeA(r1,left))
+                                     (* one-over-one *)
+       | PNodeA(r1, PNodeB(r2,left,right)),la ->
+(*        print_endline "1-o-2";   *)
+            PNodeB(r2, PNodeA(r1,left), PNodeA(r1,right))
+                                     (* one-over-two *)
+       | PNodeB(r1, PNodeA(r2,left), right),"l" ->
+(*        print_endline "2-o-1 left";   *)
+            let right_u = update_ptree r2 right "l" tsubrel in
+            PNodeA(r2, PNodeB(r1, left, right_u))
+                                     (* two-over-one left *)
+       | PNodeB(r1, left, PNodeA(r2,right)),"r" ->
+(*        print_endline "2-o-1 right";   *)
+            let left_u = update_ptree r2 left "l" tsubrel in
+            PNodeA(r2, PNodeB(r1, left_u, right))
+                                     (* two-over-one right *)
+       | PNodeB(r1, PNodeB(r2,left2,right2), right),"l" ->
+(*        print_endline "2-o-2 left"; *)
+            let right_ul = update_ptree r2 right "l" tsubrel in
+            let right_ur  = update_ptree  r2 right "r" tsubrel in
+            PNodeB(r2,PNodeB(r1,left2,right_ul),PNodeB(r1,right2,right_ur))
+                                     (* two-over-two left *)
+       | PNodeB(r1, left, PNodeB(r2,left2,right2)),"r" ->
+(*        print_endline "2-o-2 right"; *)
+            let left_ul = update_ptree r2 left "l" tsubrel in
+            let left_ur  = update_ptree  r2 left "r"  tsubrel in
+            PNodeB(r2,PNodeB(r1,left_ul,left2),PNodeB(r1,left_ur, right2))
+                                     (* two-over-two right *)
+       | _ -> raise jprover_bug
+
+(* permute layers, isolate addmissible branches *)
+
+(* computes if an Andr is d-generatives *)
+
+   let layer_bound rule =
+      let (pos,inf,formula,term) = rule in
+      if List.mem inf [Impr;Negr;Allr] then
+         true
+      else
+         false
+
+   let rec orl_free ptree  =
+      match ptree with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx(rule) ->
+            true
+       | PNodeA(rule,left) ->
+            if layer_bound rule then
+               true
+            else
+               orl_free left
+       | PNodeB(rule,left,right) ->
+            let (pos,inf,formula,term) =  rule in
+            if inf = Orl then
+               false
+            else
+               (&) (orl_free left) (orl_free right)
+
+   let rec dgenerative rule dglist ptree tsubrel =
+      let (pos,inf,formula,term) = rule in
+      if List.mem inf [Exr;Orr;Negl] then
+         true
+      else if inf = Andr then
+         if dglist = [] then
+            false
+         else
+            let first,rest = (List.hd dglist),(List.tl dglist) in
+            let (pos1,inf1,formula1,term1) = first in
+            if tsubf pos1 pos tsubrel then
+               true
+            else
+               dgenerative rule rest ptree tsubrel
+      else if inf = Impl then
+         not (orl_free ptree)
+      else
+         false
+
+
+(* to compute a topmost addmissible pair r,o  with
+   the address addr of r in the proof tree
+*)
+
+   let rec top_addmissible_pair ptree dglist act_r act_o act_addr tsubrel dummyt =
+      let rec search_pair ptree dglist act_r act_o act_addr tsubrel =
+         match ptree with
+            PEmpty -> raise jprover_bug
+          | PNodeAx(_) -> raise jprover_bug
+          | PNodeA(rule, left) ->
+(*      print_endline "alpha"; *)
+               if (dgenerative rule dglist left tsubrel) then  (* r = Exr,Orr,Negl *)
+                  let newdg = (@) [rule] dglist   in
+                  search_pair left newdg act_r rule act_addr tsubrel
+               else                   (* Impr, Allr, Notr only for test *)
+                  search_pair left dglist act_r act_o act_addr tsubrel
+          | PNodeB(rule,left,right) ->
+(*      print_endline "beta";  *)
+               let (pos,inf,formula,term) = rule in
+               if List.mem inf [Andr;Impl] then
+                  let bool = dgenerative rule dglist left tsubrel in
+                  let newdg,newrule =
+                     if bool then
+                        ((@) [rule] dglist),rule
+                     else
+                        dglist,act_o
+                  in
+                  if orl_free left then
+                     search_pair right newdg act_r newrule (act_addr^"r") tsubrel
+                  else  (* not orl_free *)
+                     let left_r,left_o,left_addr =
+                        search_pair left newdg act_r newrule (act_addr^"l") tsubrel in
+                     if left_o =  ("",Orr,dummyt,dummyt) then
+                        top_addmissible_pair right dglist act_r act_o (act_addr^"r") tsubrel dummyt
+                     else  left_r,left_o,left_addr
+               else  (* r = Orl *)
+                  if orl_free left then
+                     top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt
+                  else
+                     let left_r,left_o,left_addr
+                           = search_pair left dglist rule act_o (act_addr^"l") tsubrel in
+                     if left_o =  ("",Orr,dummyt,dummyt) then
+                        top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt
+                     else
+                        left_r,left_o,left_addr
+      in
+(*  print_endline "top_addmissible_pair in"; *)
+      if orl_free ptree then                  (* there must be a orl BELOW an layer bound *)
+         begin
+(*    print_endline "orl_free"; *)
+            act_r,act_o,act_addr
+         end
+      else
+         begin
+(*    print_endline "orl_full"; *)
+            search_pair ptree dglist act_r act_o act_addr tsubrel
+         end
+
+   let next_direction addr act_addr =
+      String.make 1 (String.get addr (String.length act_addr))
+        (* get starts with count 0*)
+
+   let change_last addr d =
+      let split = (String.length addr) - 1 in
+      let prec,last =
+         (String.sub addr 0 split),(String.sub addr split 1) in
+      prec^d^last
+
+   let last addr =
+      if addr = ""
+      then ""
+      else
+         String.make 1 (String.get addr (String.length addr-1))
+
+   let rest addr =
+      if addr = ""
+      then ""
+      else
+         String.sub addr 0 ((String.length addr) - 1)
+
+   let rec permute_layer ptree dglist (subrel,tsubrel) =
+      let rec permute_branch r addr act_addr ptree dglist (subrel,tsubrel) =
+(*   print_endline "pbranch in"; *)
+         let la = last act_addr in  (* no ensure uniqueness at 2-over-x *)
+         match ptree,la with
+            PNodeA(o,PNodeA(rule,left)),la ->   (* one-over-one *)
+(*       print_endline " one-over-one ";                  *)
+               let permute_result = permute o rule ptree la tsubrel in
+               begin match permute_result with
+                  PNodeA(r2,left2) ->
+                     let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in
+                     PNodeA(r2,pbleft)
+                | _ -> raise jprover_bug
+               end
+          | PNodeA(o,PNodeB(rule,left,right)),la ->                (* one-over-two *)
+(*     print_endline " one-over-two ";                  *)
+               if rule = r then  (* left,right are or_l free *)
+                  permute o rule ptree  la tsubrel (* first termination case *)
+               else
+                  let d = next_direction addr act_addr in
+                  if d = "l" then
+                     let permute_result = permute o rule ptree la tsubrel in
+                     (match permute_result with
+                        PNodeB(r2,left2,right2) ->
+                           let pbleft = permute_branch r addr (act_addr^d) left2 dglist (subrel,tsubrel) in
+                           let plright = permute_layer right2 dglist (subrel,tsubrel) in
+                           PNodeB(r2,pbleft,plright)
+                      | _ -> raise jprover_bug
+                     )
+                  else  (* d = "r", that is left of rule is or_l free *)
+                     let left1,bool = weak_modify rule left (subrel,tsubrel) in
+                     if bool then  (* rule is relevant *)
+                        let permute_result = permute o rule (PNodeA(o,PNodeB(rule,left1,right))) la tsubrel in
+                        (match permute_result with
+                           PNodeB(r2,left2,right2) ->
+                              let pbright = permute_branch r addr (act_addr^d) right2 dglist (subrel,tsubrel) in
+                              PNodeB(r2,left2,pbright)
+                         | _ -> raise jprover_bug
+                        )
+                     else          (* rule is not relevant *)
+                        PNodeA(o,left1)  (* optimized termination case (1) *)
+          | PNodeB(o,PNodeA(rule,left),right1),"l" ->               (* two-over-one, left *)
+(*       print_endline " two-over-one, left "; *)
+               let permute_result = permute o rule ptree la tsubrel in
+               (match permute_result with
+                  PNodeA(r2,left2) ->
+                     let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in
+                     PNodeA(r2,pbleft)
+                | _ -> raise jprover_bug
+               )
+          | PNodeB(o,left1,PNodeA(rule,left)),"r" ->                (* two-over-one, right *)
+                                                (* left of o is or_l free *)
+(*      print_endline " two-over-one, right"; *)
+               let leftm,bool = weak_modify o left1 (subrel,tsubrel) in
+               if bool then  (* rule is relevant *)
+                  let permute_result = permute o rule (PNodeB(o,leftm,PNodeA(rule,left))) la tsubrel in
+                  (match permute_result with
+                     PNodeA(r2,left2) ->
+                        let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in
+                        PNodeA(r2,pbleft)
+                   | _ -> raise jprover_bug
+                  )
+               else          (* rule is not relevant *)
+                  leftm  (* optimized termination case (2) *)
+          | PNodeB(o,PNodeB(rule,left,right),right1),"l" ->             (* two-over-two, left *)
+(*     print_endline " two-over-two, left"; *)
+               if rule = r then   (* left,right are or_l free *)
+                  let permute_result = permute o rule ptree  la tsubrel in
+                  (match permute_result with
+                     PNodeB(r2,PNodeB(r3,left3,right3),PNodeB(r4,left4,right4)) ->
+(*        print_endline "permute 2-o-2, left ok"; *)
+                        let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in
+                        let leftm4,bool4 = weak_modify r4 left4 (subrel,tsubrel) in
+                        let plleft,plright =
+                           if (&) bool3 bool4 then   (* r3 and r4 are relevant *)
+                              (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)),
+                              (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel))
+                           else if (&) bool3 (not bool4) then   (* only r3 is relevant *)
+                              begin
+(*               print_endline "two-over-two left: bool3 and not bool4"; *)
+                                 (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)),
+                                 leftm4
+                              end
+                           else if (&) (not bool3) bool4 then   (* only r4 is relevant *)
+                              leftm3,
+                              (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel))
+                           else    (* neither r3 nor r4 are relevant *)
+                              leftm3,leftm4
+                        in
+                        PNodeB(r2,plleft,plright)
+                   | _ -> raise jprover_bug
+                  )
+               else
+                  let d = next_direction addr act_addr in
+                  let newadd = change_last act_addr d in
+                  if d = "l" then
+                     let permute_result = permute o rule ptree la tsubrel in
+                     (match permute_result with
+                        PNodeB(r2,left2,right2) ->
+                           let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in
+                           let plright = permute_layer right2 dglist (subrel,tsubrel) in
+                           PNodeB(r2,pbleft,plright)
+                      | _ -> raise jprover_bug
+                     )
+                  else  (* d = "r", that is left is or_l free *)
+                     let left1,bool = weak_modify rule left (subrel,tsubrel) in
+                     if bool then  (* rule is relevant *)
+                        let permute_result =
+                           permute o rule (PNodeB(o,PNodeB(rule,left1,right),right1)) la tsubrel in
+                        (match permute_result with
+                           PNodeB(r2,PNodeB(r3,left3,right3),right2) ->
+                              let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in
+                              let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in
+                              let plleft =
+                                 if bool3 (* r3 relevant *) then
+                                    permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)
+                                 else  (* r3 redundant *)
+                                    leftm3
+                              in
+                              PNodeB(r2,plleft,pbright)  (* further opt. NOT possible *)
+                         | _ -> raise jprover_bug
+                        )
+                     else          (* rule is not relevant *)
+                        permute_layer (PNodeB(o,left1,right1)) dglist (subrel,tsubrel) (* further opt. possible *)
+                                                           (* combine with orl_free *)
+          | PNodeB(o,left1,PNodeB(rule,left,right)),"r" ->             (* two-over-two, right *)
+(*      print_endline " two-over-two, right"; *)
+               let leftm1,bool = weak_modify o left1 (subrel,tsubrel) in  (* left1 is or_l free *)
+               if bool then  (* o is relevant, even after permutations *)
+                  if rule = r then  (* left, right or_l free *)
+                     permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel
+                  else
+                     let d = next_direction addr act_addr in
+                     let newadd = change_last act_addr d in
+                     if d = "l" then
+                        let permute_result  =
+                           permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in
+                        (match permute_result with
+                                 PNodeB(r2,left2,right2) ->
+                              let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in
+                              let plright = permute_layer right2 dglist (subrel,tsubrel) in
+                              PNodeB(r2,pbleft,plright)
+                         | _ -> raise jprover_bug
+                        )
+                     else  (* d = "r", that is left is or_l free *)
+                        let leftm,bool = weak_modify rule left (subrel,tsubrel) in
+                        if bool then  (* rule is relevant *)
+                           let permute_result =
+                              permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in
+                           (match permute_result with
+                                PNodeB(r2,left2,right2) ->
+                                 let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in
+                                 PNodeB(r2,left2,pbright)  (* left2 or_l free *)
+                            | _ -> raise jprover_bug
+                           )
+                        else (* rule is not relevant *)
+                           PNodeB(o,leftm1,leftm)
+
+               else
+                  leftm1
+          | _ -> raise jprover_bug
+      in
+      let rec trans_add_branch r o addr act_addr ptree dglist (subrel,tsubrel) =
+         match ptree with
+            (PEmpty| PNodeAx(_)) -> raise jprover_bug
+          | PNodeA(rule,left) ->
+               if (dgenerative rule dglist left tsubrel) then
+                  let newdg = (@) [rule] dglist in
+                  if rule = o then
+                     begin
+(*             print_endline "one-rule is o"; *)
+                        permute_branch r addr act_addr ptree dglist (subrel,tsubrel)
+                     end
+                  else
+                     begin
+(*             print_endline "alpha - but not o"; *)
+                        let tptree = trans_add_branch r o addr act_addr left newdg (subrel,tsubrel) in
+                        permute_layer (PNodeA(rule,tptree)) dglist (subrel,tsubrel)
+                (* r may not longer be valid for rule *)
+                     end
+               else
+                  let tptree =  trans_add_branch r o addr act_addr left dglist (subrel,tsubrel) in
+                  PNodeA(rule,tptree)
+          | PNodeB(rule,left,right) ->
+               let d = next_direction addr act_addr in
+               let bool = (dgenerative rule dglist left tsubrel) in
+               if rule = o then
+                  begin
+(*          print_endline "two-rule is o"; *)
+                     permute_branch r addr (act_addr^d) ptree dglist (subrel,tsubrel)
+                  end
+               else
+                  begin
+(*         print_endline ("beta - but not o: address "^d); *)
+                     let dbranch =
+                        if d = "l" then
+                           left
+                        else   (* d = "r" *)
+                           right
+                     in
+                     let tptree =
+                        if bool then
+                           let newdg = (@) [rule] dglist in
+                           (trans_add_branch r o addr (act_addr^d) dbranch newdg (subrel,tsubrel))
+                        else
+                           (trans_add_branch r o addr (act_addr^d) dbranch dglist (subrel,tsubrel))
+                     in
+                     if d = "l" then
+                        permute_layer (PNodeB(rule,tptree,right)) dglist (subrel,tsubrel)
+                     else  (* d = "r" *)
+                        begin
+(*            print_endline "prob. a redundant call";  *)
+                           let back  = permute_layer (PNodeB(rule,left,tptree)) dglist  (subrel,tsubrel) in
+(*             print_endline "SURELY a redundant call"; *)
+                           back
+                        end
+                  end
+      in
+(*  print_endline "permute_layer in"; *)
+      let dummyt = mk_var_term "dummy" in
+      let r,o,addr =
+         top_addmissible_pair ptree dglist ("",Orl,dummyt,dummyt) ("",Orr,dummyt,dummyt) "" tsubrel dummyt in
+      if r = ("",Orl,dummyt,dummyt) then
+         ptree
+      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 ("or_l address: "^addr);
+   print_endline ("top dgen-rule: "^y1); *)
+         trans_add_branch r o addr "" ptree dglist (subrel,tsubrel)
+
+(* Isolate layer and outer recursion structure *)
+(* uses weaker layer boundaries: ONLY critical inferences *)
+
+   let rec trans_layer ptree (subrel,tsubrel) =
+      let rec isol_layer ptree (subrel,tsubrel) =
+         match ptree with
+            PEmpty -> raise jprover_bug
+          | PNodeAx(inf) ->
+               ptree
+          | PNodeA((pos,rule,formula,term),left) ->
+               if List.mem  rule [Allr;Impr;Negr] then
+                  let tptree = trans_layer left (subrel,tsubrel) in
+                  PNodeA((pos,rule,formula,term),tptree)
+               else
+                  let tptree = isol_layer  left (subrel,tsubrel) in
+                  PNodeA((pos,rule,formula,term),tptree)
+          | PNodeB(rule,left,right) ->
+               let tptree_l = isol_layer  left (subrel,tsubrel)
+               and tptree_r = isol_layer  right (subrel,tsubrel) in
+               PNodeB(rule,tptree_l,tptree_r)
+      in
+      begin
+(*   print_endline "trans_layer in"; *)
+         let top_tree = isol_layer  ptree (subrel,tsubrel) in
+         let back = permute_layer  top_tree [] (subrel,tsubrel) in
+(*     print_endline "translauer out"; *)
+         back
+      end
+
+(* REAL PERMUTATION STAFF  --- End *)
+
+(* build the proof tree from a list of inference rules *)
+
+   let rec unclosed subtree =
+      match subtree with
+         PEmpty -> true
+       | PNodeAx(y) -> false
+       | PNodeA(y,left) -> (unclosed left)
+       | PNodeB(y,left,right) -> (or) (unclosed left) (unclosed right)
+
+   let rec extend prooftree element =
+      match prooftree with
+         PEmpty ->
+            let (pos,rule,formula,term) = element in
+            if rule = Ax then
+               PNodeAx(element)
+            else
+               if List.mem rule [Andr; Orl; Impl] then
+                  PNodeB(element,PEmpty,PEmpty)
+               else
+                  PNodeA(element,PEmpty)
+       | PNodeAx(y) ->
+            PEmpty           (* that's only for  exhaustive pattern matching *)
+       | PNodeA(y, left) ->
+            PNodeA(y, (extend left element))
+       | PNodeB(y, left, right) ->
+            if (unclosed left) then
+               PNodeB(y, (extend left element), right)
+            else
+               PNodeB(y, left, (extend right element))
+
+   let rec bptree prooftree nodelist nax=
+      match nodelist with
+         [] -> prooftree,nax
+       | ((_,pos),(rule,formula,term))::rest -> (* kick away the first argument *)
+            let newax =
+               if rule = Ax then
+                  1
+               else
+                  0
+            in
+            bptree (extend prooftree (pos,rule,formula,term)) rest (nax+newax)
+
+
+   let bproof nodelist =
+      bptree PEmpty nodelist 0
+
+   let rec get_successor_pos treelist =
+      match treelist with
+         [] -> []
+       | f::r ->
+            (
+             match f with
+                Empty -> get_successor_pos r
+              | NodeAt(_) -> raise jprover_bug
+              | NodeA(pos,_) ->
+                   pos::(get_successor_pos r)
+            )
+
+   let rec get_formula_tree ftreelist f predflag =
+      match ftreelist with
+         [] -> raise jprover_bug
+       | ftree::rest_trees ->
+            (match ftree with
+               Empty -> get_formula_tree rest_trees f predflag
+             | NodeAt(_) -> get_formula_tree rest_trees f predflag
+             | NodeA(pos,suctrees) ->
+                  if predflag = "pred" then
+                     if pos.pt = Gamma then
+                        let succs = get_successor_pos (Array.to_list suctrees) in
+                        if List.mem f succs then
+                           NodeA(pos,suctrees),succs
+                        else
+                           get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag
+                     else
+                        get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag
+                  else (* predflag = "" *)
+                     if pos = f then
+                        NodeA(pos,suctrees),[]
+                     else
+                        get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag
+            )
+
+   let rec get_formula_treelist ftree po =
+      match po with
+         [] -> []
+       | f::r ->
+(* a posistion in po has either stype Gamma_0,Psi_0,Phi_0 (non-atomic), or it has *)
+(* ptype Alpha (or on the right), since there was a deadlock for proof reconstruction in LJ*)
+            if List.mem f.st [Phi_0;Psi_0] then
+               let (stree,_) = get_formula_tree [ftree] f "" in
+               stree::(get_formula_treelist ftree r)
+            else
+               if f.st = Gamma_0 then
+                  let (predtree,succs) = get_formula_tree [ftree] f "pred" in
+                  let new_po = list_diff r succs in
+                  predtree::(get_formula_treelist ftree new_po)
+               else
+                  if f.pt = Alpha then (* same as first case, or on the right *)
+                     let (stree,_) = get_formula_tree [ftree] f "" in
+                     stree::(get_formula_treelist ftree r)
+                  else raise (Invalid_argument "Jprover bug: non-admissible open position")
+
+   let rec build_formula_rel dir_treelist slist predname =
+
+      let rec build_renamed_gamma_rel dtreelist predname posname d =
+         match dtreelist with
+            [] -> [],[]
+          | (x,ft)::rdtlist ->
+               let rest_rel,rest_ren = build_renamed_gamma_rel rdtlist predname posname d  in
+               (
+                match ft with
+                   Empty ->   (* may have empty successors due to purity in former reconstruction steps *)
+                      rest_rel,rest_ren
+                 | NodeAt(_) ->
+                      raise jprover_bug (* gamma_0 position never is atomic *)
+                 | NodeA(spos,suctrees) ->
+                      if List.mem spos.name slist then
+(* the gamma_0 position is really unsolved *)
+(* this is only relevant for the gamma_0 positions in po *)
+                         let new_name = (posname^"_"^spos.name) (* make new unique gamma name *) in
+                         let new_srel_el = ((predname,new_name),d)
+                         and new_rename_el = (spos.name,new_name)  (* gamma_0 position as key first *) in
+                         let (srel,sren) = build_formula_rel [(x,ft)] slist new_name in
+                         ((new_srel_el::srel) @ rest_rel),((new_rename_el::sren) @ rest_ren)
+                      else
+                         rest_rel,rest_ren
+               )
+
+
+      in
+      match dir_treelist with
+         [] -> [],[]
+       | (d,f)::dir_r ->
+            let (rest_rel,rest_renlist) = build_formula_rel dir_r slist predname in
+            match f with
+               Empty ->
+                  print_endline "Hello, an empty subtree!!!!!!";
+                  rest_rel,rest_renlist
+             | NodeAt(pos) ->
+                  (((predname,pos.name),d)::rest_rel),rest_renlist
+             | NodeA(pos,suctrees) ->
+                  (match pos.pt with
+                     Alpha | Beta ->
+                        let dtreelist =
+                           if (pos.pt = Alpha) & (pos.op = Neg) then
+                              [(1,suctrees.(0))]
+                           else
+                              let st1 = suctrees.(0)
+                              and st2 = suctrees.(1) in
+                              [(1,st1);(2,st2)]
+                        in
+                        let (srel,sren) = build_formula_rel dtreelist slist pos.name in
+                        ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist)
+                   | Delta ->
+                        let st1 = suctrees.(0) in
+                        let (srel,sren) = build_formula_rel [(1,st1)] slist pos.name in
+                        ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist)
+                   | Psi| Phi ->
+                        let succlist = Array.to_list suctrees in
+                        let dtreelist = (List.map (fun x -> (d,x)) succlist) in
+                        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 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
+   ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist)
+   else (* we have more than one gamma instance, which means renaming *)
+*)
+                        let (srel,sren) = build_renamed_gamma_rel dtreelist predname pos.name d in
+                        (srel @ rest_rel),(sren @ rest_renlist)
+                   | PNull ->
+                        raise jprover_bug
+                  )
+
+   let rec rename_gamma ljmc_proof rename_list =
+      match ljmc_proof with
+         [] -> []
+       | ((inst,pos),(rule,formula,term))::r ->
+            if List.mem rule [Alll;Exr] then
+               let new_gamma = List.assoc inst rename_list in
+               ((inst,new_gamma),(rule,formula,term))::(rename_gamma r rename_list)
+            else
+               ((inst,pos),(rule,formula,term))::(rename_gamma r rename_list)
+
+   let rec compare_pair (s,sf) list =
+      if list = [] then
+         list
+      else
+         let (s_1,sf_1),restlist = (List.hd list),(List.tl list) in
+         if sf = s_1 then
+            (@) [(s,sf_1)] (compare_pair (s,sf) restlist)
+         else
+            compare_pair (s,sf) restlist
+
+   let rec compare_pairlist list1 list2 =
+      if list1 = [] then
+         list1
+      else
+         let (s1,sf1),restlist1  =  (List.hd list1),(List.tl list1) in
+         (@) (compare_pair (s1,sf1) list2) (compare_pairlist restlist1 list2)
+
+   let rec trans_rec pairlist translist =
+      let tlist = compare_pairlist pairlist translist in
+      if tlist = [] then
+         translist
+      else
+         (@) (trans_rec pairlist tlist) translist
+
+   let transitive_closure subrel =
+      let pairlist,nlist = List.split subrel in
+      trans_rec pairlist pairlist
+
+   let pt ptree subrel =
+      let tsubrel = transitive_closure subrel in
+      let transptree = trans_layer ptree (subrel,tsubrel) in
+      print_endline "";
+      fst (modify transptree (subrel,tsubrel))
+(*     let mtree = fst (modify transptree (subrel,tsubrel)) in *)
+(*       pretty_print mtree ax *)
+
+   let rec make_node_list ljproof =
+      match ljproof with
+         PEmpty ->
+            raise jprover_bug
+       | PNodeAx((pos,inf,form,term)) ->
+            [(("",pos),(inf,form,term))]
+       | PNodeA((pos,inf,form,term),left) ->
+            let left_list =  make_node_list left in
+            (("",pos),(inf,form,term))::left_list
+       | PNodeB((pos,inf,form,term),left,right) ->
+            let left_list =  make_node_list left
+            and right_list =  make_node_list right in
+            (("",pos),(inf,form,term))::(left_list @ right_list)
+
+   let  permute_ljmc ftree po slist ljmc_proof =
+ (* ftree/po are the formula tree / open positions of the sequent that caused deadlock and permutation *)
+(*  print_endline "!!!!!!!!!!!!!Permutation TO DO!!!!!!!!!"; *)
+ (* the open positions in po are either phi_0, psi_0, or gamma_0 positions *)
+ (* since proof reconstruction was a deadlock in LJ *)
+      let po_treelist = get_formula_treelist ftree po in
+      let dir_treelist = List.map (fun x -> (1,x)) po_treelist in
+      let (formula_rel,rename_list) = build_formula_rel dir_treelist slist "dummy" in
+      let renamed_ljmc_proof = rename_gamma ljmc_proof rename_list in
+      let (ptree,ax) =  bproof renamed_ljmc_proof in
+      let ljproof = pt ptree formula_rel in
+           (* this is a direct formula relation, comprising left/right subformula *)
+      begin
+(*   print_treelist po_treelist; *)
+(*   print_endline "";
+   print_endline "";
+*)
+(*   print_triplelist formula_rel; *)
+(*   print_endline "";
+   print_endline "";
+   tt ljproof;
+*)
+(*   print_pairlist rename_list; *)
+(*   print_endline "";
+   print_endline "";
+*)
+         make_node_list ljproof
+      end
+
+(************** PROOF RECONSTRUCTION without redundancy deletion ******************************)
+
+   let rec init_unsolved treelist =
+      match treelist with
+         [] -> []
+       | f::r ->
+            begin match f with
+               Empty -> []
+             | NodeAt(pos) ->
+                  (pos.name)::(init_unsolved r)
+             | NodeA(pos,suctrees) ->
+                  let new_treelist = (Array.to_list suctrees) @ r in
+                  (pos.name)::(init_unsolved new_treelist)
+            end
+
+(* only the unsolved positions will be represented --> skip additional root position *)
+
+   let build_unsolved ftree =
+      match ftree with
+         Empty | NodeAt _ ->
+            raise jprover_bug
+       | NodeA(pos,suctrees) ->
+            ((pos.name),init_unsolved (Array.to_list suctrees))
+
+(*
+   let rec collect_variables tree_list =
+      match tree_list with
+         [] -> []
+       | f::r ->
+            begin match f with
+               Empty -> []
+             | NodeAt(pos) ->
+                  if pos.st = Gamma_0 then
+                     pos.name::collect_variables r
+                  else
+                     collect_variables r
+             | NodeA(pos,suctrees) ->
+                  let new_tree_list = (Array.to_list suctrees) @ r in
+                  if pos.st = Gamma_0 then
+                     pos.name::collect_variables new_tree_list
+                  else
+                     collect_variables new_tree_list
+            end
+
+   let rec extend_sigmaQ sigmaQ vlist =
+      match vlist with
+         [] -> []
+       | f::r ->
+            let vf = mk_var_term f in
+            if List.exists (fun x -> (fst x = vf)) sigmaQ then
+               extend_sigmaQ sigmaQ r
+            else
+(* first and second component are var terms in meta-prl *)
+               [(vf,vf)] @ (extend_sigmaQ sigmaQ r)
+
+   let build_sigmaQ sigmaQ ftree =
+      let vlist = collect_variables [ftree] in
+      sigmaQ @ (extend_sigmaQ sigmaQ vlist)
+*)
+
+(* subformula relation subrel is assumed to be represented in pairs
+   (a,b) *)
+
+   let rec delete e list =     (* e must not necessarily occur in list *)
+      match list with
+         [] -> []               (* e must not necessarily occur in list *)
+       | first::rest ->
+            if e = first then
+               rest
+            else
+               first::(delete e rest)
+
+   let rec key_delete fname pos_list =   (* in key_delete, f is a pos name (key) but sucs is a list of positions *)
+      match pos_list with
+         [] -> []               (* the position with name f  must not necessarily occur in pos_list *)
+       | f::r ->
+            if fname = f.name then
+               r
+            else
+               f::(key_delete fname r)
+
+   let rec get_roots treelist =
+      match treelist with
+         [] -> []
+       | f::r ->
+            match f with
+               Empty -> (get_roots r)    (* Empty is posible below alpha-nodes after purity *)
+             | NodeAt(pos) -> pos::(get_roots r)
+             | NodeA(pos,trees) ->  pos::(get_roots r)
+
+   let rec comp_ps padd ftree =
+      match ftree with
+         Empty -> raise (Invalid_argument "Jprover bug: empty formula tree")
+       | NodeAt(pos) ->
+            []
+       | NodeA(pos,strees) ->
+            match padd with
+               [] -> get_roots (Array.to_list strees)
+             | f::r ->
+                  if r = [] then
+                     pos::(comp_ps r (Array.get strees (f-1)))
+                  else
+                     comp_ps r (Array.get strees (f-1))
+
+(* computes a list: first element predecessor, next elements successoes of p *)
+
+   let tpredsucc p ftree =
+      let padd = p.address in
+      comp_ps padd ftree
+
+(* set an element in an array, without side effects *)
+
+   let myset array int element =
+      let length = Array.length array in
+      let firstpart = Array.sub array 0 (int) in
+      let secondpart = Array.sub array (int+1) (length-(int+1)) in
+      (Array.append firstpart (Array.append [|element|] secondpart))
+
+   let rec compute_open treelist slist =
+      match treelist with
+         [] -> []
+       | first::rest ->
+            let elements =
+               match first with
+                  Empty -> []
+                | NodeAt(pos) ->
+                     if (List.mem (pos.name) slist) then
+                        [pos]
+                     else
+                        []
+                | NodeA(pos,suctrees) ->
+                     if (List.mem (pos.name) slist) then
+                        [pos]
+                     else
+                        compute_open (Array.to_list suctrees) slist
+            in
+            elements @ (compute_open rest slist)
+
+   let rec select_connection pname connections slist =
+      match connections with
+         [] -> ("none","none")
+       | f::r ->
+            let partner =
+               if (fst f) = pname then
+                  (snd f)
+               else
+                  if (snd f) = pname then
+                     (fst f)
+                  else
+                     "none"
+            in
+            if ((partner = "none") or (List.mem partner slist)) then
+               select_connection pname r slist
+            else
+               f
+
+   let rec replace_element element element_set redord =
+      match redord with
+         [] -> raise jprover_bug   (* element occurs in redord *)
+       | (f,fset)::r ->
+            if f = element then
+               (f,element_set)::r
+            else
+               (f,fset)::(replace_element element element_set r)
+
+   let rec collect_succ_sets sucs redord =
+      match redord with
+         [] -> StringSet.empty
+       | (f,fset)::r ->
+            let new_sucs = key_delete f sucs in
+            if (List.length sucs) = (List.length new_sucs) then   (* position with name f did not occur in sucs -- no deletion *)
+               (collect_succ_sets sucs r)
+            else
+               StringSet.union (StringSet.add f fset) (collect_succ_sets new_sucs r)
+
+   let replace_ordering psucc_name sucs redord =
+      let new_psucc_set = collect_succ_sets sucs redord in
+(*   print_string_set new_psucc_set; *)
+      replace_element psucc_name new_psucc_set redord
+
+   let rec update pname redord =
+      match redord with
+         [] -> []
+       | (f,fset)::r ->
+            if pname=f then
+               r
+            else
+               (f,fset)::(update pname r)
+
+(*  rule construction *)
+
+   let rec selectQ_rec spos_var csigmaQ =
+      match csigmaQ  with
+         [] ->  mk_var_term spos_var   (* dynamic completion of csigmaQ *)
+       | (var,term)::r ->
+            if spos_var=var then
+               term
+            else
+               selectQ_rec spos_var r
+
+   let selectQ spos_name csigmaQ =
+      let spos_var = spos_name^"_jprover" in
+      selectQ_rec spos_var csigmaQ
+
+   let apply_sigmaQ term sigmaQ =
+      let sigma_vars,sigma_terms = List.split sigmaQ in
+      (subst term sigma_vars sigma_terms)
+
+   let build_rule pos spos csigmaQ orr_flag calculus =
+      let inst_label = apply_sigmaQ (pos.label) csigmaQ in
+      match pos.op,pos.pol with
+         Null,_ -> raise (Invalid_argument "Jprover: no rule")
+       | At,O -> Ax,(inst_label),xnil_term (* to give back a term *)
+       | At,I -> Ax,(inst_label),xnil_term
+       | And,O -> Andr,(inst_label),xnil_term
+       | And,I -> Andl,(inst_label),xnil_term
+       | Or,O ->
+            if calculus = "LJ" then
+               let or_rule =
+                  if orr_flag = 1 then
+                     Orr1
+                  else
+                     Orr2
+               in
+               or_rule,(inst_label),xnil_term
+            else
+               Orr,(inst_label),xnil_term
+       | Or,I -> Orl,(inst_label),xnil_term
+       | Neg,O -> Negr,(inst_label),xnil_term
+       | Neg,I -> Negl,(inst_label),xnil_term
+       | Imp,O -> Impr,(inst_label),xnil_term
+       | Imp,I -> Impl,(inst_label),xnil_term
+       | All,I -> Alll,(inst_label),(selectQ spos.name csigmaQ)  (* elements of csigmaQ is (string * term) *)
+       | Ex,O -> Exr,(inst_label), (selectQ  spos.name csigmaQ)
+       | All,O -> Allr,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *)
+       | Ex,I -> Exl,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *)
+
+
+(* %%%%%%%%%%%%%%%%%%%% Split begin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
+
+   let rec nonemptys treearray j n =
+      if j = n then
+         0
+      else
+         let count =
+            if (Array.get treearray j) <> Empty then
+               1
+            else
+               0
+         in
+         count + (nonemptys treearray (j+1) n)
+
+   let rec collect_pure ftreelist (flist,slist) =
+
+      let rec collect_itpure ftree (flist,slist) =
+         match ftree with
+            Empty ->  (* assumed that not all brother trees are Empty *)
+               []
+          | NodeAt(pos) -> (* that may NOT longer be an inner node *)
+               if ((List.mem (pos.name) flist) or (List.mem (pos.name) slist)) then
+                  []
+               else
+                  [pos]
+          | NodeA(pos,treearray) ->
+               collect_pure (Array.to_list treearray) (flist,slist)
+      in
+      match ftreelist with
+         [] -> []
+       | f::r ->
+            (collect_itpure f (flist,slist)) @ (collect_pure r (flist,slist))
+
+   let rec update_list testlist list =
+      match testlist with
+         [] -> list
+       | f::r ->
+            let newlist = delete f list in    (* f may not occur in list; then newlist=list *)
+            update_list r newlist
+
+   let rec update_pairlist p pairlist =
+      match pairlist with
+         [] -> []
+       | f::r ->
+            if ((fst f) = p) or ((snd f) = p) then
+               update_pairlist p r
+            else
+               f::(update_pairlist p r)
+
+   let rec update_connections slist connections =
+      match slist with
+         [] -> connections
+       | f::r ->
+            let connew = update_pairlist f connections in
+            update_connections r connew
+
+   let rec update_redord delset redord =   (* delset is the set of positions to be deleted *)
+      match redord with
+         [] -> []
+       | (f,fset)::r ->
+            if (StringSet.mem f delset) then
+               update_redord delset r   (* delete all key elements f from redord which are in delset *)
+            else
+               let new_fset  = StringSet.diff fset delset in  (* no successor of f from delset should remain in fset *)
+               (f,new_fset)::(update_redord delset r)
+
+   let rec get_position_names treelist =
+      match treelist with
+         [] -> []
+       | deltree::rests ->
+            match deltree with
+               Empty -> get_position_names rests
+             | NodeAt(pos) ->
+                  (pos.name)::get_position_names rests
+             | NodeA(pos,strees) ->
+                  (pos.name)::(get_position_names ((Array.to_list strees) @ rests))
+
+   let rec slist_to_set slist =
+      match slist with
+         [] ->
+            StringSet.empty
+       | f::r ->
+            StringSet.add f (slist_to_set r)
+
+   let rec print_purelist pr =
+      match pr with
+         [] ->
+            begin
+               print_string ".";
+               print_endline " ";
+            end
+       | f::r ->
+            print_string ((f.name)^", ");
+            print_purelist r
+
+   let update_relations deltree redord connections unsolved_list =
+      let pure_names = get_position_names [deltree] in
+      begin
+(*        print_ftree deltree;
+   Format.open_box 0;
+   print_endline " ";
+   print_stringlist pure_names;
+   Format.force_newline ();
+   Format.print_flush ();
+*)
+         let rednew = update_redord (slist_to_set pure_names) redord
+         and connew = update_connections pure_names connections
+         and unsolnew = update_list pure_names unsolved_list in
+         (rednew,connew,unsolnew)
+      end
+
+   let rec collect_qpos ftreelist uslist =
+      match ftreelist with
+         [] -> [],[]
+       | ftree::rest ->
+            match ftree with
+               Empty ->
+                  collect_qpos rest uslist
+             | NodeAt(pos) ->
+                  let (rest_delta,rest_gamma) = collect_qpos rest uslist in
+                  if (pos.st = Gamma_0) & (List.mem pos.name uslist) then
+                     rest_delta,(pos.name::rest_gamma)
+                  else
+                     if (pos.st = Delta_0) & (List.mem pos.name uslist) then
+                        (pos.name::rest_delta),rest_gamma
+                     else
+                        rest_delta,rest_gamma
+             | NodeA(pos,suctrees) ->
+                  let (rest_delta,rest_gamma) = collect_qpos ((Array.to_list suctrees) @ rest) uslist in
+                  if (pos.st = Gamma_0) & (List.mem pos.name uslist) then
+                     rest_delta,(pos.name::rest_gamma)
+                  else
+                     if (pos.st = Delta_0) & (List.mem pos.name uslist) then
+                        (pos.name::rest_delta),rest_gamma
+                     else
+                        rest_delta,rest_gamma
+
+   let rec do_split gamma_diff sigmaQ =
+      match sigmaQ with
+         [] -> []
+       | (v,term)::r ->
+            if (List.mem (String.sub v 0 (String.index v '_')) gamma_diff) then
+               do_split gamma_diff r
+            else
+               (v,term)::(do_split gamma_diff r)
+
+(* make a term list out of a bterm list *)
+
+   let rec collect_subterms = function
+      [] -> []
+    | bt::r ->
+         let dbt = dest_bterm bt in
+         (dbt.bterm)::(collect_subterms r)
+
+   (*: Bug! :*)
+(*:   let rec collect_delta_terms = function
+      [] -> []
+    | t::r ->
+         let dt = dest_term t in
+         let top = dt.term_op
+         and tterms = dt.term_terms in
+         let dop = dest_op top in
+         let don = dest_opname dop.op_name in
+         match don with
+            [] ->
+               let sub_terms = collect_subterms tterms in
+               collect_delta_terms (sub_terms @ r)
+          | op1::opr ->
+               if op1 = "jprover" then
+                  match opr with
+                     [] -> raise (Invalid_argument "Jprover: delta position missing")
+                   | delta::_ ->
+                        delta::(collect_delta_terms r)
+               else
+                  let sub_terms = collect_subterms tterms in
+                  collect_delta_terms (sub_terms @ r)
+:*)
+
+  let rec collect_delta_terms = function
+      [] -> []
+    | t::r ->
+         let dt = dest_term t in
+         let top = dt.term_op
+         and tterms = dt.term_terms in
+         let dop = dest_op top in
+         let don = dest_opname dop.op_name in
+         let doa = dest_param dop.op_params in
+         match don with
+            [] ->
+               let sub_terms = collect_subterms tterms in
+               collect_delta_terms (sub_terms @ r)
+          | op1::opr ->
+               if op1 = "jprover" then
+                  match doa with
+                     [] -> raise (Invalid_argument "Jprover: delta position missing")
+                   | String delta::_ ->
+                        delta::(collect_delta_terms r)
+                   | _ ->  raise (Invalid_argument "Jprover: delta position error")
+               else
+                  let sub_terms = collect_subterms tterms in
+                  collect_delta_terms (sub_terms @ r)
+
+
+
+   let rec check_delta_terms (v,term) ass_delta_diff dterms =
+      match ass_delta_diff with
+         [] -> term,[]
+       | (var,dname)::r ->
+            if List.mem dname dterms then
+               let new_var =
+                  if var = "" then
+                     v
+                  else
+                     var
+               in
+               let replace_term = mk_string_term jprover_op dname in
+               let next_term = var_subst term replace_term new_var in
+               let (new_term,next_diffs) = check_delta_terms (v,next_term) r dterms in
+               (new_term,((new_var,dname)::next_diffs))
+            else
+               let (new_term,next_diffs) = check_delta_terms (v,term) r dterms in
+               (new_term,((var,dname)::next_diffs))
+
+
+   let rec localize_sigma zw_sigma ass_delta_diff =
+      match zw_sigma with
+         [] -> []
+       | (v,term)::r ->
+            let dterms = collect_delta_terms [term] in
+            let (new_term,new_ass_delta_diff) = check_delta_terms (v,term) ass_delta_diff dterms in
+            (v,new_term)::(localize_sigma r new_ass_delta_diff)
+
+   let subst_split ft1 ft2 ftree uslist1 uslist2 uslist sigmaQ =
+      let delta,gamma = collect_qpos [ftree] uslist
+      and delta1,gamma1 = collect_qpos [ft1] uslist1
+      and  delta2,gamma2 = collect_qpos [ft2] uslist2 in
+      let delta_diff1 = list_diff delta delta1
+      and delta_diff2 = list_diff delta delta2
+      and gamma_diff1 = list_diff gamma gamma1
+      and gamma_diff2 = list_diff gamma gamma2 in
+      let zw_sigma1 = do_split gamma_diff1 sigmaQ
+      and zw_sigma2 = do_split gamma_diff2 sigmaQ in
+      let ass_delta_diff1 = List.map (fun x -> ("",x)) delta_diff1
+      and ass_delta_diff2 = List.map (fun x -> ("",x)) delta_diff2 in
+      let sigmaQ1 = localize_sigma zw_sigma1 ass_delta_diff1
+      and sigmaQ2 = localize_sigma zw_sigma2 ass_delta_diff2 in
+      (sigmaQ1,sigmaQ2)
+
+   let rec reduce_tree addr actual_node ftree beta_flag =
+      match addr with
+         [] -> (ftree,Empty,actual_node,beta_flag)
+       | a::radd ->
+            match ftree with
+               Empty ->
+                  print_endline "Empty purity tree";
+                  raise jprover_bug
+             | NodeAt(_) ->
+                  print_endline "Atom purity tree";
+                  raise jprover_bug
+             | NodeA(pos,strees) ->
+(*       print_endline pos.name; *)
+    (* the associated node occurs above f (or the empty address) and hence, is neither atom nor empty tree *)
+
+                  let nexttree = (Array.get strees (a-1)) in
+                  if (nonemptys strees 0 (Array.length strees)) < 2  then
+                     begin
+(*          print_endline "strees 1 or non-empties < 2"; *)
+                        let (ft,dt,an,bf) =  reduce_tree radd actual_node nexttree beta_flag in
+                        let nstrees = myset strees (a-1) ft in
+(*            print_endline ("way back "^pos.name); *)
+                        (NodeA(pos,nstrees),dt,an,bf)
+                     end
+                  else  (* nonemptys >= 2 *)
+                     begin
+(*             print_endline "nonempties  >= 2 "; *)
+                        let (new_act,new_bf) =
+                           if pos.pt = Beta then
+                              (actual_node,true)
+                           else
+                              ((pos.name),false)
+                        in
+                        let (ft,dt,an,bf) = reduce_tree radd new_act nexttree new_bf in
+                        if an = pos.name then
+                           let nstrees = myset strees (a-1) Empty in
+(*                 print_endline ("way back assocnode "^pos.name); *)
+                           (NodeA(pos,nstrees),nexttree,an,bf)
+                        else  (* has been replaced / will be replaced below / above pos *)
+                           let nstrees = myset strees (a-1) ft in
+(*                 print_endline ("way back "^pos.name); *)
+                           (NodeA(pos,nstrees),dt,an,bf)
+                     end
+
+   let rec purity ftree redord connections unsolved_list =
+
+      let rec purity_reduction pr ftree redord connections unsolved_list =
+         begin
+(*        Format.open_box 0;
+   print_endline " ";
+   print_purelist pr;
+   Format.force_newline ();
+   Format.print_flush ();
+*)
+            match pr with
+               [] -> (ftree,redord,connections,unsolved_list)
+             | f::r ->
+(*   print_endline ("pure position "^(f.name)); *)
+                  let (ftnew,deltree,assocn,beta_flag) = reduce_tree f.address "" ftree false
+                  in
+(*     print_endline ("assoc node "^assocn); *)
+                  if assocn = "" then
+                     (Empty,[],[],[])  (* should not occur in the final version *)
+                  else
+                     let (rednew,connew,unsolnew) = update_relations deltree redord connections unsolved_list in
+                     begin
+(*        Format.open_box 0;
+   print_endline " ";
+   print_pairlist connew;
+   Format.force_newline ();
+   Format.print_flush ();
+*)
+                        if beta_flag = true then
+                           begin
+(*          print_endline "beta_flag true"; *)
+                              purity ftnew rednew connew unsolnew
+  (* new pure positions may occur; old ones may not longer exist *)
+                           end
+                        else
+                           purity_reduction r ftnew rednew connew unsolnew (* let's finish the old pure positions *)
+                     end
+         end
+
+      in
+      let flist,slist = List.split connections in
+      let pr = collect_pure [ftree] (flist,slist) in
+      purity_reduction pr ftree redord connections unsolved_list
+
+   let rec betasplit addr ftree redord connections unsolved_list =
+      match ftree with
+         Empty  ->
+            print_endline "bsplit Empty tree";
+            raise jprover_bug
+       | NodeAt(_) ->
+            print_endline "bsplit Atom tree";
+            raise jprover_bug   (* the beta-node should actually occur! *)
+       | NodeA(pos,strees) ->
+            match addr with
+               [] ->    (* we are at the beta node under consideration *)
+                  let st1tree = (Array.get strees 0)
+                  and st2tree = (Array.get strees 1) in
+                  let (zw1red,zw1conn,zw1uslist) = update_relations st2tree redord connections unsolved_list
+                  and (zw2red,zw2conn,zw2uslist) = update_relations st1tree redord connections unsolved_list in
+                  ((NodeA(pos,[|st1tree;Empty|])),zw1red,zw1conn,zw1uslist),
+                  ((NodeA(pos,[|Empty;st2tree|])),zw2red,zw2conn,zw2uslist)
+             | f::rest ->
+                  let nexttree  = Array.get strees (f-1) in
+                  let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) =
+                     betasplit rest nexttree redord connections unsolved_list in
+(*          let scopytrees = Array.copy strees in  *)
+                  let zw1trees = myset strees (f-1) zw1ft
+                  and zw2trees = myset strees (f-1) zw2ft in
+                  (NodeA(pos,zw1trees),zw1red,zw1conn,zw1uslist),(NodeA(pos,zw2trees),zw2red,zw2conn,zw2uslist)
+
+
+
+
+   let split addr pname ftree redord connections unsolved_list opt_bproof =
+      let (opt_bp1,min_con1),(opt_bp2,min_con2) = split_permutation pname opt_bproof in
+      begin
+(*
+   print_endline "Beta proof 1: ";
+   print_endline "";
+   print_beta_proof opt_bp1;
+   print_endline "";
+   print_endline ("Beta proof 1 connections: ");
+   Format.open_box 0;
+   print_pairlist min_con1;
+   print_endline ".";
+   Format.print_flush();
+   print_endline "";
+   print_endline "";
+   print_endline "Beta proof 2: ";
+   print_endline "";
+   print_beta_proof opt_bp2;
+   print_endline "";
+   print_endline ("Beta proof 2 connections: ");
+   Format.open_box 0;
+   print_pairlist min_con2;
+   print_endline ".";
+   Format.print_flush();
+   print_endline "";
+*)
+         let  (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) =
+            betasplit addr ftree redord connections unsolved_list in
+(* zw1conn and zw2conn are not longer needed when using beta proofs *)
+(*   print_endline "betasp_out"; *)
+         let ft1,red1,conn1,uslist1 =  purity zw1ft zw1red min_con1 zw1uslist in
+(*   print_endline "purity_one_out"; *)
+         let ft2,red2,conn2,uslist2 =  purity zw2ft zw2red min_con2 zw2uslist in
+(*        print_endline "purity_two_out"; *)
+(* again, min_con1 = conn1 and min_con2 = conn2 should hold *)
+         begin
+(* print_endline "";
+   print_endline "";
+   print_endline ("Purity 1 connections: ");
+   Format.open_box 0;
+   print_pairlist conn1;
+   print_endline ".";
+   print_endline "";
+   Format.print_flush();
+   print_endline "";
+   print_endline "";
+   print_endline ("Purity 2 connections: ");
+   Format.open_box 0;
+   print_pairlist conn2;
+   print_endline ".";
+   print_endline "";
+   Format.print_flush();
+   print_endline "";
+   print_endline "";
+*)
+            (ft1,red1,conn1,uslist1,opt_bp1),(ft2,red2,conn2,uslist2,opt_bp2)
+         end
+      end
+
+
+(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Splitting end %%%%%%%%%%%%%%%%  *)
+
+
+(* for wait labels we collect all solved atoms with pol=0 *)
+
+   let rec collect_solved_O_At ftreelist slist =
+      match ftreelist with
+         [] ->
+            []
+       | f::r ->
+            match f with
+               Empty ->    (* may become possible after purity *)
+                  collect_solved_O_At r slist
+             | NodeAt(pos) ->
+                  if ((List.mem (pos.name) slist) or (pos.pol = I)) then  (* recall slist is the unsolved list *)
+                     collect_solved_O_At r slist
+                  else
+    (* here, we have pos solved and pos.pol = O) *)
+                     pos::(collect_solved_O_At r slist)
+             | NodeA(pos,treearray) ->
+                  collect_solved_O_At ((Array.to_list treearray) @ r) slist
+
+   let rec red_ord_block pname redord =
+      match redord with
+         [] -> false
+       | (f,fset)::r ->
+            if ((f = pname) or (not (StringSet.mem pname fset))) then
+               red_ord_block pname r
+            else
+               true   (* then, we have (StringSet.mem pname fset) *)
+
+   let rec check_wait_succ_LJ faddress ftree =
+      match ftree with
+         Empty -> raise jprover_bug
+       | NodeAt(pos) -> raise jprover_bug (* we have an gamma_0 position or an or-formula *)
+       | NodeA(pos,strees) ->
+            match faddress with
+               [] ->
+                  if pos.op = Or then
+                     match (strees.(0),strees.(1)) with
+                        (Empty,Empty) -> raise (Invalid_argument "Jprover: redundancies occur")
+                      | (Empty,_) -> (false,2)   (* determines the Orr2 rule *)
+                      | (_,Empty) -> (false,1)   (* determines the Orr1 ruke *)
+                      | (_,_)  -> (true,0)    (* wait-label is set *)
+                  else
+                     (false,0)
+             | f::r ->
+                  if r = [] then
+                     if (pos.pt = Gamma) & ((nonemptys strees 0 (Array.length strees)) > 1)  then
+                        (true,0)             (* we are at a gamma position (exr) with one than one successor -- wait label in LJ*)
+                     else
+                        check_wait_succ_LJ r (Array.get strees (f-1))
+                  else
+                     check_wait_succ_LJ r (Array.get strees (f-1))
+
+   let blocked f po redord ftree connections slist logic calculus opt_bproof =
+(* print_endline ("Blocking check "^(f.name)); *)
+      if (red_ord_block (f.name) redord) then
+         begin
+(*     print_endline "wait-1 check positive"; *)
+            true,0
+         end
+      else
+         if logic = "C" then
+            false,0  (* ready, in C only redord counts *)
+         else
+            let pa_O = collect_solved_O_At [ftree] slist      (* solved atoms in ftree *)
+            and po_test = (delete f po) in
+            if calculus = "LJmc" then (* we provide dynamic wait labels for both sequent calculi *)
+(*       print_endline "wait-2 check"; *)
+               if (f.st = Psi_0)  &  (f.pt <> PNull) &
+                  ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) then
+                  begin
+(*          print_endline "wait-2 positive"; *)
+                     true,0 (* wait_2 label *)
+                  end
+               else
+                  begin
+(*            print_endline "wait-2 negative"; *)
+                     false,0
+                  end
+            else  (* calculus is supposed to be LJ *)
+               if calculus = "LJ" then
+                  if  ((f.st = Phi_0)  & ((f.op=Neg) or (f.op=Imp)) &
+                       ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test))
+                      )
+         (* this would cause an impl or negl rule with an non-empty succedent *)
+                  then
+                     if (f.op=Neg) then
+                        true,0
+                     else  (* (f.op=Imp) *)
+              (* In case of an impl rule on A => B, the wait_label must NOT be set
+                 iff all succedent formulae depend exclusively on B. For this, we
+                 perform a split operation and determine, if in the A-subgoal
+                 all succedent formulae are pure, i.e.~have been deleted from treds.
+                 Otherwise, in case of A-dependent succedent formulae, the
+                 wait_label must be set.
+              *)
+                        let ((_,min_con1),_) = split_permutation f.name opt_bproof in
+                        let slist_fake = delete f.name slist in
+                        let  ((zw1ft,zw1red,_,zw1uslist),_) =
+                           betasplit (f.address) ftree redord connections slist_fake in
+                        let ft1,_,_,uslist1 =  purity zw1ft zw1red min_con1 zw1uslist in
+(*                   print_endline "wait label purity_one_out"; *)
+                        let ft1_root = (List.hd (List.tl (tpredsucc f ft1))) in
+(*                 print_endline ("wait-root "^(ft1_root.name)); *)
+                        let po_fake = compute_open [ft1] uslist1 in
+                        let po_fake_test = delete ft1_root po_fake
+                        and pa_O_fake = collect_solved_O_At [ft1] uslist1 in
+(*                  print_purelist (po_fake_test @ pa_O_fake); *)
+                        if ((pa_O_fake <> []) or (List.exists (fun x -> x.pol = O) po_fake_test)) then
+                           true,0
+                        else
+                           false,0
+                  else
+                     if ((f.pol=O) & ((f.st=Gamma_0) or (f.op=Or))) then
+                        let (bool,orr_flag) = check_wait_succ_LJ f.address ftree in
+                        (bool,orr_flag)
+        (* here is determined if orr1 or orr2 will be performed, provided bool=false) *)
+        (* orr_flag can be 1 or 2 *)
+                     else
+                        false,0
+               else
+                  raise (Invalid_argument "Jprover: calculus should be LJmc or LJ")
+
+   let rec get_beta_preference list actual =
+      match list with
+         [] -> actual
+       | (f,int)::r ->
+            if f.op = Imp then
+               (f,int)
+            else
+(*     if f.op = Or then
+   get_beta_preference r (f,int)
+   else
+*)
+               get_beta_preference r actual
+
+   exception Gamma_deadlock
+
+   let rec select_pos search_po po redord ftree connections slist logic calculus candidates
+         opt_bproof =
+      match search_po with
+         [] ->
+            (match candidates with
+               [] ->
+                  if calculus = "LJ" then
+                     raise Gamma_deadlock  (* permutation may be necessary *)
+                  else
+                     raise (Invalid_argument "Jprover bug: overall deadlock") (* this case should not occur *)
+             | c::rest ->
+                  get_beta_preference (c::rest) c
+            )
+       | f::r ->  (* there exist an open position *)
+            let (bool,orr_flag) = (blocked f po redord ftree connections slist logic calculus
+                                      opt_bproof)
+            in
+            if (bool = true) then
+               select_pos r po redord  ftree connections slist logic calculus candidates opt_bproof
+            else
+               if f.pt = Beta then
+     (* search for non-splitting rules first *)
+(*      let beta_candidate =
+   if candidates = []
+   then
+   [(f,orr_flag)]
+   else
+   !!!!  but preserve first found candidate !!!!!!!
+   candidates
+   in
+   !!!!!!! this strategy is not sure the best -- back to old !!!!!!!!!
+*)
+                  select_pos r po redord  ftree connections slist logic calculus
+                     ((f,orr_flag)::candidates) opt_bproof
+               else
+                  (f,orr_flag)
+
+(* let rec get_position_in_tree pname treelist =
+      match treelist with
+         [] -> raise jprover_bug
+       | f::r ->
+            begin match f with
+               Empty -> get_position_in_tree pname r
+             | NodeAt(pos) ->
+                  if pos.name = pname then
+                     pos
+                  else
+                     get_position_in_tree pname r
+             | NodeA(pos,suctrees) ->
+                  get_position_in_tree pname ((Array.to_list suctrees) @ r)
+            end
+*)
+
+(* total corresponds to tot in the thesis,
+   tot simulates the while-loop, solve is the rest *)
+
+   let rec total  ftree redord connections csigmaQ slist logic calculus opt_bproof =
+      let rec tot  ftree redord connections po slist =
+         let rec solve  ftree redord connections p po slist (pred,succs) orr_flag =
+            let newslist = delete (p.name) slist in
+            let rback =
+               if p.st = Gamma_0 then
+                  begin
+(*          print_endline "that's the gamma rule";  *)
+                     [((p.name,pred.name),(build_rule pred p csigmaQ orr_flag calculus))]
+                  end
+               else
+                  []
+            in
+(*        print_endline "gamma check finish";  *)
+            let pnew =
+               if p.pt <> Beta then
+                  succs @ (delete  p po)
+               else
+                  po
+            in
+            match p.pt with
+               Gamma ->
+                  rback @ (tot  ftree redord connections pnew newslist)
+             | Psi   ->
+                  if p.op = At then
+                     let succ = List.hd succs in
+                     rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag)  (* solve atoms immediately *)
+                  else
+                     rback @ (tot  ftree redord connections pnew newslist)
+             | Phi   ->
+                  if p.op = At then
+                     let succ = List.hd succs in
+                     rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag)  (* solve atoms immediately *)
+                  else
+                     rback @ (tot  ftree redord connections pnew newslist)
+             | PNull ->
+                  let new_redord = update p.name redord in
+                  let (c1,c2) = select_connection (p.name) connections newslist in
+                  if (c1= "none" & c2 ="none") then
+                     rback @ (tot  ftree new_redord connections pnew newslist)
+                  else
+                     let (ass_pos,inst_pos) =
+(* need the pol=O position ass_pos of the connection for later permutation *)
+(* need the pol=I position inst_pos for NuPRL instantiation *)
+                        if p.name = c1 then
+                           if p.pol = O then
+                              (c1,c2)
+                           else
+                              (c2,c1)
+                        else (* p.name = c2 *)
+                           if p.pol = O then
+                              (c2,c1)
+                           else
+                              (c1,c2)
+                     in
+                     rback @ [(("",ass_pos),(build_rule p p csigmaQ orr_flag calculus))]
+   (* one possibility of recursion end *)
+             | Alpha ->
+                  rback @ ((("",p.name),(build_rule p p csigmaQ orr_flag calculus))::(tot  ftree redord connections pnew newslist))
+             | Delta ->
+                  let sp = List.hd succs in
+                  rback @ ((("",p.name),(build_rule p sp csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist))
+             | Beta  ->
+(*             print_endline "split_in"; *)
+                  let (ft1,red1,conn1,uslist1,opt_bproof1),(ft2,red2,conn2,uslist2,opt_bproof2) =
+                     split (p.address) (p.name) ftree redord connections newslist opt_bproof in
+                  let (sigmaQ1,sigmaQ2) = subst_split ft1 ft2 ftree uslist1 uslist2 newslist csigmaQ in
+(*           print_endline "split_out"; *)
+                  let p1 = total  ft1 red1 conn1 sigmaQ1 uslist1 logic calculus opt_bproof1 in
+(*           print_endline "compute p1 out";              *)
+                  let p2 = total  ft2 red2 conn2 sigmaQ2 uslist2 logic calculus opt_bproof2 in
+(*           print_endline "compute p2 out";              *)
+                  rback @ [(("",p.name),(build_rule p p csigmaQ orr_flag calculus))] @ p1 @ p2  (* second possibility of recursion end *)
+         in
+         begin try
+            let (p,orr_flag) = select_pos po po redord ftree connections slist logic
+                  calculus [] opt_bproof
+    (* last argument for guiding selection strategy *)
+            in
+(*    print_endline ((p.name)^" "^(string_of_int orr_flag)); *)
+            let predsuccs = tpredsucc p ftree in
+            let pred = List.hd predsuccs
+            and succs = List.tl predsuccs in
+            let redpo = update (p.name) redord in   (* deletes the entry (p,psuccset) from the redord *)
+            let rednew =
+               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
+                  replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *)
+               else
+                  redpo
+            in
+(*      print_endline "update ok"; *)
+            solve ftree rednew connections p po slist (pred,succs) orr_flag
+         with Gamma_deadlock ->
+            let ljmc_subproof =  total ftree redord connections csigmaQ slist "J" "LJmc" opt_bproof
+            in
+            eigen_counter := 1;
+            permute_ljmc ftree po slist ljmc_subproof
+           (* the permuaiton result will be appended to the lj proof constructed so far *)
+         end
+      in
+      let po  = compute_open [ftree] slist in
+      tot ftree redord connections po slist
+
+   let reconstruct ftree redord sigmaQ ext_proof logic calculus =
+      let min_connections = remove_dups_connections ext_proof in
+      let (opt_bproof,beta_exp,closures) = construct_opt_beta_proof ftree ext_proof in
+(* let connections = remove_dups_connections ext_proof in
+   let bproof,beta_exp,closures = construct_beta_proof ftree connections in
+   let (opt_bproof,min_connections) = bproof_purity bproof in
+*)
+      if !debug_jprover then
+         begin
+            print_endline "";
+            print_endline ("Beta proof with number of closures = "^(string_of_int closures)^" and number of beta expansions = "^(string_of_int beta_exp));
+(*   print_endline "";
+   print_endline "";
+   print_beta_proof bproof;
+   print_endline "";
+   print_endline "";
+   print_endline "Optimal beta proof: ";
+   print_endline "";
+   print_endline "";
+   print_beta_proof opt_bproof;
+   print_endline "";
+   print_endline "";
+   print_endline ("Beta proof connections: ");
+   Format.open_box 0;
+   print_pairlist min_connections;
+   print_endline ".";
+   Format.print_flush(); *)
+            print_endline "";
+         end;
+      let  (newroot_name,unsolved_list) =  build_unsolved ftree in
+      let redord2 = (update newroot_name redord) in   (* otherwise we would have a deadlock *)
+      let (init_tree,init_redord,init_connections,init_unsolved_list) =
+         purity ftree redord2 min_connections unsolved_list in
+      begin
+(*   print_endline "";
+   print_endline "";
+   print_endline ("Purity connections: ");
+   Format.open_box 0;
+   print_pairlist init_connections;
+   print_endline ".";
+   print_endline "";
+   Format.print_flush();
+   print_endline "";
+   print_endline "";
+*)
+(* it should hold: min_connections = init_connections *)
+         total init_tree init_redord init_connections sigmaQ
+            init_unsolved_list logic calculus opt_bproof
+      end
+
+(* ***************** REDUCTION ORDERING -- both types **************************** *)
+
+   exception Reflexive
+
+   let rec transitive_irreflexive_closure addset const ordering =
+      match ordering with
+         [] ->
+            []
+       | (pos,fset)::r ->
+            if (pos = const) or (StringSet.mem const fset) then
+(* check reflexsivity during transitive closure wrt. addset ONLY!!! *)
+               if StringSet.mem pos addset then
+                  raise Reflexive
+               else
+                  (pos,(StringSet.union fset addset))::(transitive_irreflexive_closure addset const r)
+            else
+               (pos,fset)::(transitive_irreflexive_closure addset const r)
+
+   let rec search_set var ordering =
+(* print_endline var; *)
+      match ordering with
+         [] ->
+            raise (Invalid_argument "Jprover: element in ordering missing")
+       | (pos,fset)::r ->
+            if pos = var then
+               StringSet.add pos fset
+            else
+               search_set var r
+
+   let add_sets var const ordering =
+      let addset =  search_set var ordering  in
+      transitive_irreflexive_closure addset const ordering
+
+(* ************* J ordering ********************************************** *)
+
+   let rec add_arrowsJ (v,vlist) ordering =
+      match vlist with
+         [] -> ordering
+       | f::r ->
+            if ((String.get f 0)='c') then
+               let new_ordering = add_sets v f ordering in
+               add_arrowsJ (v,r) new_ordering
+            else
+               add_arrowsJ (v,r) ordering
+
+   let rec add_substJ replace_vars replace_string ordering atom_rel =
+      match replace_vars with
+         [] -> ordering
+       | v::r ->
+            if (String.get v 1 = 'n') (* don't integrate new variables *)
+                  or (List.exists (fun (x,_,_) -> (x.aname = v)) atom_rel) then   (* no reduction ordering at atoms *)
+               (add_substJ r replace_string ordering atom_rel)
+            else
+               let next_ordering = add_arrowsJ (v,replace_string) ordering in
+               (add_substJ r replace_string next_ordering atom_rel)
+
+   let build_orderingJ replace_vars replace_string ordering atom_rel =
+      try
+         add_substJ replace_vars replace_string ordering atom_rel
+      with Reflexive ->        (* only possible in the FO case *)
+         raise Not_unifiable    (*search for alternative string unifiers *)
+
+   let rec build_orderingJ_list substJ ordering atom_rel =
+      match substJ with
+         [] -> ordering
+       | (v,vlist)::r ->
+            let next_ordering = build_orderingJ [v] vlist ordering atom_rel in
+            build_orderingJ_list r next_ordering atom_rel
+
+(* ************* J ordering  END ********************************************** *)
+
+(* ************* quantifier ordering ********************************************** *)
+
+   let rec add_arrowsQ v clist ordering =
+      match clist with
+         [] -> ordering
+       | f::r ->
+            let new_ordering = add_sets v f ordering in
+            add_arrowsQ v r new_ordering
+
+   let rec print_sigmaQ sigmaQ =
+      match sigmaQ with
+         [] ->
+            print_endline "."
+       | (v,term)::r ->
+            begin
+               Format.open_box 0;
+               print_endline " ";
+               print_string (v^" = ");
+               print_term stdout term;
+               Format.force_newline ();
+               Format.print_flush ();
+               print_sigmaQ r
+            end
+
+   let rec print_term_list tlist =
+      match tlist with
+         [] -> print_string "."
+       | t::r ->
+            begin
+               print_term stdout t;
+               print_string "   ";
+               print_term_list r
+            end
+
+   let rec add_sigmaQ new_elements ordering  =
+      match new_elements with
+         [] -> ([],ordering)
+       | (v,termlist)::r ->
+            let dterms = collect_delta_terms termlist in
+            begin
+(*:               print_stringlist dterms;
+               mbreak "add_sigmaQ:1\n";
+               Format.open_box 0;
+               print_endline " ";
+               print_endline "sigmaQ: ";
+               print_string (v^" = ");
+               print_term_list termlist;
+               Format.force_newline ();
+               print_stringlist dterms;
+               Format.force_newline ();
+               Format.print_flush ();
+               mbreak "add_sigmaQ:2\n";
+:*)
+               let new_ordering = add_arrowsQ  v dterms ordering in
+(*:               print_ordering new_ordering;
+               mbreak "add_sigmaQ:3\n";
+:*)
+               let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in
+                   ((v,dterms)::rest_pairs),rest_ordering
+            end
+
+   let build_orderingQ new_elements ordering =
+(* new_elements is of type (string * term list) list, since one variable can receive more than *)
+(* a single term due to substitution multiplication *)
+      try
+(*   print_endline "build orderingQ in"; *)  (* apple *)
+         add_sigmaQ new_elements ordering;
+      with Reflexive ->
+         raise Failed                (* new connection, please *)
+
+
+(* ************* quantifier ordering  END ********************************************** *)
+
+(* ****** Quantifier unification ************** *)
+
+(* For multiplication we assume always idempotent substitutions sigma, tau! *)
+
+   let rec collect_assoc inst_vars tauQ  =
+      match inst_vars with
+         [] -> []
+       | f::r ->
+            let f_term = List.assoc f tauQ in
+            f_term::(collect_assoc r tauQ)
+
+   let rec rec_apply sigmaQ tauQ tau_vars tau_terms =
+      match sigmaQ with
+         [] -> [],[]
+       | (v,term)::r ->
+            let app_term = subst term tau_vars tau_terms in
+            let old_free = free_vars_list term
+            and new_free = free_vars_list app_term  in
+            let inst_vars = list_diff old_free new_free in
+            let inst_terms = collect_assoc inst_vars tauQ in
+            let (rest_sigma,rest_sigma_ordering) = rec_apply r tauQ tau_vars tau_terms in
+            if inst_terms  = [] then
+               ((v,app_term)::rest_sigma),rest_sigma_ordering
+            else
+               let ordering_v = String.sub v 0 (String.index v '_') in
+               ((v,app_term)::rest_sigma),((ordering_v,inst_terms)::rest_sigma_ordering)
+
+(* let multiply sigmaQ tauQ =
+   let tau_vars,tau_terms = List.split tauQ
+   and sigma_vars,sigma_terms = List.split sigmaQ in
+   let apply_terms  = rec_apply sigma_terms tau_vars tau_terms in
+   (List.combine sigma_vars apply_terms) @ tauQ
+*)
+
+   let multiply sigmaQ tauQ =
+      let (tau_vars,tau_terms) = List.split tauQ in
+      let (new_sigmaQ,sigma_ordering)  = rec_apply sigmaQ tauQ tau_vars tau_terms in
+      let tau_ordering_terms = (List.map (fun x -> [x]) tau_terms) (* for extending ordering_elements *) in
+      let tau_ordering_vars = (List.map (fun x -> String.sub x 0 (String.index x '_')) tau_vars) in
+      let tau_ordering  = (List.combine tau_ordering_vars tau_ordering_terms) in
+      ((new_sigmaQ @ tauQ),
+       (sigma_ordering @ tau_ordering)
+      )
+
+   let apply_2_sigmaQ term1 term2 sigmaQ =
+      let sigma_vars,sigma_terms = List.split sigmaQ in
+      (subst term1 sigma_vars sigma_terms),(subst term2 sigma_vars sigma_terms)
+
+   let jqunify term1 term2 sigmaQ =
+      let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in
+      try
+(*:         let tauQ = unify_mm app_term1 app_term2 String_set.StringSet.empty in :*)
+         let tauQ = unify_mm app_term1 app_term2 StringSet.empty in
+         let (mult,oel) = multiply sigmaQ tauQ in
+         (mult,oel)
+      with
+         RefineError _  ->  (* any unification failure *)
+(*    print_endline "fo-unification fail"; *)
+            raise Failed   (* new connection, please *)
+
+(* ************ T-STRING UNIFICATION ******************************** *)
+
+   let rec combine subst (ov,oslist)  =
+      match subst with
+         [] -> [],[]
+       | f::r ->
+            let (v,slist) = f in
+            let rest_vlist,rest_combine = (combine r (ov,oslist)) in
+            if (List.mem ov slist) then  (* subst assumed to be idemponent *)
+               let com_element = com_subst slist (ov,oslist) in
+               (v::rest_vlist),((v,com_element)::rest_combine)
+            else
+               (rest_vlist,(f::rest_combine))
+
+   let compose sigma one_subst =
+      let (n,subst)=sigma
+      and (ov,oslist) = one_subst in
+      let (trans_vars,com) = combine subst (ov,oslist)
+      in
+(*    begin
+   print_endline "!!!!!!!!!test print!!!!!!!!!!";
+   print_subst [one_subst];
+   print_subst subst;
+   print_endline "!!!!!!!!! END test print!!!!!!!!!!";
+*)
+      if List.mem one_subst subst then
+         (trans_vars,(n,com))
+      else
+(* ov may multiply as variable in subst with DIFFERENT values *)
+(* in order to avoid explicit atom instances!!! *)
+         (trans_vars,(n,(com @ [one_subst])))
+(*   end *)
+
+   let rec apply_element fs ft (v,slist) =
+      match (fs,ft) with
+         ([],[]) ->
+            ([],[])
+       | ([],(ft_first::ft_rest)) ->
+            let new_ft_first =
+               if ft_first = v then
+                  slist
+               else
+                  [ft_first]
+            in
+            let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in
+            (emptylist,(new_ft_first @ new_ft_rest))
+       | ((fs_first::fs_rest),[]) ->
+            let new_fs_first =
+               if fs_first = v then
+                  slist
+               else
+                  [fs_first]
+            in
+            let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in
+            ((new_fs_first @ new_fs_rest),emptylist)
+       | ((fs_first::fs_rest),(ft_first::ft_rest)) ->
+            let new_fs_first =
+               if fs_first = v then
+                  slist
+               else
+                  [fs_first]
+            and new_ft_first =
+               if ft_first = v then
+                  slist
+               else
+                  [ft_first]
+            in
+            let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in
+            ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest))
+
+   let rec shorten us ut =
+      match (us,ut) with
+         ([],_) -> (us,ut)
+       | (_,[])  -> (us,ut)
+       | ((fs::rs),(ft::rt)) ->
+            if fs = ft then
+               shorten rs rt
+            else
+               (us,ut)
+
+   let rec apply_subst_list eq_rest (v,slist) =
+
+      match eq_rest with
+         [] ->
+            (true,[])
+       | (atomnames,(fs,ft))::r ->
+            let (n_fs,n_ft) = apply_element fs ft (v,slist) in
+            let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *)
+            match (new_fs,new_ft) with
+               [],[] ->
+                  let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                  (bool,((atomnames,([],[]))::new_eq_rest))
+             | [],(fft::rft) ->
+                  if (is_const fft) then
+                     (false,[])
+                  else
+                     let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                     (bool,((atomnames,([],new_ft))::new_eq_rest))
+             | (ffs::rfs),[] ->
+                  if (is_const ffs) then
+                     (false,[])
+                  else
+                     let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                     (bool,((atomnames,(new_fs,[]))::new_eq_rest))
+             | (ffs::rfs),(fft::rft) ->
+                  if (is_const ffs) & (is_const fft) then
+                     (false,[])
+        (* different first constants cause local fail *)
+                  else
+        (* at least one of firsts is a variable *)
+                     let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                     (bool,((atomnames,(new_fs,new_ft))::new_eq_rest))
+
+   let apply_subst eq_rest (v,slist) atomnames =
+      if (List.mem v atomnames) then (* don't apply subst to atom variables !! *)
+         (true,eq_rest)
+      else
+         apply_subst_list eq_rest (v,slist)
+
+   let all_variable_check eqlist = false   (* needs some discussion with Jens! -- NOT done *)
+
+(*
+   let rec all_variable_check eqlist =
+   match eqlist with
+   [] -> true
+   | ((_,(fs,ft))::rest_eq) ->
+   if (fs <> []) & (ft <> []) then
+   let fs_first = List.hd fs
+   and ft_first = List.hd ft
+   in
+   if (is_const fs_first) or (is_const ft_first) then
+   false
+   else
+   all_variable_check rest_eq
+   else
+   false
+*)
+
+   let rec  tunify_list eqlist init_sigma orderingQ atom_rel =
+
+      let rec tunify atomnames fs ft rt rest_eq sigma ordering =
+
+         let apply_r1 fs ft rt rest_eq sigma =
+(* print_endline "r1"; *)
+            tunify_list rest_eq sigma ordering atom_rel
+
+         in
+         let apply_r2 fs ft rt rest_eq sigma =
+(* print_endline "r2"; *)
+            tunify atomnames rt fs ft rest_eq sigma ordering
+
+         in
+         let apply_r3 fs ft rt rest_eq sigma =
+(* print_endline "r3"; *)
+            let rfs =  (List.tl fs)
+            and rft =  (List.tl rt) in
+            tunify atomnames rfs ft rft rest_eq sigma ordering
+
+         in
+         let apply_r4 fs ft rt rest_eq sigma =
+(* print_endline "r4"; *)
+            tunify atomnames rt ft fs rest_eq sigma ordering
+
+         in
+         let apply_r5 fs ft rt rest_eq sigma =
+(* print_endline "r5"; *)
+            let v = (List.hd fs) in
+            let (compose_vars,new_sigma) = compose sigma (v,ft) in
+            let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in
+            if (bool=false) then
+               raise Not_unifiable
+            else
+               let new_ordering = build_orderingJ (v::compose_vars) ft ordering atom_rel in
+               tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma new_ordering
+
+         in
+         let apply_r6 fs ft rt rest_eq sigma =
+(* print_endline "r6"; *)
+            let v = (List.hd fs) in
+            let (_,new_sigma) = (compose sigma (v,[])) in
+            let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in
+            if (bool=false) then
+               raise Not_unifiable
+            else
+     (* no relation update since [] has been replaced for v *)
+               tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma ordering
+
+         in
+         let apply_r7 fs ft rt rest_eq sigma =
+(* print_endline "r7"; *)
+            let v = (List.hd fs)
+            and c1 = (List.hd rt)
+            and c2t =(List.tl rt) in
+            let (compose_vars,new_sigma) = (compose sigma (v,(ft @ [c1]))) in
+            let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in
+            if bool=false then
+               raise Not_unifiable
+            else
+               let new_ordering = build_orderingJ (v::compose_vars) (ft @ [c1]) ordering atom_rel in
+               tunify atomnames (List.tl fs) []  c2t new_rest_eq new_sigma new_ordering
+
+
+         in
+         let apply_r8 fs ft rt rest_eq sigma =
+(* print_endline "r8"; *)
+            tunify atomnames  rt [(List.hd fs)] (List.tl fs) rest_eq sigma ordering
+
+         in
+         let apply_r9 fs ft rt rest_eq sigma =
+(* print_endline "r9"; *)
+            let v = (List.hd fs)
+            and (max,subst) = sigma in
+            let v_new = ("vnew"^(string_of_int max)) in
+            let (compose_vars,new_sigma) = (compose ((max+1),subst) (v,(ft @ [v_new]))) in
+            let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in
+            if (bool=false) then
+               raise Not_unifiable
+            else
+               let new_ordering =
+                  build_orderingJ (v::compose_vars) (ft @ [v_new]) ordering atom_rel in
+                 tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma new_ordering
+
+         in
+         let apply_r10 fs ft rt rest_eq sigma =
+(* print_endline "r10"; *)
+            let x = List.hd rt in
+            tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma ordering
+
+         in
+         if r_1 fs ft rt then
+            apply_r1 fs ft rt rest_eq sigma
+         else if r_2 fs ft rt then
+            apply_r2 fs ft rt rest_eq sigma
+         else if r_3 fs ft rt then
+            apply_r3 fs ft rt rest_eq sigma
+         else if r_4 fs ft rt then
+            apply_r4 fs ft rt rest_eq sigma
+         else if r_5 fs ft rt then
+            apply_r5 fs ft rt rest_eq sigma
+         else if r_6 fs ft rt then
+            (try
+               apply_r6 fs ft rt rest_eq sigma
+            with Not_unifiable ->
+               if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *)
+                  (try
+                     apply_r7 fs ft rt rest_eq sigma
+                  with Not_unifiable ->
+                     apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *)
+                  )
+               else
+(* r10 could be represented only once if we would try it before r7.*)
+(* but looking at the transformation rules, r10 should be tried at last in any case *)
+                  apply_r10 fs ft rt rest_eq sigma  (* r10 always applicable r6 was *)
+            )
+         else if r_7 fs ft rt then  (* not r6 and r7 possible if z <> [] *)
+            (try
+               apply_r7 fs ft rt rest_eq sigma
+            with Not_unifiable ->
+               apply_r10 fs ft rt rest_eq sigma  (* r10 always applicable if r7 was *)
+            )
+         else if r_8 fs ft rt then
+            (try
+               apply_r8 fs ft rt rest_eq sigma
+            with Not_unifiable ->
+               if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *)
+                  apply_r10 fs ft rt rest_eq sigma
+               else
+                  raise Not_unifiable (* simply back propagation *)
+            )
+         else if r_9 fs ft rt then
+            (try
+               apply_r9 fs ft rt rest_eq sigma
+            with Not_unifiable ->
+               if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *)
+                  apply_r10 fs ft rt rest_eq sigma
+               else
+                  raise Not_unifiable (* simply back propagation *)
+            )
+
+
+         else
+            if r_10 fs ft rt then  (* not ri, i<10, and r10 possible if for instance *)
+                         (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *)
+               apply_r10 fs ft rt rest_eq sigma
+            else  (* NO rule applicable *)
+               raise Not_unifiable
+      in
+      match eqlist with
+         [] ->
+            init_sigma,orderingQ
+       | f::rest_eq ->
+            begin
+(*  Format.open_box 0;
+   print_equations [f];
+   Format.print_flush ();
+*)
+               let (atomnames,(fs,ft)) = f in
+               tunify atomnames fs [] ft rest_eq init_sigma orderingQ
+            end
+
+let rec test_apply_eq atomnames eqs eqt subst =
+   match subst with
+      [] -> (eqs,eqt)
+    | (f,flist)::r ->
+         let (first_appl_eqs,first_appl_eqt) =
+            if List.mem f atomnames then
+               (eqs,eqt)
+            else
+               (apply_element eqs eqt (f,flist))
+         in
+         test_apply_eq atomnames first_appl_eqs first_appl_eqt r
+
+let rec test_apply_eqsubst eqlist subst =
+   match eqlist with
+      [] -> []
+    | f::r ->
+         let (atomnames,(eqs,eqt)) = f in
+         let applied_element  = test_apply_eq atomnames eqs eqt subst in
+         (atomnames,applied_element)::(test_apply_eqsubst r subst)
+
+let ttest us ut ns nt eqlist orderingQ atom_rel =
+   let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *)
+                                           (* to eliminate common beginning *)
+   let new_element = ([ns;nt],(short_us,short_ut)) in
+   let full_eqlist =
+      if List.mem new_element eqlist then
+         eqlist
+      else
+         new_element::eqlist
+   in
+   let (sigma,_) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in
+   let (n,subst) = sigma in
+   let test_apply  = test_apply_eqsubst full_eqlist subst in
+   begin
+      print_endline "";
+      print_endline "Final equations:";
+      print_equations full_eqlist;
+      print_endline "";
+      print_endline "Final substitution:";
+      print_tunify sigma;
+      print_endline "";
+      print_endline "Applied equations:";
+      print_equations test_apply
+   end
+
+let do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel qmax =
+   let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *)
+   let new_element = ([ns;nt],(short_us,short_ut)) in
+   let full_eqlist =
+      if List.mem new_element equations then
+         equations @ fo_eqlist
+      else
+         (new_element::equations) @ fo_eqlist
+   in
+   try
+(*  print_equations full_eqlist; *)
+(* max-1 new variables have been used for the domain equations *)
+      let (new_sigma,new_ordering) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in
+(* sigmaQ will not be returned in eqlist *)
+      (new_sigma,(qmax,full_eqlist),new_ordering)
+   with Not_unifiable ->
+      raise Failed            (* new connection please *)
+
+let rec one_equation gprefix dlist delta_0_prefixes n =
+   match dlist with
+      [] -> ([],n)
+    | f::r ->
+         let fprefix = List.assoc f delta_0_prefixes  in
+         let (sf1,sg) = shorten fprefix gprefix
+         and v_new = ("vnewq"^(string_of_int n)) in
+         let fnew = sf1 @ [v_new] in
+         let (rest_equations,new_n) = one_equation gprefix r delta_0_prefixes (n+1) in
+         (([],(fnew,sg))::rest_equations),new_n
+
+let rec make_domain_equations fo_pairs (gamma_0_prefixes,delta_0_prefixes) n =
+   match fo_pairs with
+      [] -> ([],n)
+    | (g,dlist)::r ->
+         let gprefix = List.assoc g gamma_0_prefixes in
+         let (gequations,max) = one_equation gprefix dlist delta_0_prefixes n in
+         let (rest_equations,new_max) =
+            make_domain_equations r (gamma_0_prefixes,delta_0_prefixes) max in
+         (gequations @ rest_equations),new_max
+
+(* type of one unifier: int * ((string * string list) list)  *)
+(* global failure: (0,[]) *)
+
+let stringunify ext_atom try_one eqlist fo_pairs logic orderingQ atom_rel qprefixes =
+   if logic = "C" then
+      ((0,[]),(0,[]),orderingQ)
+   else
+      let (qmax,equations) = eqlist
+      and us  = ext_atom.aprefix
+      and ut  = try_one.aprefix
+      and ns = ext_atom.aname
+      and nt = try_one.aname in
+      if qprefixes = ([],[]) then  (* prop case *)
+         begin
+(*     print_endline "This is the prop case"; *)
+            let (new_sigma,new_eqlist)  = Jtunify.do_stringunify us ut ns nt equations
+       (* prop unification only *)
+            in
+            (new_sigma,new_eqlist,[]) (* assume the empty reduction ordering during proof search *)
+         end
+      else
+         begin
+(*     print_endline "This is the FO case"; *)
+(* fo_eqlist encodes the domain condition on J quantifier substitutions *)
+(* Again, always computed for the whole substitution sigmaQ *)
+            let (fo_eqlist,new_max) = make_domain_equations fo_pairs qprefixes qmax in
+            begin
+(*    Format.open_box 0;
+   print_string "domain equations in";
+   print_equations fo_eqlist;
+   print_string "domain equations out";
+   Format.print_flush ();
+*)
+               do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel new_max
+            end
+         end
+
+(**************************************** add multiplicity *********************************)
+
+let rec subst_replace subst_list t =
+   match subst_list with
+      [] -> t
+    | (old_t,new_t)::r ->
+         let inter_term = var_subst t  old_t "dummy"  in
+(*:         print_string "(";
+         print_term stdout old_t;
+         print_string " --> ";
+         print_term stdout new_t;
+         print_string ")\n";
+         print_term stdout t;
+         print_newline ();
+         print_term stdout inter_term;
+         print_newline ();     :*)
+         let new_term = subst1 inter_term "dummy" new_t in
+(*:         print_term stdout new_term;
+         print_newline ();
+         mbreak "\n+++========-----    ---------..........\n";  :*)
+         subst_replace r new_term
+
+let rename_pos x m =
+   let pref = String.get x 0 in
+   (Char.escaped pref)^(string_of_int m)
+
+let update_position position m replace_n subst_list mult =
+   let ({name=x; address=y; op=z; pol=p; pt=a; st=b; label=t}) = position in
+   let nx = rename_pos x m in
+   let nsubst_list =
+      if b=Gamma_0 then
+         let vx = mk_var_term (x^"_jprover")
+         and vnx = mk_var_term (nx^"_jprover") in
+            (vx,vnx)::subst_list
+      else
+         if b=Delta_0 then
+            let sx = mk_string_term jprover_op x
+            and snx = mk_string_term jprover_op nx in
+            (sx,snx)::subst_list
+         else
+            subst_list
+   in
+   let nt = subst_replace nsubst_list t in
+   let add_array = Array.of_list y in
+   let _ = (add_array.(replace_n) <- mult) in
+   let new_add = Array.to_list add_array in
+   ({name=nx; address=new_add; op=z; pol=p; pt=a; st=b; label=nt},m,nsubst_list)
+
+let rec append_orderings list_of_lists =
+   match list_of_lists with
+      [] ->
+         []
+    | f::r ->
+         f @ (append_orderings r)
+
+let rec union_orderings first_orderings =
+   match first_orderings with
+      [] ->
+         StringSet.empty
+    | (pos,fset)::r ->
+         StringSet.union (StringSet.add pos fset) (union_orderings r)
+
+let rec select_orderings add_orderings =
+   match add_orderings with
+      [] -> []
+    | f::r ->
+         (List.hd f)::select_orderings r
+
+let combine_ordering_list add_orderings pos_name =
+   let first_orderings = select_orderings add_orderings in
+   let pos_succs = union_orderings first_orderings in
+   let rest_orderings  = append_orderings add_orderings in
+   (pos_name,pos_succs)::rest_orderings
+
+let rec copy_and_rename_tree last_tree replace_n pos_n mult subst_list =
+
+   let rec rename_subtrees tree_list nposition s_pos_n nsubst_list =
+      match tree_list with
+         [] -> ([||],[],s_pos_n)
+       | f::r ->
+            let (f_subtree,f_ordering,f_pos_n) =
+               copy_and_rename_tree f replace_n s_pos_n  mult nsubst_list in
+            let (r_subtrees,r_ordering_list,r_pos_n) = rename_subtrees r nposition f_pos_n nsubst_list in
+            ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n)
+
+   in
+   match last_tree with
+      Empty -> raise (Invalid_argument "Jprover: copy tree")
+    | NodeAt(position) ->   (* can never be a Gamma_0 position -> no replacements *)
+         let (nposition,npos_n,_) = update_position position (pos_n+1) replace_n subst_list mult in
+         ((NodeAt(nposition)),[(nposition.name,StringSet.empty)],npos_n)
+    | NodeA(position, suctrees) ->
+         let (nposition,npos_n,nsubst_list) = update_position position (pos_n+1) replace_n subst_list mult in
+         let (new_suctrees, new_ordering_list, new_pos_n) =
+            rename_subtrees (Array.to_list suctrees) nposition npos_n nsubst_list in
+         let new_ordering = combine_ordering_list new_ordering_list (nposition.name) in
+         ((NodeA(nposition,new_suctrees)),new_ordering,new_pos_n)
+
+(* we construct for each pos a list orderings representing and correspondning to the array of succtrees *)
+
+let rec add_multiplicity ftree pos_n  mult logic =
+   let rec parse_subtrees tree_list s_pos_n =
+      match tree_list with
+         [] -> ([||],[],s_pos_n)
+       | f::r ->
+            let (f_subtree,f_ordering,f_pos_n) = add_multiplicity f s_pos_n  mult logic in
+            let (r_subtrees,r_ordering_list,r_pos_n) = parse_subtrees r f_pos_n in
+            ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n)
+
+   in
+   match ftree with
+      Empty -> raise (Invalid_argument "Jprover: add mult")
+    | NodeAt(pos) -> (ftree,[(pos.name,StringSet.empty)],pos_n)
+    | NodeA(pos,suctrees) ->
+         let (new_suctrees, new_ordering_list, new_pos_n) = parse_subtrees (Array.to_list suctrees) pos_n in
+         if (((pos.pt = Phi) & (((pos.op <> At) & (logic="J")) or ((pos.op = All) & (logic = "C"))))
+          (* no explicit atom-instances *)
+                or ((pos.pt = Gamma) & (pos.st <> Phi_0))) then   (* universal quantifiers are copied *)
+                                                                (* at their Phi positions *)
+            let replace_n = (List.length pos.address)  (* points to the following argument in the array_of_address *)
+            and last = (Array.length new_suctrees) - 1 in (* array first element has index 0 *)
+            let last_tree = new_suctrees.(last) in
+            let (add_tree,add_ordering,final_pos_n) =
+               copy_and_rename_tree last_tree replace_n new_pos_n mult [] in
+            let final_suctrees = Array.append new_suctrees [|add_tree|]
+            and add_orderings = List.append new_ordering_list [add_ordering] in
+            let final_ordering = combine_ordering_list add_orderings (pos.name) in
+            ((NodeA(pos,final_suctrees)),final_ordering,final_pos_n)
+         else
+            let final_ordering = combine_ordering_list new_ordering_list (pos.name) in
+            ((NodeA(pos,new_suctrees)),final_ordering,new_pos_n)
+
+
+(**************  Path checker   ****************************************************)
+
+let rec get_sets atom atom_sets =
+   match atom_sets with
+      [] -> raise (Invalid_argument "Jprover bug: atom not found")
+    | f::r ->
+         let (a,b,c) = f in
+         if atom = a then f
+         else
+            get_sets atom r
+
+let rec get_connections a alpha tabulist =
+   match alpha with
+      [] -> []
+    | f::r ->
+         if (a.apredicate = f.apredicate) & (a.apol <> f.apol) & (not (List.mem f tabulist)) then
+            (a,f)::(get_connections a r tabulist)
+         else
+            (get_connections a r tabulist)
+
+let rec connections atom_rel tabulist =
+   match atom_rel with
+      [] -> []
+    | f::r ->
+         let (a,alpha,beta) = f in
+         (get_connections a alpha tabulist) @ (connections r (a::tabulist))
+
+let check_alpha_relation atom set atom_sets =
+   let (a,alpha,beta) = get_sets atom atom_sets in
+   AtomSet.subset set alpha
+
+let rec extset  atom_sets path closed =
+   match atom_sets with
+      [] -> AtomSet.empty
+    | f::r ->
+         let (at,alpha,beta) = f in
+         if (AtomSet.subset path alpha) & (AtomSet.subset closed beta) then
+            AtomSet.add at (extset r path closed)
+         else
+            (extset r path closed)
+
+let rec check_ext_list ext_list fail_set atom_sets =  (* fail_set consists of one atom only *)
+   match ext_list with
+      [] -> AtomSet.empty
+    | f::r ->
+         if (check_alpha_relation f fail_set atom_sets) then
+            AtomSet.add f (check_ext_list r fail_set  atom_sets)
+         else
+            (check_ext_list r fail_set atom_sets)
+
+let fail_ext_set ext_atom ext_set atom_sets =
+   let ext_list = AtomSet.elements ext_set
+   and fail_set  = AtomSet.add ext_atom AtomSet.empty in
+   check_ext_list ext_list fail_set atom_sets
+
+let rec ext_partners con path ext_atom (reduction_partners,extension_partners) atom_sets =
+   match con with
+      [] ->
+         (reduction_partners,extension_partners)
+    | f::r ->
+         let (a,b) = f in
+         if List.mem ext_atom [a;b] then
+            let ext_partner =
+               if ext_atom = a then b else a
+            in
+            let (new_red_partners,new_ext_partners) =
+(* force reduction steps first *)
+               if (AtomSet.mem ext_partner path) then
+                  ((AtomSet.add ext_partner reduction_partners),extension_partners)
+               else
+                  if (check_alpha_relation ext_partner path atom_sets) then
+                     (reduction_partners,(AtomSet.add ext_partner extension_partners))
+                  else
+                     (reduction_partners,extension_partners)
+            in
+            ext_partners r path ext_atom (new_red_partners,new_ext_partners) atom_sets
+         else
+            ext_partners r path ext_atom (reduction_partners,extension_partners) atom_sets
+
+exception Failed_connections
+
+let path_checker atom_rel atom_sets qprefixes init_ordering logic =
+
+   let con = connections atom_rel [] in
+(*:   print_endline "";
+   print_endline ("number of connections: "^(string_of_int (List.length con)));
+   mbreak "#connec\n";
+:*)
+   let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) =
+
+      let rec check_connections (reduction_partners,extension_partners) ext_atom =
+         let try_one =
+            if reduction_partners = AtomSet.empty then
+               if extension_partners = AtomSet.empty then
+                  raise Failed_connections
+               else
+                  AtomSet.choose extension_partners
+            else
+       (* force reduction steps always first!! *)
+               AtomSet.choose reduction_partners
+         in
+(*         print_endline ("connection partner "^(try_one.aname)); *)
+(*       print_endline ("partner path "^(print_set path));
+*)
+         (try
+            let (new_sigmaQ,new_ordering_elements) = jqunify (ext_atom.alabel) (try_one.alabel) sigmaQ in
+(* build the orderingQ incrementally from the new added substitution tau of new_sigmaQ *)
+            let (relate_pairs,new_orderingQ) = build_orderingQ new_ordering_elements orderingQ in
+(* we make in incremental reflexivity test during the string unification *)
+            let (new_sigmaJ,new_eqlist,new_red_ordering) =
+(* new_red_ordering = [] in propositional case *)
+               stringunify ext_atom try_one eqlist relate_pairs logic new_orderingQ atom_rel qprefixes
+            in
+(*           print_endline ("make reduction ordering "^((string_of_int (List.length new_ordering)))); *)
+            let new_closed = AtomSet.add ext_atom closed in
+            let ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),subproof) =
+               if AtomSet.mem try_one path then
+                  provable path new_closed (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ)
+                     (* always use old first-order ordering for recursion *)
+               else
+                  let new_path = AtomSet.add ext_atom path
+                  and extension = AtomSet.add try_one AtomSet.empty in
+                  let ((norderingQ,nredordering),neqlist,(nsigmaQ,nsigmaJ),p1) =
+                     provable new_path extension (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) in
+                  let ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),p2) =
+                     provable path new_closed (norderingQ,nredordering) neqlist (nsigmaQ,nsigmaJ) in
+                  ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),(p1 @ p2))
+      (* first the extension subgoals = depth first; then other subgoals in same clause *)
+            in
+            ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),(((ext_atom.aname),(try_one.aname))::subproof))
+         with Failed ->
+(*          print_endline ("new connection for "^(ext_atom.aname)); *)
+(*            print_endline ("Failed"); *)
+            check_connections ((AtomSet.remove try_one reduction_partners),
+                               (AtomSet.remove try_one extension_partners)
+                              ) ext_atom
+         )
+
+      in
+      let rec check_extension  extset =
+         if extset = AtomSet.empty then
+            raise Failed             (* go directly to a new entry connection *)
+         else
+            let select_one = AtomSet.choose extset in
+(*        print_endline ("extension literal "^(select_one.aname)); *)
+(*        print_endline ("extension path "^(print_set path));*)
+            let (reduction_partners,extension_partners) =
+               ext_partners con path select_one (AtomSet.empty,AtomSet.empty) atom_sets in
+            (try
+               check_connections (reduction_partners,extension_partners) select_one
+            with Failed_connections ->
+(*         print_endline ("no connections for subgoal "^(select_one.aname)); *)
+(*           print_endline ("Failed_connections"); *)
+               let fail_ext_set = fail_ext_set select_one extset atom_sets in
+               check_extension fail_ext_set
+            )
+
+      in
+      let extset = extset atom_sets path closed in
+      if extset = AtomSet.empty then
+         ((orderingQ,reduction_ordering),eqlist,(sigmaQ,sigmaJ),[])
+      else
+         check_extension extset
+   in
+   if qprefixes = ([],[]) then
+      begin
+(*      print_endline "!!!!!!!!!!! prop prover !!!!!!!!!!!!!!!!!!"; *)
+(* in the propositional case, the reduction ordering will be computed AFTER proof search *)
+         let (_,eqlist,(_,(n,substJ)),ext_proof) =
+            provable AtomSet.empty AtomSet.empty ([],[]) (1,[]) ([],(1,[])) in
+         let orderingJ = build_orderingJ_list substJ init_ordering atom_rel in
+         ((init_ordering,orderingJ),eqlist,([],(n,substJ)),ext_proof)
+      end
+   else
+      provable AtomSet.empty AtomSet.empty (init_ordering,[]) (1,[]) ([],(1,[]))
+
+(*************************** prepare and init prover *******************************************************)
+
+let rec list_to_set list =
+   match list with
+      [] -> AtomSet.empty
+    | f::r ->
+         let rest_set = list_to_set r in
+         AtomSet.add f rest_set
+
+let rec make_atom_sets atom_rel =
+   match atom_rel with
+      [] -> []
+    | f::r ->
+         let (a,alpha,beta) =  f in
+         (a,(list_to_set alpha),(list_to_set beta))::(make_atom_sets r)
+
+let rec predecessor address_1 address_2 ftree =
+   match ftree with
+      Empty -> PNull            (* should not occur since every pair of atoms have a common predecessor *)
+    | NodeAt(position) -> PNull (* should not occur as above *)
+    | NodeA(position,suctrees) ->
+         match address_1,address_2 with
+            [],_ -> raise (Invalid_argument "Jprover: predecessors left")
+          | _,[] -> raise (Invalid_argument "Jprover: predecessors right")
+          | (f1::r1),(f2::r2) ->
+               if f1 = f2 then
+                  predecessor r1 r2 (suctrees.(f1-1))
+               else
+                  position.pt
+
+let rec compute_sets element ftree alist =
+   match alist with
+      [] -> [],[]
+    | first::rest ->
+         if first = element then
+            compute_sets element ftree rest    (* element is neithes alpha- nor beta-related to itself*)
+         else
+            let (alpha_rest,beta_rest) = compute_sets element ftree rest in
+            if predecessor (element.aaddress) (first.aaddress) ftree = Beta then
+               (alpha_rest,(first::beta_rest))
+            else
+               ((first::alpha_rest),beta_rest)
+
+let rec compute_atomlist_relations worklist ftree alist =  (* last version of alist for total comparison *)
+   let rec compute_atom_relations element ftree alist =
+      let alpha_set,beta_set = compute_sets element ftree alist in
+      (element,alpha_set,beta_set)
+   in
+   match worklist with
+      [] -> []
+    | first::rest ->
+         let first_relations = compute_atom_relations first ftree alist in
+         first_relations::(compute_atomlist_relations rest ftree alist)
+
+let atom_record position prefix =
+   let aname = (position.name) in
+   let aprefix = (List.append prefix [aname]) in (* atom position is last element in prefix *)
+   let aop = (dest_term position.label).term_op in
+   ({aname=aname; aaddress=(position.address); aprefix=aprefix; apredicate=aop;
+     apol=(position.pol); ast=(position.st); alabel=(position.label)})
+
+let rec select_atoms_treelist treelist prefix =
+   let rec select_atoms ftree prefix =
+      match ftree with
+         Empty -> [],[],[]
+       | NodeAt(position) ->
+            [(atom_record position prefix)],[],[]
+       | NodeA(position,suctrees) ->
+            let treelist = Array.to_list suctrees in
+            let new_prefix =
+               let prefix_element =
+                  if List.mem (position.st) [Psi_0;Phi_0] then
+                     [(position.name)]
+                  else
+                     []
+               in
+               (List.append prefix prefix_element)
+            in
+            let (gamma_0_element,delta_0_element) =
+               if position.st = Gamma_0 then
+                  begin
+(*  Format.open_box 0;
+   print_endline "gamma_0 prefixes ";
+   print_string (position.name^" :");
+   print_stringlist prefix;
+   print_endline " ";
+   Format.force_newline ();
+   Format.print_flush ();
+*)
+                     [(position.name,prefix)],[]
+                  end
+               else
+                  if position.st = Delta_0 then
+                     begin
+(* Format.open_box 0;
+   print_endline "delta_0 prefixes ";
+   print_string (position.name^" :");
+   print_stringlist prefix;
+   print_endline " ";
+   Format.force_newline ();
+   Format.print_flush ();
+*)
+                        [],[(position.name,prefix)]
+                     end
+                  else
+                     [],[]
+            in
+            let (rest_alist,rest_gamma_0_prefixes,rest_delta_0_prefixes) =
+               select_atoms_treelist treelist new_prefix in
+            (rest_alist,(rest_gamma_0_prefixes @ gamma_0_element),
+             (rest_delta_0_prefixes @ delta_0_element))
+
+   in
+   match treelist with
+      [] -> [],[],[]
+    | first::rest ->
+         let (first_alist,first_gprefixes,first_dprefixes) = select_atoms first prefix
+         and (rest_alist,rest_gprefixes,rest_dprefixes) = select_atoms_treelist rest prefix in
+         ((first_alist @ rest_alist),(first_gprefixes @ rest_gprefixes),
+          (first_dprefixes @ rest_dprefixes))
+
+let prepare_prover ftree =
+   let alist,gamma_0_prefixes,delta_0_prefixes = select_atoms_treelist [ftree] [] in
+   let atom_rel = compute_atomlist_relations alist ftree alist in
+   (atom_rel,(gamma_0_prefixes,delta_0_prefixes))
+
+(* ************************ Build intial formula tree  and relations *********************************** *)
+(* Building a formula tree and the tree ordering from the input formula, i.e. OCaml term *)
+
+let make_position_name stype pos_n =
+   let prefix =
+      if List.mem stype [Phi_0;Gamma_0]
+      then "v"
+      else
+         if List.mem stype [Psi_0;Delta_0]
+         then "c"
+         else
+            "a"
+   in
+   prefix^(string_of_int pos_n)
+
+let dual_pol pol =
+   if pol = O then I else O
+
+let check_subst_term (variable,old_term) pos_name stype =
+   if (List.mem stype [Gamma_0;Delta_0]) then
+      let new_variable =
+         if stype = Gamma_0 then (mk_var_term (pos_name^"_jprover"))
+         else
+            (mk_string_term jprover_op pos_name)
+      in
+      (subst1 old_term variable new_variable) (* replace variable (non-empty) in t by pos_name *)
+         (* pos_name is either a variable term or a constant, f.i. a string term *)
+         (* !!! check unification module how handling eingenvariables as constants !!! *)
+   else
+      old_term
+
+let rec build_ftree (variable,old_term) pol stype address pos_n =
+   let pos_name = make_position_name stype pos_n in
+   let term = check_subst_term (variable,old_term) pos_name stype in
+   if JLogic.is_and_term term then
+      let s,t = JLogic.dest_and term in
+      let ptype,stype_1,stype_2 =
+         if pol = O
+         then Beta,Beta_1,Beta_2
+         else
+            Alpha,Alpha_1,Alpha_2
+      in
+      let position = {name=pos_name; address=address; op=And; pol=pol; pt=ptype; st=stype; label=term} in
+      let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in
+      let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2])
+            (posn_left+1) in
+      let (succ_left,whole_left) = List.hd ordering_left
+      and (succ_right,whole_right) = List.hd ordering_right in
+      let pos_succs =
+         (StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)))
+      in
+      (NodeA(position,[|subtree_left;subtree_right|]),
+       ((position.name,pos_succs)::(ordering_left @ ordering_right)),
+       posn_right
+      )
+   else
+      if JLogic.is_or_term term then
+         let s,t = JLogic.dest_or term in
+         let ptype,stype_1,stype_2 =
+            if pol = O
+            then Alpha,Alpha_1,Alpha_2
+            else
+               Beta,Beta_1,Beta_2
+         in
+         let position = {name=pos_name; address=address; op=Or; pol=pol; pt=ptype; st=stype; label=term} in
+         let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in
+         let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2])
+               (posn_left+1) in
+         let (succ_left,whole_left) = List.hd ordering_left
+         and (succ_right,whole_right) = List.hd ordering_right in
+         let pos_succs =
+            StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in
+         (NodeA(position,[|subtree_left;subtree_right|]),
+          ((position.name),pos_succs) :: (ordering_left @ ordering_right),
+          posn_right
+         )
+      else
+         if JLogic.is_implies_term term then
+            let s,t = JLogic.dest_implies term in
+            let ptype_0,stype_0,ptype,stype_1,stype_2 =
+               if pol = O
+               then Psi,Psi_0,Alpha,Alpha_1,Alpha_2
+               else
+                  Phi,Phi_0,Beta,Beta_1,Beta_2
+            in
+            let pos2_name = make_position_name stype_0 (pos_n+1) in
+            let sposition = {name=pos_name; address=address; op=Imp; pol=pol; pt=ptype_0; st=stype; label=term}
+            and position = {name=pos2_name; address=address@[1]; op=Imp; pol=pol; pt=ptype; st=stype_0; label=term} in
+            let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1])
+                  (pos_n+2) in
+            let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[1;2])
+                  (posn_left+1) in
+            let (succ_left,whole_left) = List.hd ordering_left
+            and (succ_right,whole_right) = List.hd ordering_right in
+            let pos_succs =
+               StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in
+            let pos_ordering = (position.name,pos_succs) :: (ordering_left @ ordering_right) in
+            (NodeA(sposition,[|NodeA(position,[|subtree_left;subtree_right|])|]),
+             ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering),
+             posn_right
+            )
+         else
+            if JLogic.is_not_term term then
+               let s = JLogic.dest_not term in
+               let ptype_0,stype_0,ptype,stype_1=
+                  if pol = O
+                  then Psi,Psi_0,Alpha,Alpha_1
+                  else
+                     Phi,Phi_0,Alpha,Alpha_1
+               in
+               let pos2_name = make_position_name stype_0 (pos_n+1) in
+               let sposition = {name=pos_name; address=address; op=Neg; pol=pol; pt=ptype_0; st=stype; label=term}
+               and position = {name=pos2_name; address=address@[1]; op=Neg; pol=pol; pt=ptype; st=stype_0; label=term} in
+               let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1])
+                     (pos_n+2) in
+               let (succ_left,whole_left) = List.hd ordering_left in
+               let pos_succs =
+                  StringSet.add succ_left whole_left in
+               let pos_ordering = (position.name,pos_succs) :: ordering_left in
+               (NodeA(sposition,[|NodeA(position,[| subtree_left|])|]),
+                ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering),
+                posn_left
+               )
+            else
+               if JLogic.is_exists_term term then
+                  let v,s,t = JLogic.dest_exists term in  (* s is type of v and will be supressed here *)
+                  let ptype,stype_1 =
+                     if pol = O
+                     then Gamma,Gamma_0
+                     else
+                        Delta,Delta_0
+                  in
+                  let position = {name=pos_name; address=address; op=Ex; pol=pol; pt=ptype; st=stype; label=term} in
+                  let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1]) (pos_n+1) in
+                  let (succ_left,whole_left) = List.hd ordering_left in
+                  let pos_succs =
+                     StringSet.add succ_left whole_left in
+                  (NodeA(position,[|subtree_left|]),
+                   ((position.name,pos_succs) :: ordering_left),
+                   posn_left
+                  )
+               else
+                  if JLogic.is_all_term term then
+                     let v,s,t = JLogic.dest_all term in
+       (* s is type of v and will be supressed here *)
+                     let ptype_0,stype_0,ptype,stype_1=
+                        if pol = O
+                        then Psi,Psi_0,Delta,Delta_0
+                        else
+                           Phi,Phi_0,Gamma,Gamma_0
+                     in
+                     let pos2_name = make_position_name stype_0 (pos_n+1) in
+                     let sposition = {name=pos_name; address=address; op=All; pol=pol; pt=ptype_0; st=stype; label=term}
+                     and position = {name=pos2_name; address=address@[1]; op=All; pol=pol; pt=ptype; st=stype_0; label=term} in
+                     let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1;1])
+                           (pos_n+2) in
+                     let (succ_left,whole_left) = List.hd ordering_left in
+                     let pos_succs =
+                        StringSet.add succ_left whole_left in
+                     let pos_ordering = (position.name,pos_succs) :: ordering_left in
+                     (NodeA(sposition,[|NodeA(position,[|subtree_left|])|]),
+                      ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering),
+                      posn_left
+                     )
+                  else      (* finally, term is atomic *)
+                     let ptype_0,stype_0 =
+                        if pol = O
+                        then Psi,Psi_0
+                        else
+                           Phi,Phi_0
+                     in
+                     let pos2_name = make_position_name stype_0 (pos_n+1) in
+                     let sposition = {name=pos_name; address=address; op=At; pol=pol; pt=ptype_0; st=stype; label=term}
+                     and position = {name=pos2_name; address=address@[1]; op=At; pol=pol; pt=PNull; st=stype_0; label=term} in
+                     (NodeA(sposition,[|NodeAt(position)|]),
+                      [(sposition.name,(StringSet.add position.name StringSet.empty));(position.name,StringSet.empty)],
+                      pos_n+1
+                     )
+
+let rec construct_ftree termlist treelist orderinglist pos_n goal =
+   match termlist with
+      [] ->
+         let new_root = {name="w"; address=[]; op=Null; pol=O; pt=Psi; st=PNull_0; label=goal}
+         and treearray = Array.of_list treelist in
+         NodeA(new_root,treearray),(("w",(union_orderings orderinglist))::orderinglist),pos_n
+    | ft::rest_terms ->
+         let next_address = [((List.length treelist)+1)]
+         and next_pol,next_goal =
+            if rest_terms = []  then
+               O,ft (* construct tree for the conclusion *)
+            else
+               I,goal
+         in
+         let new_tree,new_ordering,new_pos_n =
+            build_ftree ("",ft) next_pol Alpha_1 next_address (pos_n+1) in
+         construct_ftree rest_terms (treelist @ [new_tree])
+            (orderinglist @ new_ordering) new_pos_n next_goal
+
+(*************************** Main LOOP ************************************)
+let unprovable = RefineError ("Jprover", StringError "formula is not provable")
+let mult_limit_exn = RefineError ("Jprover", StringError "multiplicity limit reached")
+let coq_exn = RefineError ("Jprover", StringError "interface for coq: error on ")
+
+let init_prover ftree =
+   let atom_relation,qprefixes = prepare_prover ftree in
+(*      print_atom_info atom_relation;  *)  (* apple *)
+   let atom_sets = make_atom_sets atom_relation in
+   (atom_relation,atom_sets,qprefixes)
+
+
+let rec try_multiplicity mult_limit ftree ordering pos_n mult logic =
+   try
+      let (atom_relation,atom_sets,qprefixes) = init_prover ftree in
+      let ((orderingQ,red_ordering),eqlist,unifier,ext_proof) =
+         path_checker atom_relation atom_sets qprefixes ordering logic in
+      (ftree,red_ordering,eqlist,unifier,ext_proof)   (* orderingQ is not needed as return value *)
+   with Failed ->
+      match mult_limit with
+         Some m when m == mult ->
+            raise mult_limit_exn
+       | _ ->
+            let new_mult = mult+1 in
+            begin
+            Pp.msgnl (Pp.(++) (Pp.str "Multiplicity Fail: Trying new multiplicity ")
+            (Pp.int new_mult));
+(*
+               Format.open_box 0;
+               Format.force_newline ();
+               Format.print_string "Multiplicity Fail: ";
+               Format.print_string ("Try new multiplicity "^(string_of_int new_mult));
+               Format.force_newline ();
+               Format.print_flush ();
+*)
+               let (new_ftree,new_ordering,new_pos_n) =
+                  add_multiplicity ftree pos_n new_mult logic in
+               if (new_ftree = ftree) then
+                  raise unprovable
+               else
+(*                  print_formula_info new_ftree new_ordering new_pos_n; *)  (* apple *)
+                  try_multiplicity mult_limit new_ftree new_ordering new_pos_n new_mult logic
+            end
+
+let prove mult_limit termlist logic =
+   let (ftree,ordering,pos_n) = construct_ftree termlist [] [] 0 (mk_var_term "dummy") in
+(* pos_n = number of positions without new root "w" *)
+(*   print_formula_info ftree ordering pos_n;   *)    (* apple *)
+   try_multiplicity mult_limit ftree ordering pos_n 1 logic
+
+(********** first-order type theory interface *******************)
+
+let rec renam_free_vars termlist =
+   match termlist
+   with [] -> [],[]
+    | f::r ->
+         let var_names = free_vars_list f in
+         let string_terms =
+             List.map (fun x ->  (mk_string_term free_var_op x)) var_names
+         in
+         let mapping = List.combine var_names string_terms
+         and new_f = subst f var_names string_terms in
+         let (rest_mapping,rest_renamed) = renam_free_vars r in
+         let unique_mapping = remove_dups_list (mapping @ rest_mapping) in
+         (unique_mapping,(new_f::rest_renamed))
+
+let rec apply_var_subst term var_subst_list =
+   match var_subst_list with
+      [] -> term
+    | (v,t)::r ->
+         let next_term = var_subst term t v in
+         apply_var_subst next_term r
+
+let rec make_equal_list n list_object =
+   if n = 0 then
+      []
+   else
+      list_object::(make_equal_list (n-1) list_object)
+
+let rec create_output rule_list input_map =
+   match rule_list with
+      [] -> JLogic.empty_inf
+    | f::r ->
+         let (pos,(rule,term1,term2)) = f in
+         let delta1_names = collect_delta_terms [term1]
+         and delta2_names = collect_delta_terms [term2] in
+         let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in
+         let delta_terms =
+            List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in
+         let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in
+         let delta_map = List.combine delta_vars delta_terms in
+         let var_mapping = (input_map @ delta_map) in
+         let frees1 = free_vars_list term1
+         and frees2 = free_vars_list term2 in
+         let unique_object = mk_var_term "v0_jprover" in
+         let unique_list1 = make_equal_list (List.length frees1) unique_object
+         and unique_list2 = make_equal_list (List.length frees2) unique_object
+         in
+         let next_term1 = subst term1 frees1 unique_list1
+         and next_term2 = subst term2 frees2 unique_list2 in
+         let new_term1 = apply_var_subst next_term1 var_mapping
+         and new_term2 = apply_var_subst next_term2 var_mapping
+         and (a,b) = pos
+         in
+(*:         print_string (a^"+++"^b^"\n");  :*)
+
+(* kick away the first argument, the position *)
+         (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule)
+
+let rec make_test_interface rule_list input_map =
+   match rule_list with
+      [] -> []
+    | f::r ->
+         let (pos,(rule,term1,term2)) = f in
+         let delta1_names = collect_delta_terms [term1]
+         and delta2_names = collect_delta_terms [term2] in
+         let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in
+         let delta_terms =
+            List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in
+         let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in
+         let delta_map = List.combine delta_vars delta_terms in
+         let var_mapping = (input_map @ delta_map) in
+         let frees1 = free_vars_list term1
+         and frees2 = free_vars_list term2 in
+         let unique_object = mk_var_term "v0_jprover" in
+         let unique_list1 = make_equal_list (List.length frees1) unique_object
+         and unique_list2 = make_equal_list (List.length frees2) unique_object
+         in
+         begin
+(*
+   print_endline "";
+   print_endline "";
+   print_stringlist frees1;
+   print_endline "";
+   print_stringlist frees2;
+   print_endline "";
+   print_endline "";
+*)
+            let next_term1 = subst term1 frees1 unique_list1
+            and next_term2 = subst term2 frees2 unique_list2 in
+            let new_term1 = apply_var_subst next_term1 var_mapping
+            and new_term2 = apply_var_subst next_term2 var_mapping
+            in
+            (pos,(rule,new_term1,new_term2))::(make_test_interface r input_map)
+         end
+
+(**************************************************************)
+
+(*: modified for Coq :*)
+
+let decomp_pos pos =
+    let {name=n; address=a; label=l} = pos in
+      (n,(a,l))
+
+let rec build_formula_id ftree =
+  let rec build_fid_list = function
+     [] -> []
+   | t::rest -> (build_formula_id t)@(build_fid_list rest)
+  in
+    match ftree with
+        Empty  -> []
+    | NodeAt(position) ->
+        [decomp_pos position]
+    | NodeA(position,subtrees) ->
+        let tree_list = Array.to_list subtrees in
+        (decomp_pos position)::(build_fid_list tree_list)
+
+let rec encode1 = function      (* normal *)
+      [] -> ""
+    | i::r -> "_"^(string_of_int i)^(encode1 r)
+
+let rec encode2 = function      (* move up *)
+      [i] -> ""
+    | i::r -> "_"^(string_of_int i)^(encode2 r)
+    | _ -> raise coq_exn
+
+let rec encode3 = function      (* move down *)
+      [] -> "_1"
+    | i::r -> "_"^(string_of_int i)^(encode3 r)
+
+let lookup_coq str map =
+  try
+    let (il,t) = List.assoc str map in
+        il
+  with Not_found -> raise coq_exn
+
+let create_coq_input inf map =
+  let rec rec_coq_part inf =
+    match inf with
+        [] -> []
+     |  (rule, (s1, t1), ((s2, t2) as k))::r ->
+        begin
+           match rule with
+                Andl | Andr | Orl | Orr1 | Orr2 ->
+                    (rule, (encode1 (lookup_coq s1 map), t1), k)::(rec_coq_part r)
+             |  Impr | Impl | Negr | Negl | Ax ->
+                    (rule, (encode2 (lookup_coq s1 map), t1), k)::(rec_coq_part r)
+             | Exr ->
+                    (rule, (encode1 (lookup_coq s1 map), t1),
+                           (encode1 (lookup_coq s2 map), t2))::(rec_coq_part r)
+             | Exl ->
+                    (rule, (encode1 (lookup_coq s1 map), t1),
+                           (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r)
+             | Allr | Alll ->
+                    (rule, (encode2 (lookup_coq s1 map), t1),
+                       (*    (s2, t2))::(rec_coq_part r) *)
+                           (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r)
+             | _ -> raise coq_exn
+        end
+  in
+    rec_coq_part inf
+
+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 *)
+     (* we can transform the eigenvariables AFTER proof reconstruction since *)
+     (* new delta_0 constants may have been constructed during rule permutation *)
+     (* from the LJmc to the LJ proof *)
+     create_coq_input (create_output sequent_proof input_map) idl
+
+(*: end of coq modification :*)
+
+let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl]
+
+(************* test with propositional proof reconstruction ************)
+
+let rec count_axioms seq_list =
+   match seq_list with
+      [] -> 0
+    | f::r ->
+         let (rule,_,_) = f in
+         if rule = Ax then
+            1 + count_axioms r
+         else
+            count_axioms r
+
+let do_prove mult_limit termlist logic calculus =
+   try begin
+      let (input_map,renamed_termlist) = renam_free_vars termlist in
+      let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in
+      Format.open_box 0;
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_string "Extension proof ready";
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_string ("Length of Extension proof: "^((string_of_int (List.length ext_proof)))^
+                           " Axioms");
+      Format.force_newline ();
+      Format.force_newline ();
+      print_endline "Extension proof:";
+      Format.open_box 0;
+      print_pairlist ext_proof;       (* print list of type (string * string) list *)
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_flush ();
+      Format.print_flush ();
+      Format.open_box 0;
+      print_ordering red_ordering;
+      Format.print_flush ();
+      Format.open_box 0;
+      Format.force_newline ();
+(* ----------------------------------------------- *)
+      Format.open_box 0;
+      print_tunify sigmaJ;
+      Format.print_flush ();
+      print_endline "";
+      print_endline "";
+      print_sigmaQ sigmaQ;
+      print_endline "";
+      print_endline "";
+      Format.open_box 0;
+      let (qmax,equations) = eqlist in
+      print_endline ("number of quantifier domains : "^(string_of_int (qmax-1)));
+      print_endline "";
+      print_equations equations;
+      Format.print_flush ();
+      print_endline "";
+      print_endline "";
+      print_endline ("Length of equations : "^((string_of_int (List.length equations))));
+      print_endline "";
+      print_endline "";
+(* --------------------------------------------------------- *)
+      Format.print_string "Break ... ";
+      print_endline "";
+      print_endline "";
+      Format.print_flush ();
+(*:      let _ = input_char stdin in :*)
+      let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in
+      let sequent_proof = make_test_interface reconstr_proof input_map in
+      Format.open_box 0;
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_string "Sequent proof ready";
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_flush ();
+      let (ptree,count_ax) = bproof sequent_proof in
+      Format.open_box 0;
+      Format.print_string ("Length of sequent proof: "^((string_of_int count_ax))^" Axioms");
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.force_newline ();
+      Format.print_flush ();
+      tt ptree;     (*: print proof tree :*)
+      Format.print_flush ();
+      print_endline "";
+      print_endline ""
+   end with exn -> begin
+      print_endline "Jprover got an exception:";
+      print_endline (Printexc.to_string exn)
+   end
+
+let test concl logic calculus =  (* calculus should be LJmc or LJ for J, and LK for C *)
+   do_prove None [concl] logic calculus
+
+(* for sequents *)
+
+let seqtest list_term logic calculus =
+   let bterms = (dest_term list_term).term_terms in
+   let termlist = collect_subterms bterms in
+   do_prove None termlist logic calculus
+
+(*****************************************************************)
+
+end (* of struct *)
diff --git a/contrib/jprover/jall.mli b/contrib/jprover/jall.mli
new file mode 100644
index 00000000..1811fe59
--- /dev/null
+++ b/contrib/jprover/jall.mli
@@ -0,0 +1,339 @@
+(* JProver provides an efficient refiner for first-order classical
+   and first-order intuitionistic logic. It consists of two main parts:
+   a proof search procedure and a proof reconstruction procedure.
+
+
+   Proof Search
+   ============
+
+   The proof search process is based on a matrix-based (connection-based)
+   proof procedure, i.e.~a non-normalform extension procedure.
+   Besides the well-known quantifier substitution (Martelli Montanari),
+   a special string unifiation procedure is used in order to
+   efficiently compute intuitionistic rule non-permutabilities.
+
+
+   Proof Reconstruction
+   ====================
+
+   The proof reconstruction process converts machine-generated matrix proofs
+   into cut-free Gentzen-style sequent proofs. For classcal logic "C",
+   Gentzen's sequent calculus "LK" is used as target calculus.
+   For intuitionistic logic "J", either Gentzen's single-conclusioned sequent
+   calculus "LJ" or Fitting's multiply-conclusioned sequent calculus "LJmc"
+   can be used. All sequent claculi are implemented in a set-based formulation
+   in order to avoid structural rules.
+
+   The proof reconstruction procedure combines three main procedures, depending
+   on the selected logics and sequent calculi. It consists of:
+
+    1) A uniform traversal algorithm for all logics and target sequent calculi.
+       This procedure converts classical (intuitionistic) matrix proofs
+       directly into cut-free "LK" ("LJmc" or "LJ") sequent proofs.
+       However, the direct construction of "LJ" proofs may fail in some cases
+       due to proof theoretical reasons.
+
+    2) A complete redundancy deletion algorithm, which integrates additional
+       knowledge from the proof search process into the reconstruction process.
+       This procedure is called by the traversal algorithms in order to avoid
+       search and deadlocks during proof reconstruciton.
+
+    3) A permutation-based proof transformation for converting "LJmc" proofs
+       into "LJ" proofs.
+       This procedure is called by-need, whenever the direct reconstruction
+       of "LJ" proofs from matrix proofs fails.
+
+
+
+
+   Literature:
+   ==========
+
+   JProver system description was presented at CADE 2001:
+   @InProceedings{inp:Schmitt+01a,
+     author          = "Stephan Schmitt and Lori Lorigo and Christoph Kreitz and
+                        Alexey Nogin",
+     title           = "{{\sf JProver}}: Integrating Connection-based Theorem
+                        Proving into Interactive Proof Assistants",
+     booktitle       = "International Joint Conference on Automated Reasoning",
+     year            = "2001",
+     editor          = "R. Gore and A. Leitsch and T. Nipkow",
+     volume          = 2083,
+     series          = LNAI,
+     pages           = "421--426",
+     publisher       = SPRINGER,
+     language        = English,
+     where           = OWN,
+   }
+
+   The implementation of JProver is based on the following publications:
+
+
+
+   Slides of PRL-seminar talks:
+   ---------------------------
+
+   An Efficient Refiner for First-order Intuitionistic Logic
+
+   http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/feb28.html
+
+
+   An Efficient Refiner for First-order Intuitionistic Logic (Part II)
+
+   http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/may22.html
+
+
+
+   Proof search:
+   -------------
+
+
+[1]
+   @InProceedings{inp:OttenKreitz96b,
+     author       = "J.~Otten and C.~Kreitz",
+     title        = "A uniform proof procedure  for classical and
+                     non-classical logics",
+     booktitle	  = "Proceedings of the 20$^{th}$ German Annual Conference on
+                     Artificial Intelligence",
+     year	  = "1996",
+     editor	  = "G.~G{\"o}rz and S.~H{\"o}lldobler",
+     number	  = "1137",
+     series	  = LNAI,
+     pages	  = "307--319",
+     publisher	  = SPRINGER
+    }
+
+
+[2]
+   @Article{ar:KreitzOtten99,
+     author	  = "C.~Kreitz and J.~Otten",
+     title 	  = "Connection-based theorem proving in classical and
+                     non-classical logics",
+     journal	  = "Journal for Universal Computer Science,
+                     Special Issue on Integration of Deductive Systems",
+     year  	  = "1999",
+     volume	  = "5",
+     number	  = "3",
+     pages 	  = "88--112"
+    }
+
+
+
+
+   Special string unifiation procedure:
+   ------------------------------------
+
+
+[3]
+   @InProceedings{inp:OttenKreitz96a,
+     author	  = "J.~Otten and C.~Kreitz",
+     titl         = "T-string-unification: unifying prefixes in
+                     non-classical proof methods",
+     booktitle	  = "Proceedings of the 5$^{th}$ Workshop on Theorem Proving
+		     with Analytic Tableaux and Related Methods",
+     year         = 1996,
+     editor   	  = "U.~Moscato",
+     number	  = "1071",
+     series   	  = LNAI,
+     pages        = "244--260",
+     publisher 	  = SPRINGER,
+     month   	  = "May      "
+    }
+
+
+
+   Proof reconstruction: Uniform traversal algorithm
+   -------------------------------------------------
+
+
+[4]
+   @InProceedings{inp:SchmittKreitz96a,
+     author       = "S.~Schmitt and C.~Kreitz",
+     title        = "Converting non-classical matrix proofs into
+                     sequent-style systems",
+     booktitle    = "Proceedings of the 13$^t{}^h$ Conference on
+                     Automated Deduction",
+     editor       =  M.~A.~McRobbie and J.~K.~Slaney",
+     number       = "1104",
+     series       = LNAI,
+     pages        = "418--432",
+     year         = "1996",
+     publisher    = SPRINGER,
+     month        = "July/August"
+    }
+
+
+[5]
+   @Article{ar:KreitzSchmitt00,
+     author	  = "C.~Kreitz and S.~Schmitt",
+     title 	  = "A uniform procedure for converting matrix proofs
+                     into sequent-style systems",
+     journal	  = "Journal of Information and Computation",
+     year  	  = "2000",
+     note  	  = "(to appear)"
+    }
+
+
+[6]
+   @Book{bo:Schmitt00,
+     author	  = "S.~Schmitt",
+     title 	  = "Proof reconstruction in classical and non-classical logics",
+     year  	  = "2000",
+     publisher	  = "Infix",
+     series       = "Dissertationen zur K{\"u}nstlichen Intelleigenz",
+     number       = "(to appear)",
+     note         = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt,
+                     FG Intellektik, Germany, 1999)"
+    }
+
+   The traversal algorithm is presented in the Chapters 2 and 3 of my thesis.
+   The thesis will be made available for the Department through Christoph Kreitz,
+   Upson 4159, kreitz@cs.cornell.edu
+
+
+
+
+   Proof reconstruction: Complete redundancy deletion
+   --------------------------------------------------
+
+
+[7]
+   @Book{bo:Schmitt00,
+     author	  = "S.~Schmitt",
+     title 	  = "Proof reconstruction in classical and non-classical logics",
+     year  	  = "2000",
+     publisher	  = "Infix",
+     series       = "Dissertationen zur K{\"u}nstlichen Intelleigenz",
+     note         = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt,
+                     FG Intellektik, Germany, 1999)"
+     note         = "(to appear)",
+
+    }
+
+   The integration of proof knowledge and complete redundancy deletion is presented
+   in Chapter 4 of my thesis.
+
+
+[8]
+   @InProceedings{inp:Schmitt00,
+     author	  = "S.~Schmitt",
+     title        = "A tableau-like representation framework for efficient
+                     proof reconstruction",
+     booktitle	  = "Proceedings of the International Conference on Theorem Proving
+                     with Analytic Tableaux and Related Methods",
+     year	  = "2000",
+     series   	  = LNAI,
+     publisher 	  = SPRINGER,
+     month   	  = "June"
+     note         = "(to appear)",
+    }
+
+
+
+
+   Proof Reconstruction: Permutation-based poof transformations "LJ" -> "LJmc"
+   ---------------------------------------------------------------------------
+
+
+[9]
+   @InProceedings{inp:EglySchmitt98,
+     author	  = "U.~Egly and S.~Schmitt",
+     title        = "Intuitionistic proof transformations and their
+                     application to constructive program synthesis",
+     booktitle	  = "Proceedings of the 4$^{th}$ International Conference
+                     on Artificial Intelligence and Symbolic Computation",
+     year         = "1998",
+     editor   	  = "J.~Calmet and J.~Plaza",
+     number	  = "1476",
+     series   	  = LNAI,
+     pages	  = "132--144",
+     publisher 	  = SPRINGER,
+     month   	  = "September"
+    }
+
+
+[10]
+   @Article{ar:EglySchmitt99,
+     author	  = "U.~Egly and S.~Schmitt",
+     title 	  = "On intuitionistic proof transformations, their
+                     complexity, and application to constructive program synthesis",
+     journal	  = "Fundamenta Informaticae,
+                     Special Issue: Symbolic Computation and Artificial Intelligence",
+    year  	  = "1999",
+    volume	  = "39",
+    number	  = "1--2",
+    pages 	  = "59--83"
+   }
+*)
+
+(*: open Refiner.Refiner
+open Refiner.Refiner.Term
+open Refiner.Refiner.TermType
+open Refiner.Refiner.TermSubst 
+
+open Jlogic_sig
+:*)
+
+open Jterm
+open Opname
+open Jlogic
+
+val ruletable : rule -> string
+
+module JProver(JLogic: JLogicSig) :
+sig
+  val test : term -> string -> string -> unit
+
+  (* Procedure call: test conclusion logic calculus
+
+     test is applied to a first-order formula. The output is some
+     formatted sequent proof for test / debugging purposes.
+
+     The arguments for test are as follows:
+
+     logic = "C"|"J"
+     i.e. first-order classical logic or first-order intuitionistic logic
+
+     calculus = "LK"|"LJ"|"LJmc"
+     i.e. "LK" for classical logic "C", and either Gentzen's single conclusioned
+     calculus "LJ" or Fittings multiply-conclusioned calculus "LJmc" for
+     intuitionistic logic "J".
+
+     term = first-order formula representing the proof goal.
+  *)
+
+
+
+  val seqtest : term -> string -> string -> unit
+
+  (* seqtest procedure is for debugging purposes only *)
+
+
+  val gen_prover : int option -> string -> string -> term list -> term list -> JLogic.inference
+
+  (* Procedure call: gen_prover mult_limit logic calculus hypothesis conclusion
+
+     The arguments for gen_prover are as follows:
+
+     mult_limit - maximal multiplicity to try, None for unlimited
+
+     logic = same as in test
+
+     calculus = same as in test
+
+     hypothesis = list of first-order terms forming the antecedent of the input sequent
+
+     conclusion = list of first-order terms forming the succedent of the input sequent
+     This list should contain only one element if logic = "J" and calculus = "LJ".
+  *)
+
+
+  val prover : int option -> term list -> term -> JLogic.inference
+
+  (* Procedure call: gen_prover mult_limit "J" "LJ" hyps [concl]
+
+     prover provides the first-order refiner for NuPRL, using
+     a single concluisoned succedent [concl] in the sequent.
+     The result is a sequent proof in the single-conclusioned calculus "LJ".
+  *)
+end
diff --git a/contrib/jprover/jlogic.ml b/contrib/jprover/jlogic.ml
new file mode 100644
index 00000000..c074e93e
--- /dev/null
+++ b/contrib/jprover/jlogic.ml
@@ -0,0 +1,106 @@
+open Opname
+open Jterm
+
+type rule =
+ | Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl
+ | Allr | Alll| Exr | Exl | Fail | Falsel | Truer
+
+let ruletable = function
+ | Fail -> "Fail"
+ | Ax ->     "Ax"
+ | Negl ->  "Negl"
+ | Negr ->  "Negr"
+ | Andl ->  "Andl"
+ | Andr ->  "Andr"
+ | Orl ->   "Orl"
+ | Orr ->   "Orr"
+ | Orr1 ->   "Orr1"
+ | Orr2 ->   "Orr2"
+ | Impl ->   "Impl"
+ | Impr ->   "Impr"
+ | Exl ->   "Exl"
+ | Exr ->   "Exr"
+ | Alll ->   "Alll"
+ | Allr ->   "Allr"
+ | Falsel -> "Falsel"
+ | Truer -> "Truer"
+
+module type JLogicSig =
+sig
+   (* understanding the input *)
+	val is_all_term	: term -> bool
+	val dest_all : term -> string * term * term
+	val is_exists_term : term -> bool
+	val dest_exists : term -> string * term * term
+	val is_and_term : term -> bool
+	val dest_and : term -> term * term
+	val is_or_term : term -> bool
+	val dest_or : term -> term * term
+	val is_implies_term : term -> bool
+	val dest_implies : term -> term * term
+	val is_not_term : term -> bool
+	val dest_not : term -> term 
+
+   (* processing the output *)
+   type inf_step = rule * (string * term) * (string * term)
+   type inference = inf_step list
+(* type inference *)
+   val empty_inf : inference
+   val append_inf : inference -> (string * term) -> (string * term) -> rule -> inference
+   val print_inf : inference -> unit
+end;;
+
+(* Copy from [term_op_std.ml]: *)
+
+   let rec print_address int_list =
+      match int_list with
+       | [] ->
+            Format.print_string ""
+       | hd::rest ->
+            begin
+               Format.print_int hd;
+               print_address rest
+            end
+
+module JLogic: JLogicSig =
+struct
+  let is_all_term = Jterm.is_all_term
+  let dest_all = Jterm.dest_all
+  let is_exists_term = Jterm.is_exists_term
+  let dest_exists = Jterm.dest_exists
+  let is_and_term = Jterm.is_and_term
+  let dest_and = Jterm.dest_and
+  let is_or_term = Jterm.is_or_term
+  let dest_or = Jterm.dest_or
+  let is_implies_term = Jterm.is_implies_term
+  let dest_implies = Jterm.dest_implies
+  let is_not_term = Jterm.is_not_term
+  let dest_not = Jterm.dest_not
+
+  type inf_step = rule * (string * term) * (string * term)
+  type inference = inf_step list
+
+  let empty_inf = []
+  let append_inf inf t1 t2 rule =
+    (rule, t1, t2)::inf
+
+  let rec print_inf inf =
+   match inf with
+  |  [] -> print_string "."; Format.print_flush ()
+  |  (rule, (n1,t1), (n2,t2))::d ->
+      print_string (ruletable rule);
+      print_string (":("^n1^":");
+      print_term stdout t1;
+      print_string (","^n2^":");
+      print_term stdout t2;
+      print_string ")\n";
+      print_inf d
+end;;
+
+let show_loading s = print_string s
+type my_Debug = { mutable debug_name: string;
+                  mutable debug_description: string;
+                  debug_value: bool
+                }
+
+let create_debug x = ref false
diff --git a/contrib/jprover/jlogic.mli b/contrib/jprover/jlogic.mli
new file mode 100644
index 00000000..a9079791
--- /dev/null
+++ b/contrib/jprover/jlogic.mli
@@ -0,0 +1,40 @@
+(* The interface to manipulate [jterms], which is
+   extracted and modified from Meta-Prl. *)
+
+type rule =
+   Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl
+ | Allr | Alll| Exr | Exl | Fail | Falsel | Truer
+
+module type JLogicSig =
+  sig
+    val is_all_term : Jterm.term -> bool
+    val dest_all : Jterm.term -> string * Jterm.term * Jterm.term
+    val is_exists_term : Jterm.term -> bool
+    val dest_exists : Jterm.term -> string * Jterm.term * Jterm.term
+    val is_and_term : Jterm.term -> bool
+    val dest_and : Jterm.term -> Jterm.term * Jterm.term
+    val is_or_term : Jterm.term -> bool
+    val dest_or : Jterm.term -> Jterm.term * Jterm.term
+    val is_implies_term : Jterm.term -> bool
+    val dest_implies : Jterm.term -> Jterm.term * Jterm.term
+    val is_not_term : Jterm.term -> bool
+    val dest_not : Jterm.term -> Jterm.term
+    type inf_step = rule * (string * Jterm.term) * (string * Jterm.term)
+    type inference = inf_step list
+    val empty_inf : inference
+    val append_inf :
+      inference -> (string * Jterm.term) -> (string * Jterm.term) -> rule -> inference
+    val print_inf : inference -> unit
+  end
+
+module JLogic : JLogicSig
+
+val show_loading : string -> unit
+
+type my_Debug = {
+  mutable debug_name : string;
+  mutable debug_description : string;
+  debug_value : bool;
+} 
+val create_debug : 'a -> bool ref
+val ruletable : rule -> string
diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4
new file mode 100644
index 00000000..dd76438f
--- /dev/null
+++ b/contrib/jprover/jprover.ml4
@@ -0,0 +1,565 @@
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Jlogic
+
+module JA = Jall
+module JT = Jterm
+module T = Tactics
+module TCL = Tacticals
+module TM = Tacmach
+module N = Names
+module PT = Proof_type
+module HT = Hiddentac
+module PA = Pattern
+module HP = Hipattern
+module TR = Term
+module PR = Printer
+module RO = Reductionops
+module UT = Util
+module RA = Rawterm
+
+module J=JA.JProver(JLogic)         (* the JProver *)
+
+(*i
+module NO = Nameops
+module TO = Termops
+module RE = Reduction
+module CL = Coqlib
+module ID = Inductiveops
+module CV = Clenv
+module RF = Refiner
+i*)
+
+(* Interface to JProver: *)
+(* type JLogic.inf_step = rule * (string * Jterm.term) * (string * Jterm.term) *)
+type jp_inf_step = JLogic.inf_step
+type jp_inference = JLogic.inference    (* simply a list of [inf_step] *)
+
+(* Definitions for rebuilding proof tree from JProver: *)
+(* leaf, one-branch, two-branch, two-branch, true, false *)
+type jpbranch = JP0 | JP1 | JP2 | JP2' | JPT | JPF
+type jptree = | JPempty                                 (* empty tree *)
+              | JPAx of jp_inf_step                     (* Axiom node *)
+              | JPA of jp_inf_step * jptree
+              | JPB of jp_inf_step * jptree * jptree
+
+(* Private debugging tools: *)
+(*i*)
+let mbreak s = Format.print_flush (); print_string ("-break at: "^s);
+               Format.print_flush (); let _ = input_char stdin in ()
+(*i*)
+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 rec print_constr_list = function
+  |  [] -> ()
+  |  ct::r -> print_constr ct; print_constr_list r
+
+let print_constr_pair op c1 c2 =
+    print_string (op^"(");
+    print_constr c1;
+    print_string ",";
+    print_constr c2;
+    print_string ")\n"
+
+
+(* Parsing modules for Coq:         *)
+(* [is_coq_???] : testing functions *)
+(* [dest_coq_???] : destructors     *)
+
+let is_coq_true ct = (HP.is_unit_type ct) && not (HP.is_equation ct)
+
+let is_coq_false = HP.is_empty_type
+
+(* return two subterms *)
+let dest_coq_and ct =
+    match (HP.match_with_conjunction ct) with
+      | Some (hdapp,args) ->
+(*i            print_constr hdapp; print_constr_list args; i*)
+            begin
+               match args with
+                   | s1::s2::[] ->
+(*i                       print_constr_pair "and" s1 s2; i*)
+                       (s1,s2)
+                   | _ -> jp_error "dest_coq_and"
+            end
+      | None -> jp_error "dest_coq_and"
+
+let is_coq_or = HP.is_disjunction
+
+(* return two subterms *)
+let dest_coq_or ct =
+    match (HP.match_with_disjunction ct) with
+      | Some (hdapp,args) ->
+(*i            print_constr hdapp; print_constr_list args; i*)
+            begin
+               match args with
+                   | s1::s2::[] ->
+(*i                       print_constr_pair "or" s1 s2; i*)
+                       (s1,s2)
+                   | _ -> jp_error "dest_coq_or"
+            end
+      | None -> jp_error "dest_coq_or"
+
+let is_coq_not = HP.is_nottype
+
+let dest_coq_not ct =
+    match (HP.match_with_nottype ct) with
+      | Some (hdapp,arg) ->
+(*i            print_constr hdapp; print_constr args; i*)
+(*i            print_string "not ";
+            print_constr arg; i*)
+            arg
+      | None -> jp_error "dest_coq_not"
+
+
+let is_coq_impl ct =
+  match TR.kind_of_term ct with
+    | TR.Prod (_,_,b) -> (not (Termops.dependent (TR.mkRel 1) b))
+    | _  -> false
+
+
+let dest_coq_impl c =
+  match TR.kind_of_term c with
+    | TR.Prod (_,b,c) ->
+(*i            print_constr_pair "impl" b c; i*)
+            (b, c)
+    | _ -> jp_error "dest_coq_impl"
+
+(* provide new variables for renaming of universal variables *)
+let new_counter =
+  let ctr = ref 0 in
+    fun () -> incr ctr;!ctr
+
+(* provide new symbol name for unknown Coq constructors *)
+let new_ecounter =
+  let ectr = ref 0 in
+    fun () -> incr ectr;!ectr
+
+(* provide new variables for address naming *)
+let new_acounter =
+  let actr = ref 0 in
+    fun () -> incr actr;!actr
+
+let is_coq_forall ct =
+  match TR.kind_of_term (RO.whd_betaiota ct) with
+    | TR.Prod (_,_,b) -> Termops.dependent (TR.mkRel 1) b
+    | _  -> false
+
+(* return the bounded variable (as a string) and the bounded term *)
+let dest_coq_forall ct =
+  match TR.kind_of_term (RO.whd_betaiota ct) with
+    | TR.Prod (_,_,b) ->
+        let x ="jp_"^(string_of_int (new_counter())) in
+        let v = TR.mkVar (N.id_of_string x) in
+        let c = TR.subst1 v b in    (* substitute de Bruijn variable by [v] *)
+(*i        print_constr_pair "forall" v c; i*)
+        (x, c)
+    | _  -> jp_error "dest_coq_forall"
+
+
+(* Apply [ct] to [t]: *)
+let sAPP ct t =
+  match TR.kind_of_term (RO.whd_betaiota ct) with
+    | TR.Prod (_,_,b) ->
+        let c = TR.subst1 t b in
+            c
+    | _  -> jp_error "sAPP"
+
+
+let is_coq_exists ct =
+  if not (HP.is_conjunction ct) then false
+  else let (hdapp,args) = TR.decompose_app ct in
+     match args with
+      | _::la::[] ->
+           begin
+            try
+              match TR.destLambda la with
+                | (N.Name _,_,_) -> true
+                | _ -> false
+            with _ -> false
+           end
+      | _ -> false
+
+(* return the bounded variable (as a string) and the bounded term *)
+let dest_coq_exists ct =
+  let (hdapp,args) = TR.decompose_app ct in
+     match args with
+      | _::la::[] ->
+           begin
+            try
+             match TR.destLambda la with
+                    | (N.Name x,t1,t2) ->
+                         let v = TR.mkVar x in
+                         let t3 = TR.subst1 v t2 in
+(*i                            print_constr_pair "exists" v t3; i*)
+                            (N.string_of_id x, t3)
+                    | _ -> jp_error "dest_coq_exists"
+            with _ -> jp_error "dest_coq_exists"
+           end
+      | _ -> jp_error "dest_coq_exists"
+
+
+let is_coq_and ct =
+  if (HP.is_conjunction ct) && not (is_coq_exists ct)
+  && not (is_coq_true ct) then true
+  else false
+
+
+(* Parsing modules: *)
+
+let jtbl = Hashtbl.create 53        (* associate for unknown Coq constr. *)
+let rtbl = Hashtbl.create 53        (* reverse table of [jtbl] *)
+
+let dest_coq_symb ct =
+    N.string_of_id (TR.destVar ct)
+
+(* provide new names for unknown Coq constr. *)
+(* [ct] is the unknown constr., string [s] is appended to the name encoding *)
+let create_coq_name ct s =
+    try
+       Hashtbl.find jtbl ct
+    with Not_found ->
+       let t = ("jp_"^s^(string_of_int (new_ecounter()))) in
+          Hashtbl.add jtbl ct t;
+          Hashtbl.add rtbl t ct;
+          t
+
+let dest_coq_app ct s =
+    let (hd, args) = TR.decompose_app ct in
+(*i        print_constr hd;
+        print_constr_list args; i*)
+       if TR.isVar hd then
+          (dest_coq_symb hd, args)
+       else                         (* unknown constr *)
+          (create_coq_name hd s, args)
+
+let rec parsing2 c =        (* for function symbols, variables, constants *)
+    if (TR.isApp c) then    (* function symbol? *)
+        let (f,args) = dest_coq_app c "fun_" in
+            JT.fun_ f (List.map parsing2 args)
+    else if TR.isVar c then (* identifiable variable or constant *)
+            JT.var_ (dest_coq_symb c)
+    else                    (* unknown constr *)
+            JT.var_ (create_coq_name c "var_")
+
+(* the main parsing function *)
+let rec parsing c =
+    let ct = Reduction.whd_betadeltaiota (Global.env ()) c in
+(*    let ct = Reduction.whd_betaiotazeta (Global.env ()) c in *)
+    if is_coq_true ct then
+       JT.true_
+    else if is_coq_false ct then
+       JT.false_
+    else if is_coq_not ct then
+        JT.not_ (parsing (dest_coq_not ct))
+    else if is_coq_impl ct then
+        let (t1,t2) = dest_coq_impl ct in
+            JT.imp_ (parsing t1) (parsing t2)
+    else if is_coq_or ct then
+        let (t1,t2) = dest_coq_or ct in
+            JT.or_ (parsing t1) (parsing t2)
+    else if is_coq_and ct then
+        let (t1,t2) = dest_coq_and ct in
+            JT.and_ (parsing t1) (parsing t2)
+    else if is_coq_forall ct then
+        let (v,t) = dest_coq_forall ct in
+            JT.forall v (parsing t)
+    else if is_coq_exists ct then
+        let (v,t) = dest_coq_exists ct in
+            JT.exists v (parsing t)
+    else if TR.isApp ct then            (* predicate symbol with arguments *)
+        let (p,args) = dest_coq_app ct "P_" in
+            JT.pred_ p (List.map parsing2 args)
+    else if TR.isVar ct then            (* predicate symbol without arguments *)
+        let p = dest_coq_symb ct in
+            JT.pred_ p []
+    else                                (* unknown predicate *)
+        JT.pred_ (create_coq_name ct "Q_") []
+
+(*i
+        print_string "??";print_constr ct;
+        JT.const_ ("err_"^(string_of_int (new_ecounter())))
+i*)
+
+
+(* Translate JProver terms into Coq constructors: *)
+(* The idea is to retrieve it from [rtbl] if it exists indeed, otherwise
+   create one. *)
+let rec constr_of_jterm t =
+  if (JT.is_var_term t) then            (* a variable *)
+     let v = JT.dest_var t in
+     try
+        Hashtbl.find rtbl v
+     with Not_found -> TR.mkVar (N.id_of_string v)
+  else if (JT.is_fun_term t) then       (* a function symbol *)
+     let (f,ts) = JT.dest_fun t in
+     let f' = try Hashtbl.find rtbl f with Not_found -> TR.mkVar (N.id_of_string f) in
+        TR.mkApp (f', Array.of_list (List.map constr_of_jterm ts))
+  else jp_error "constr_of_jterm"
+
+
+(* Coq tactics for Sequent Calculus LJ: *)
+(* Note that for left-rule a name indicating the being applied rule
+   in Coq's Hints is required; for right-rule a name is also needed
+   if it will pass some subterm to the left-hand side.
+   However, all of these can be computed by the path [id] of the being
+   applied rule.
+*)
+
+let assoc_addr = Hashtbl.create 97
+
+let short_addr s =
+  let ad =
+    try
+       Hashtbl.find assoc_addr s
+    with Not_found ->
+       let t = ("jp_H"^(string_of_int (new_acounter()))) in
+          Hashtbl.add assoc_addr s t;
+          t
+  in
+    N.id_of_string ad
+
+(* and-right *)
+let dyn_andr =
+  T.split RA.NoBindings
+
+(* For example, the following implements the [and-left] rule: *)
+let dyn_andl id =   (* [id1]: left child; [id2]: right child *)
+  let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in
+    (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) (T.intros_using [id1;id2]))
+
+let dyn_orr1 =
+  T.left RA.NoBindings
+
+let dyn_orr2 =
+  T.right RA.NoBindings
+
+let dyn_orl id =
+  let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in
+    (TCL.tclTHENS (T.simplest_elim (TR.mkVar (short_addr id)))
+                  [T.intro_using id1; T.intro_using id2])
+
+let dyn_negr id =
+  let id1 = id^"_1_1" in
+     HT.h_intro (short_addr id1)
+
+let dyn_negl id =
+  T.simplest_elim (TR.mkVar (short_addr id))
+
+let dyn_impr id =
+  let id1 = id^"_1_1" in
+     HT.h_intro (short_addr id1)
+
+let dyn_impl id gl =
+  let t = TM.pf_get_hyp_typ gl (short_addr id) in
+    let ct = Reduction.whd_betadeltaiota (Global.env ()) t in   (* unfolding *)
+    let (_,b) = dest_coq_impl ct in
+      let id2 = (short_addr (id^"_1_2")) in
+         (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
+
+let dyn_allr c =       (* [c] must be an eigenvariable which replaces [v] *)
+  HT.h_intro (N.id_of_string c)
+
+(* [id2] is the path of the instantiated term for [id]*)
+let dyn_alll id id2 t gl =
+  let id' = short_addr id in
+  let id2' = short_addr id2 in
+  let ct = TM.pf_get_hyp_typ gl id' in
+    let ct' = Reduction.whd_betadeltaiota (Global.env ()) ct in   (* unfolding *)
+    let ta = sAPP ct' t in
+       TCL.tclTHENS (T.cut ta) [T.intro_using id2'; T.apply (TR.mkVar id')] gl
+
+let dyn_exl id id2 c = (* [c] must be an eigenvariable *)
+  (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id)))
+               (T.intros_using [(N.id_of_string c);(short_addr id2)]))
+
+let dyn_exr t =
+  T.one_constructor 1 (RA.ImplicitBindings [t])
+
+let dyn_falsel = dyn_negl
+
+let dyn_truer =
+  T.one_constructor 1 RA.NoBindings
+
+(* Do the proof by the guidance of JProver. *)
+
+let do_one_step inf =
+  let (rule, (s1, t1), ((s2, t2) as k)) = inf in
+   begin
+(*i   if not (Jterm.is_xnil_term t2) then
+   begin
+      print_string "1: "; JT.print_term stdout t2; print_string "\n";
+      print_string "2: "; print_constr (constr_of_jterm t2); print_string "\n";
+   end;
+i*)
+   match rule with
+     | Andl -> dyn_andl s1
+     | Andr -> dyn_andr
+     | Orl  -> dyn_orl s1
+     | Orr1 -> dyn_orr1
+     | Orr2 -> dyn_orr2
+     | Impr -> dyn_impr s1
+     | Impl -> dyn_impl s1
+     | Negr -> dyn_negr s1
+     | Negl -> dyn_negl s1
+     | Allr -> dyn_allr (JT.dest_var t2)
+     | Alll -> dyn_alll s1 s2 (constr_of_jterm t2)
+     | Exr  -> dyn_exr (constr_of_jterm t2)
+     | Exl  -> dyn_exl s1 s2 (JT.dest_var t2)
+     | Ax -> T.assumption (*i TCL.tclIDTAC i*)
+     | Truer -> dyn_truer
+     | Falsel -> dyn_falsel s1
+     | _ -> jp_error "do_one_step"
+            (* this is impossible *)
+    end
+;;
+
+(* Parameter [tr] is the reconstucted proof tree from output of JProver. *)
+let do_coq_proof tr =
+ let rec rec_do trs =
+    match trs with
+     | JPempty -> TCL.tclIDTAC
+     | JPAx h -> do_one_step h
+     | JPA (h, t) -> TCL.tclTHEN (do_one_step h) (rec_do t)
+     | JPB (h, left, right) -> TCL.tclTHENS (do_one_step h) [rec_do left; rec_do right]
+ in
+    rec_do tr
+
+
+(* Rebuild the proof tree from the output of JProver: *)
+
+(* Since some universal variables are not necessarily first-order,
+   lazy substitution may happen. They are recorded in [rtbl]. *)
+let reg_unif_subst t1 t2 =
+  let (v,_,_) = JT.dest_all t1 in
+    Hashtbl.add rtbl v (TR.mkVar (N.id_of_string (JT.dest_var t2)))
+
+let count_jpbranch one_inf =
+    let (rule, (_, t1), (_, t2)) = one_inf in
+      begin
+      match rule with
+        | Ax -> JP0
+        | Orr1 | Orr2 | Negl | Impr | Alll | Exr | Exl -> JP1
+        | Andr | Orl -> JP2
+        | Negr -> if (JT.is_true_term t1) then JPT else JP1
+        | Andl -> if (JT.is_false_term t1) then JPF else JP1
+        | Impl -> JP2'  (* reverse the sons of [Impl] since [dyn_impl] reverses them *)
+        | Allr -> reg_unif_subst t1 t2; JP1
+        | _ -> jp_error "count_jpbranch"
+      end
+
+let replace_by r = function
+  (rule, a, b) -> (r, a, b)
+
+let rec build_jptree inf =
+    match inf with
+     |  [] -> ([], JPempty)
+     |  h::r ->
+        begin
+          match count_jpbranch h with
+           | JP0 -> (r,JPAx h)
+           | JP1 -> let (r1,left) = build_jptree r in
+                    (r1, JPA(h, left))
+           | JP2 -> let (r1,left) = build_jptree r in
+                    let (r2,right) = build_jptree r1 in
+                    (r2, JPB(h, left, right))
+           | JP2' -> let (r1,left) = build_jptree r in      (* for [Impl] *)
+                    let (r2,right) = build_jptree r1 in
+                    (r2, JPB(h, right, left))
+           | JPT -> let (r1,left) = build_jptree r in       (* right True *)
+                    (r1, JPAx (replace_by Truer h))
+           | JPF -> let (r1,left) = build_jptree r in       (* left False *)
+                    (r1, JPAx (replace_by Falsel h))
+        end
+
+
+(* The main function: *)
+(* [limits] is the multiplicity limit. *)
+let jp limits gls =
+   let concl = TM.pf_concl gls in
+   let ct = concl in
+(*i     print_constr ct; i*)
+     Hashtbl.clear jtbl;    (* empty the hash tables *)
+     Hashtbl.clear rtbl;
+     Hashtbl.clear assoc_addr;
+     let t = parsing ct in
+(*i     JT.print_term stdout t; i*)
+        try
+        let p = (J.prover limits [] t) in
+(*i            print_string "\n";
+            JLogic.print_inf p; i*)
+            let (il,tr) = build_jptree p in
+               if (il = []) then
+               begin
+                  Pp.msgnl (Pp.str "Proof is built.");
+                  do_coq_proof tr gls
+               end
+               else UT.error "Cannot reconstruct proof tree from JProver."
+        with e -> Pp.msgnl (Pp.str "JProver fails to prove this:");
+                  JT.print_error_msg e;
+                  UT.error "JProver terminated."
+
+(* an unfailed generalization procedure *)
+let non_dep_gen b gls =
+  let concl = TM.pf_concl gls in
+      if (not (Termops.dependent b concl)) then
+         T.generalize [b] gls
+      else
+         TCL.tclIDTAC gls
+
+let rec unfail_gen = function
+  | [] -> TCL.tclIDTAC
+  | h::r ->
+     TCL.tclTHEN
+        (TCL.tclORELSE (non_dep_gen h) (TCL.tclIDTAC))
+        (unfail_gen r)
+
+(*
+(* no argument, which stands for no multiplicity limit *)
+let jp gls =
+  let ls = List.map (fst) (TM.pf_hyps_types gls) in
+(*i     T.generalize (List.map TR.mkVar ls) gls i*)
+    (* generalize the context *)
+    TCL.tclTHEN (TCL.tclTRY T.red_in_concl)
+                (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls))
+                             (jp None)) gls
+*)
+(*
+let dyn_jp l gls =
+  assert (l = []);
+  jp
+*)
+
+(* one optional integer argument for the multiplicity *)
+let jpn n gls =
+  let ls = List.map (fst) (TM.pf_hyps_types gls) in
+  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 ]
+END
+
+(*
+TACTIC EXTEND Andl
+  [ "Andl" ident(id)] -> [ ... (Andl id) ... ].
+END
+*)
diff --git a/contrib/jprover/jterm.ml b/contrib/jprover/jterm.ml
new file mode 100644
index 00000000..7fc923a5
--- /dev/null
+++ b/contrib/jprover/jterm.ml
@@ -0,0 +1,872 @@
+open Printf
+open Opname
+open List
+
+(* Definitions of [jterm]: *)
+type  param = param'
+   and operator = operator'
+   and term = term'
+   and bound_term = bound_term'
+   and param' =
+    | Number of int
+    | String of string
+    | Token of string
+    | Var of string
+    | ParamList of param list
+   and operator' = { op_name : opname; op_params : param list }
+   and term' = { term_op : operator; term_terms : bound_term list }
+   and bound_term' = { bvars : string list; bterm : term }
+;;
+
+(* Debugging tools: *)
+(*i*)
+let mbreak s = Format.print_flush (); print_string ("-break at: "^s);
+               Format.print_flush (); let _ = input_char stdin in ()
+(*i*)
+
+type error_msg =
+    | TermMatchError of term * string
+    | StringError of string
+
+exception RefineError of string * error_msg
+
+let ref_raise = function
+ |  RefineError(s,e) -> raise (RefineError(s,e))
+ |  _ -> raise (RefineError ("Jterm", StringError "unexpected error"))
+
+(* Printing utilities: *)
+
+let fprint_str ostream s =
+    let _ = fprintf ostream "%s." s in ostream
+
+let fprint_str_list ostream sl =
+    ignore (List.fold_left fprint_str ostream sl);
+    Format.print_flush ()
+
+let fprint_opname ostream = function
+    { opname_token= tk; opname_name = sl } ->
+        fprint_str_list ostream sl
+
+let rec fprint_param ostream = function
+    | Number n -> fprintf ostream " %d " n
+    | String s -> fprint_str_list ostream [s]
+    | Token t -> fprint_str_list ostream [t]
+    | Var v -> fprint_str_list ostream [v]
+    | ParamList ps -> fprint_param_list ostream ps
+and fprint_param_list ostream = function
+    | [] -> ()
+    | param::r -> fprint_param ostream param;
+                  fprint_param_list ostream r
+;;
+
+let print_strs = fprint_str_list stdout
+
+
+(* Interface to [Jall.ml]: *)
+(* It is extracted from Meta-Prl's standard implementation. *)
+(*c begin of the extraction *)
+
+type term_subst = (string * term) list
+let mk_term op bterms = { term_op = op; term_terms = bterms }
+let make_term x = x (* external [make_term : term' -> term] = "%identity" *)
+let dest_term x = x (* external [dest_term : term -> term'] = "%identity" *)
+let mk_op name params =
+   { op_name = name; op_params = params }
+
+let make_op x = x (* external [make_op : operator' -> operator] = "%identity" *)
+let dest_op x = x (* external [dest_op : operator -> operator'] = "%identity" *)
+let mk_bterm bvars term = { bvars = bvars; bterm = term }
+let make_bterm x = x (* external [make_bterm : bound_term' -> bound_term] = "%identity" *)
+let dest_bterm x = x (* external [dest_bterm : bound_term -> bound_term'] = "%identity" *)
+let make_param x = x (* external [make_param : param' -> param] = "%identity" *)
+let dest_param x = x (* external [dest_param : param -> param'] = "%identity" *)
+
+(*
+ * Operator names.
+ *)
+let opname_of_term = function
+   { term_op = { op_name = name } } ->
+      name
+
+(*
+ * Get the subterms.
+ * None of the subterms should be bound.
+ *)
+let subterms_of_term t =
+   List.map (fun { bterm = t } -> t) t.term_terms
+
+let subterm_count { term_terms = terms } =
+   List.length terms
+
+let subterm_arities { term_terms = terms } =
+   List.map (fun { bvars = vars } -> List.length vars) terms
+
+(*
+ * Manifest terms are injected into the "perv" module.
+ *)
+let xperv = make_opname ["Perv"]
+let sequent_opname = mk_opname "sequent" xperv
+
+(*
+ * Variables.
+ *)
+
+let var_opname = make_opname ["var"]
+
+(*
+ * See if a term is a variable.
+ *)
+let is_var_term = function
+ | { term_op = { op_name = opname; op_params = [Var v] };
+     term_terms = []
+   } when Opname.eq opname var_opname -> true
+ | _ ->
+      false
+
+(*
+ * Destructor for a variable.
+ *)
+let dest_var = function
+ | { term_op = { op_name = opname; op_params = [Var v] };
+     term_terms = []
+   } when Opname.eq opname var_opname -> v
+ | t ->
+       ref_raise(RefineError ("dest_var", TermMatchError (t, "not a variable")))
+(*
+ * Make a variable.
+ *)
+let mk_var_term v =
+   { term_op = { op_name = var_opname; op_params = [Var v] };
+     term_terms = []
+   }
+
+(*
+ * Simple terms
+ *)
+(*
+ * "Simple" terms have no parameters and no binding variables.
+ *)
+let is_simple_term_opname name = function
+ | { term_op = { op_name = name'; op_params = [] };
+     term_terms = bterms
+   } when Opname.eq name' name ->
+      let rec aux = function
+       | { bvars = []; bterm = _ }::t -> aux t
+       | _::t -> false
+       | [] -> true
+      in
+         aux bterms
+ | _ -> false
+
+let mk_any_term op terms =
+   let aux t =
+      { bvars = []; bterm = t }
+   in
+      { term_op = op; term_terms = List.map aux terms }
+
+let mk_simple_term name terms =
+   mk_any_term { op_name = name; op_params = [] } terms
+
+let dest_simple_term = function
+ | ({ term_op = { op_name = name; op_params = [] };
+      term_terms = bterms
+    } : term) as t ->
+      let aux = function
+       | { bvars = []; bterm = t } ->
+            t
+       | _ ->
+            ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "binding vars exist")))
+      in
+         name, List.map aux bterms
+ | t ->
+      ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "params exist")))
+
+let dest_simple_term_opname name = function
+ | ({ term_op = { op_name = name'; op_params = [] };
+      term_terms = bterms
+    } : term) as t ->
+      if Opname.eq name name' then
+         let aux = function
+          | { bvars = []; bterm = t } -> t
+          | _ -> ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "binding vars exist")))
+         in
+            List.map aux bterms
+      else
+         ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "opname mismatch")))
+ | t ->
+      ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "params exist")))
+
+(*
+ * Bound terms.
+ *)
+let mk_simple_bterm bterm =
+   { bvars = []; bterm = bterm }
+
+let dest_simple_bterm = function
+ | { bvars = []; bterm = bterm } ->
+      bterm
+ | _ ->
+      ref_raise(RefineError ("dest_simple_bterm", StringError ("bterm is not simple")))
+
+(* Copy from [term_op_std.ml]: *)
+(*i modified for Jprover, as a patch... i*)
+let mk_string_term opname s =
+   { term_op = { op_name = opname; op_params = [String s] }; term_terms = [] }
+
+(*i let mk_string_term opname s =
+  let new_opname={opname_token=opname.opname_token; opname_name=(List.tl opname.opname_name)@[s]} in
+    { term_op = { op_name = new_opname; op_params = [String (List.hd opname.opname_name)] }; term_terms = [] }
+i*)
+
+(* Copy from [term_subst_std.ml]: *)
+
+let rec free_vars_term gvars bvars = function
+    | { term_op = { op_name = opname; op_params = [Var v] }; term_terms = bterms } when Opname.eq opname var_opname ->
+         (* This is a variable *)
+         let gvars' =
+            if List.mem v bvars or List.mem v gvars then
+               gvars
+            else
+               v::gvars
+         in
+            free_vars_bterms gvars' bvars bterms
+    | { term_terms = bterms } ->
+         free_vars_bterms gvars bvars bterms
+   and free_vars_bterms gvars bvars = function
+    | { bvars = vars; bterm = term}::l ->
+         let bvars' = vars @ bvars in
+         let gvars' = free_vars_term gvars bvars' term in
+            free_vars_bterms gvars' bvars l
+    | [] ->
+         gvars
+
+let free_vars_list = free_vars_term [] []
+
+
+(* Termop: *)
+
+let is_no_subterms_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = []
+   } ->
+      Opname.eq opname' opname
+ | _ ->
+      false
+
+(*
+ * Terms with one subterm.
+ *)
+let is_dep0_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = [] }]
+   } -> Opname.eq opname' opname
+ | _ -> false
+
+let mk_dep0_term opname t =
+   { term_op = { op_name = opname; op_params = [] };
+     term_terms = [{ bvars = []; bterm = t }]
+   }
+
+let dest_dep0_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = []; bterm = t }]
+   } when Opname.eq opname' opname -> t
+ | t -> ref_raise(RefineError ("dest_dep0_term", TermMatchError (t, "not a dep0 term")))
+
+(*
+ * Terms with two subterms.
+ *)
+let is_dep0_dep0_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = [] }; { bvars = [] }]
+   } -> Opname.eq opname' opname
+ | _ -> false
+
+let mk_dep0_dep0_term opname = fun
+   t1 t2 ->
+      { term_op = { op_name = opname; op_params = [] };
+        term_terms = [{ bvars = []; bterm = t1 };
+                      { bvars = []; bterm = t2 }]
+      }
+
+let dest_dep0_dep0_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = []; bterm = t1 };
+                   { bvars = []; bterm = t2 }]
+   } when Opname.eq opname' opname -> t1, t2
+ | t -> ref_raise(RefineError ("dest_dep0_dep0_term", TermMatchError (t, "bad arity")))
+
+(*
+ * Bound term.
+ *)
+
+let is_dep0_dep1_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = [] }; { bvars = [_] }]
+   } when Opname.eq opname' opname -> true
+ | _ -> false
+
+let is_dep0_dep1_any_term = function
+ | { term_op = { op_params = [] };
+     term_terms = [{ bvars = [] }; { bvars = [_] }]
+   } -> true
+ | _ -> false
+
+let mk_dep0_dep1_term opname = fun
+   v t1 t2 -> { term_op = { op_name = opname; op_params = [] };
+                term_terms = [{ bvars = []; bterm = t1 };
+                              { bvars = [v]; bterm = t2 }]
+              }
+
+let dest_dep0_dep1_term opname = function
+ | { term_op = { op_name = opname'; op_params = [] };
+     term_terms = [{ bvars = []; bterm = t1 };
+                   { bvars = [v]; bterm = t2 }]
+   } when Opname.eq opname' opname -> v, t1, t2
+ | t -> ref_raise(RefineError ("dest_dep0_dep1_term", TermMatchError (t, "bad arity")))
+
+let rec smap f = function
+ | [] -> []
+ | (hd::tl) as l ->
+      let hd' = f hd in
+      let tl' = smap f tl in
+      if (hd==hd')&&(tl==tl') then l else hd'::tl'
+
+let rec try_check_assoc v v' = function
+ | [] -> raise Not_found
+ | (v1,v2)::tl ->
+      begin match v=v1, v'=v2 with
+       | true, true -> true
+       | false, false -> try_check_assoc v v' tl
+       | _ -> false
+      end
+
+let rec zip_list l l1 l2 = match (l1,l2) with
+ | (h1::t1), (h2::t2) ->
+      zip_list ((h1,h2)::l) t1 t2
+ | [], [] ->
+      l
+ | _ -> raise (Failure "Term.zip_list")
+
+let rec assoc_in_range eq y = function
+ | (_, y')::tl ->
+      (eq y y') || (assoc_in_range eq y tl)
+ | [] ->
+      false
+
+let rec check_assoc v v' = function
+ | [] -> v=v'
+ | (v1,v2)::tl ->
+      begin match v=v1, v'=v2 with
+       | true, true -> true
+       | false, false -> check_assoc v v' tl
+       | _ -> false
+      end
+
+let rec zip a b = match (a,b) with
+ | (h1::t1), (h2::t2) ->
+      (h1, h2) :: zip t1 t2
+ | [], [] ->
+      []
+ |
+   _ -> raise (Failure "Term.zip")
+
+let rec for_all2 f l1 l2 =
+   match (l1,l2) with
+    | h1::t1, h2::t2 -> for_all2 f t1 t2 & f h1 h2
+    | [], [] -> true
+    | _ -> false
+
+let newname v i =
+   v ^ "_" ^ (string_of_int i)
+
+let rec new_var v avoid i =
+   let v' = newname v i in
+   if avoid v'
+      then new_var v avoid (succ i)
+      else v'
+
+let vnewname v avoid = new_var v avoid 1
+
+let rev_mem a b = List.mem b a
+
+let rec find_index_aux v i = function
+ | h::t ->
+      if h = v then
+         i
+      else
+         find_index_aux v (i + 1) t
+ | [] ->
+      raise Not_found
+
+let find_index v l = find_index_aux v 0 l
+
+let rec remove_elements l1 l2 =
+   match l1, l2 with
+    | flag::ft, h::t ->
+         if flag then
+            remove_elements ft t
+         else
+            h :: remove_elements ft t
+    | _, l ->
+         l
+
+let rec subtract l1 l2 =
+   match l1 with
+    | h::t ->
+         if List.mem h l2 then
+            subtract t l2
+         else
+            h :: subtract t l2
+    | [] ->
+         []
+
+let rec fv_mem fv v =
+      match fv with
+       | [] -> false
+       | h::t ->
+            List.mem v h || fv_mem t v
+
+let rec new_vars fv = function
+    | [] -> []
+    | v::t ->
+         (* Rename the first one, then add it to free vars *)
+         let v' = vnewname v (fv_mem fv) in
+            v'::(new_vars ([v']::fv) t)
+
+let rec fsubtract l = function
+    | [] -> l
+    | h::t ->
+         fsubtract (subtract l h) t
+
+let add_renames_fv r l =
+    let rec aux = function
+    | [] -> l
+    | v::t -> [v]::(aux t)
+   in
+      aux r
+
+let add_renames_terms r l =
+   let rec aux = function
+    | [] -> l
+    | v::t -> (mk_var_term v)::(aux t)
+   in
+      aux r
+
+(*
+ * First order simultaneous substitution.
+ *)
+let rec subst_term terms fv vars = function
+ | { term_op = { op_name = opname; op_params = [Var(v)] }; term_terms = [] } as t
+   when Opname.eq opname var_opname->
+      (* Var case *)
+      begin
+         try List.nth terms (find_index v vars) with
+            Not_found ->
+               t
+      end
+ | { term_op = op; term_terms = bterms } ->
+      (* Other term *)
+      { term_op = op; term_terms = subst_bterms terms fv vars bterms }
+
+and subst_bterms terms fv vars bterms =
+   (* When subst through bterms, catch binding occurrences *)
+   let rec subst_bterm = function
+    | { bvars = []; bterm = term } ->
+         (* Optimize the common case *)
+         { bvars = []; bterm = subst_term terms fv vars term }
+
+    | { bvars = bvars; bterm = term } ->
+         (* First subtract bound instances *)
+         let flags = List.map (function v -> List.mem v bvars) vars in
+         let vars' = remove_elements flags vars in
+         let fv' = remove_elements flags fv in
+         let terms' = remove_elements flags terms in
+
+         (* If any of the binding variables are free, rename them *)
+         let renames = subtract bvars (fsubtract bvars fv') in
+            if renames <> [] then
+               let fv'' = (free_vars_list term)::fv' in
+               let renames' = new_vars fv'' renames in
+                  { bvars = subst_bvars renames' renames bvars;
+                    bterm = subst_term
+                            (add_renames_terms renames' terms')
+                            (add_renames_fv renames' fv')
+                            (renames @ vars')
+                            term
+                  }
+            else
+               { bvars = bvars;
+                 bterm = subst_term terms' fv' vars' term
+               }
+   in
+      List.map subst_bterm bterms
+
+and subst_bvars renames' renames bvars =
+   let subst_bvar v =
+      try List.nth renames' (find_index v renames) with
+         Not_found -> v
+   in
+      List.map subst_bvar bvars
+
+let subst term vars terms =
+      subst_term terms (List.map free_vars_list terms) vars term
+
+(*i bug!!! in the [term_std] module
+      let subst1 t var term =
+      let fv = free_vars_list term in
+      if List.mem var fv then
+         subst_term [term] [fv] [var] t
+      else
+         t
+The following is the correct implementation
+i*)
+
+let subst1 t var term =
+if List.mem var (free_vars_list t) then
+   subst_term [term] [free_vars_list term] [var] t
+else
+   t
+
+let apply_subst t s =
+   let vs,ts = List.split s in
+   subst t vs ts
+
+let rec equal_params p1 p2 =
+   match p1, p2 with
+    | Number n1, Number n2 ->
+         n1 = n2
+    | ParamList pl1, ParamList pl2 ->
+         List.for_all2 equal_params pl1 pl2
+    | _ ->
+         p1 = p2
+
+let rec equal_term vars t t' =
+   match t, t' with
+    | { term_op = { op_name = opname1; op_params = [Var v] };
+        term_terms = []
+      },
+      { term_op = { op_name = opname2; op_params = [Var v'] };
+        term_terms = []
+      } when Opname.eq opname1 var_opname & Opname.eq opname2 var_opname ->
+         check_assoc v v' vars
+    | { term_op = { op_name = name1; op_params = params1 }; term_terms = bterms1 },
+      { term_op = { op_name = name2; op_params = params2 }; term_terms = bterms2 } ->
+         (Opname.eq name1 name2)
+         & (for_all2 equal_params params1 params2)
+         & (equal_bterms vars bterms1 bterms2)
+and equal_bterms vars bterms1 bterms2 =
+   let equal_bterm = fun
+      { bvars = bvars1; bterm = term1 }
+      { bvars = bvars2; bterm = term2 } ->
+         equal_term (zip_list vars bvars1 bvars2) term1 term2
+   in
+      for_all2 equal_bterm bterms1 bterms2
+
+
+let alpha_equal t1 t2 =
+   try equal_term [] t1 t2 with Failure _ -> false
+
+let var_subst t t' v =
+   let { term_op = { op_name = opname } } = t' in
+   let vt = mk_var_term v in
+   let rec subst_term = function
+      { term_op = { op_name = opname'; op_params = params };
+        term_terms = bterms
+      } as t ->
+         (* Check if this is the same *)
+         if Opname.eq opname' opname & alpha_equal t t' then
+            vt
+         else
+            { term_op = { op_name = opname'; op_params = params };
+              term_terms = List.map subst_bterm bterms
+            }
+
+   and subst_bterm { bvars = vars; bterm = term } =
+      if List.mem v vars then
+         let av = vars @ (free_vars_list term) in
+         let v' = vnewname v (fun v -> List.mem v av) in
+         let rename var = if var = v then v' else var in
+         let term = subst1 term v (mk_var_term v') in
+            { bvars =  smap rename vars; bterm = subst_term term }
+      else
+         { bvars = vars; bterm = subst_term term }
+   in
+      subst_term t
+
+let xnil_opname = mk_opname "nil" xperv
+let xnil_term = mk_simple_term xnil_opname []
+let is_xnil_term = is_no_subterms_term xnil_opname
+
+(*c End of the extraction from Meta-Prl *)
+
+(* Huang's modification: *)
+let all_opname = make_opname ["quantifier";"all"]
+let is_all_term = is_dep0_dep1_term all_opname
+let dest_all = dest_dep0_dep1_term all_opname
+let mk_all_term = mk_dep0_dep1_term all_opname
+
+let exists_opname = make_opname ["quantifier";"exst"]
+let is_exists_term = is_dep0_dep1_term exists_opname
+let dest_exists = dest_dep0_dep1_term exists_opname
+let mk_exists_term = mk_dep0_dep1_term exists_opname
+
+let or_opname = make_opname ["connective";"or"]
+let is_or_term = is_dep0_dep0_term or_opname
+let dest_or = dest_dep0_dep0_term or_opname
+let mk_or_term = mk_dep0_dep0_term or_opname
+
+let and_opname = make_opname ["connective";"and"]
+let is_and_term = is_dep0_dep0_term and_opname
+let dest_and = dest_dep0_dep0_term and_opname
+let mk_and_term = mk_dep0_dep0_term and_opname
+
+let cor_opname = make_opname ["connective";"cor"]
+let is_cor_term = is_dep0_dep0_term cor_opname
+let dest_cor = dest_dep0_dep0_term cor_opname
+let mk_cor_term = mk_dep0_dep0_term cor_opname
+
+let cand_opname = make_opname ["connective";"cand"]
+let is_cand_term = is_dep0_dep0_term cand_opname
+let dest_cand = dest_dep0_dep0_term cand_opname
+let mk_cand_term = mk_dep0_dep0_term cand_opname
+
+let implies_opname = make_opname ["connective";"=>"]
+let is_implies_term = is_dep0_dep0_term implies_opname
+let dest_implies = dest_dep0_dep0_term implies_opname
+let mk_implies_term = mk_dep0_dep0_term implies_opname
+
+let iff_opname = make_opname ["connective";"iff"]
+let is_iff_term = is_dep0_dep0_term iff_opname
+let dest_iff = dest_dep0_dep0_term iff_opname
+let mk_iff_term = mk_dep0_dep0_term iff_opname
+
+let not_opname = make_opname ["connective";"not"]
+let is_not_term = is_dep0_term not_opname
+let dest_not = dest_dep0_term not_opname
+let mk_not_term = mk_dep0_term not_opname
+
+let var_ = mk_var_term
+let fun_opname = make_opname ["function"]
+let fun_ f ts = mk_any_term {op_name = fun_opname; op_params = [String f] } ts
+
+let is_fun_term = function
+ | { term_op = { op_name = opname; op_params = [String f] }}
+   when Opname.eq opname fun_opname -> true
+ | _ ->
+      false
+
+let dest_fun = function
+ | { term_op = { op_name = opname; op_params = [String f] }; term_terms = ts}
+   when Opname.eq opname fun_opname -> (f, List.map (fun { bterm = t } -> t) ts)
+ | t ->
+   ref_raise(RefineError ("dest_fun", TermMatchError (t, "not a function symbol")))
+
+let const_ c = fun_ c []
+let is_const_term = function
+ | { term_op = { op_name = opname; op_params = [String f] }; term_terms = [] }
+   when Opname.eq opname fun_opname -> true
+ | _ ->
+      false
+
+let dest_const t =
+  let (n, ts) = dest_fun t in n
+
+let pred_opname = make_opname ["predicate"]
+let pred_ p ts = mk_any_term {op_name = pred_opname; op_params = [String p] } ts
+
+let not_ = mk_not_term
+let and_ = mk_and_term
+let or_ = mk_or_term
+let imp_ = mk_implies_term
+let cand_ = mk_cand_term
+let cor_ = mk_cor_term
+let iff_ = mk_iff_term
+let nil_term = {term_op={op_name=nil_opname; op_params=[]}; term_terms=[] }
+let forall v t = mk_all_term v nil_term t
+let exists v t= mk_exists_term v nil_term t
+let rec wbin op = function
+  |  [] ->  raise (Failure "Term.wbin")
+  |  [t] -> t
+  |  t::r -> op t (wbin op r)
+
+let wand_ = wbin and_
+let wor_ = wbin or_
+let wimp_ = wbin imp_
+
+(*i let true_opname = make_opname ["bool";"true"]
+let is_true_term = is_no_subterms_term true_opname
+let true_ = mk_simple_term true_opname []
+let false_ = not_ true_
+
+let is_false_term t =
+  if is_not_term t then
+  let t1 = dest_not t in
+    is_true_term t1
+  else
+    false
+i*)
+
+let dummy_false_ = mk_simple_term (make_opname ["bool";"false"]) []
+let dummy_true_ = mk_simple_term (make_opname ["bool";"true"]) []
+let false_ = and_ (dummy_false_) (not_ dummy_false_)
+let true_ = not_ (and_ (dummy_true_) (not_ dummy_true_))
+
+let is_false_term t =
+  if (alpha_equal t false_) then true
+  else false
+
+let is_true_term t =
+  if (alpha_equal t true_) then true
+  else false
+
+(* Print a term [t] via the [ostream]: *)
+let rec fprint_term ostream t prec =
+  let l_print op_prec =
+      if (prec > op_prec) then fprintf ostream "(" in
+  let r_print op_prec =
+      if (prec > op_prec) then fprintf ostream ")" in
+  if is_false_term t then                       (* false *)
+      fprint_str_list ostream ["False"]
+  else if is_true_term t then                   (* true *)
+      fprint_str_list ostream ["True"]
+  else if is_all_term t then                    (* for all *)
+      let v, t1, t2 = dest_all t in
+          fprint_str_list ostream ["A."^v];
+          fprint_term ostream t2 4
+  else if is_exists_term t then                 (* exists *)
+      let v, t1, t2 = dest_exists t in
+          fprint_str_list ostream ["E."^v];
+          fprint_term ostream t2 4              (* implication *)
+  else if is_implies_term t then
+      let t1, t2 = dest_implies t in
+          l_print 0;
+          fprint_term ostream t1 1;
+          fprint_str_list ostream ["=>"];
+          fprint_term ostream t2 0;
+          r_print 0
+  else if is_and_term t then                    (* logical and *)
+      let t1, t2 = dest_and t in
+          l_print 3;
+          fprint_term ostream t1 3;
+          fprint_str_list ostream ["&"];
+          fprint_term ostream t2 3;
+          r_print 3
+  else if is_or_term t then                     (* logical or *)
+      let t1, t2 = dest_or t in
+          l_print 2;
+          fprint_term ostream t1 2;
+          fprint_str_list ostream ["|"];
+          fprint_term ostream t2 2;
+          r_print 2
+  else if is_not_term t then                    (* logical not *)
+      let t2 = dest_not t in
+          fprint_str_list ostream ["~"];
+          fprint_term ostream t2 4              (* nil term *)
+  else if is_xnil_term t then
+          fprint_str_list ostream ["NIL"]
+  else match t with                             (* other cases *)
+    { term_op = { op_name = opname; op_params = opparm }; term_terms = bterms} ->
+        if (Opname.eq opname pred_opname) || (Opname.eq opname fun_opname) then
+        begin
+           fprint_param_list ostream opparm;
+           if bterms != [] then
+           begin
+              fprintf ostream "(";
+              fprint_bterm_list ostream prec bterms;
+              fprintf ostream ")";
+           end
+        end else
+        begin
+           fprintf ostream "[";
+(*           fprint_opname ostream opname;
+           fprintf ostream ": "; *)
+           fprint_param_list ostream opparm;
+           if bterms != [] then
+           begin
+              fprintf ostream "(";
+              fprint_bterm_list ostream prec bterms;
+              fprintf ostream ")";
+           end;
+           fprintf ostream "]"
+        end
+and fprint_bterm_list ostream prec = function
+   |  [] -> ()
+   | {bvars=bv; bterm=bt}::r ->
+        fprint_str_list ostream bv;
+        fprint_term ostream bt prec;
+        if (r<>[]) then fprint_str_list ostream [","];
+        fprint_bterm_list ostream prec r
+;;
+
+
+let print_term ostream t =
+    Format.print_flush ();
+    fprint_term ostream t 0;
+    Format.print_flush ()
+
+let print_error_msg = function
+    | RefineError(s,e) -> print_string ("(module "^s^") ");
+      begin
+      match e with
+       | TermMatchError(t,s) -> print_term stdout t; print_string (s^"\n")
+       | StringError s -> print_string (s^"\n")
+      end
+    | ue -> print_string "Unexpected error for Jp.\n";
+           raise ue
+
+
+(* Naive implementation for [jterm] substitution, unification, etc.: *)
+let substitute subst term =
+    apply_subst term subst
+
+(* A naive unification algorithm: *)
+let compsubst subst1 subst2 =
+  (List.map (fun (v, t) -> (v, substitute subst1 t)) subst2) @ subst1
+;;
+
+let rec extract_terms = function
+    | [] -> []
+    | h::r -> let {bvars=_; bterm=bt}=h in bt::extract_terms r
+
+(* Occurs check: *)
+let occurs v t =
+  let rec occur_rec t =
+    if is_var_term t then v=dest_var t
+    else let { term_op = _ ; term_terms = bterms} = t in
+         let sons = extract_terms bterms in
+            List.exists occur_rec sons
+  in
+  occur_rec t
+
+(* The naive unification algorithm: *)
+let rec unify2 (term1,term2) =
+  if is_var_term term1 then
+    if equal_term [] term1 term2 then []
+    else let v1 = dest_var term1 in
+            if occurs v1 term2 then raise (RefineError ("unify1", StringError ("1")))
+            else [v1,term2]
+  else if is_var_term term2 then
+    let v2 = dest_var term2 in
+       if occurs v2 term1 then raise (RefineError ("unify2", StringError ("2")))
+       else [v2,term1]
+  else
+      let { term_op = { op_name = opname1; op_params = params1 };
+            term_terms = bterms1
+          } = term1
+      in
+      let { term_op = { op_name = opname2; op_params = params2 };
+            term_terms = bterms2
+          } = term2
+      in
+         if Opname.eq opname1 opname2 & params1 = params2 then
+            let sons1 = extract_terms bterms1
+            and sons2 = extract_terms bterms2 in
+            List.fold_left2
+               (fun s t1 t2 -> compsubst
+                               (unify2 (substitute s t1, substitute s t2)) s)
+               [] sons1 sons2
+         else raise (RefineError ("unify3", StringError ("3")))
+
+let unify term1 term2 = unify2 (term1, term2)
+let unify_mm term1 term2 _ = unify2 (term1, term2)
diff --git a/contrib/jprover/jterm.mli b/contrib/jprover/jterm.mli
new file mode 100644
index 00000000..0bc42010
--- /dev/null
+++ b/contrib/jprover/jterm.mli
@@ -0,0 +1,110 @@
+(* This module is modified and extracted from Meta-Prl. *)
+
+(* Definitions of [jterm]: *)
+type param = param'
+and operator = operator'
+and term = term'
+and bound_term = bound_term'
+and param' =
+  | Number of int
+  | String of string
+  | Token of string
+  | Var of string
+  | ParamList of param list
+and operator' = { op_name : Opname.opname; op_params : param list; } 
+and term' = { term_op : operator; term_terms : bound_term list; } 
+and bound_term' = { bvars : string list; bterm : term; } 
+type term_subst = (string * term) list
+
+type error_msg = TermMatchError of term * string | StringError of string
+
+exception RefineError of string * error_msg
+
+(* Collect free variables: *)
+val free_vars_list : term -> string list
+
+(* Substitutions: *)
+val subst_term : term list -> string list list -> string list -> term -> term
+val subst : term -> string list -> term list -> term
+val subst1 : term -> string -> term -> term
+val var_subst : term -> term -> string -> term
+val apply_subst : term -> (string * term) list -> term
+
+(* Unification: *)
+val unify_mm : term -> term -> 'a -> (string * term) list
+
+val xnil_term : term'
+
+(* Testing functions: *)
+val is_xnil_term : term' -> bool
+val is_var_term : term' -> bool
+val is_true_term : term' -> bool
+val is_false_term : term' -> bool
+val is_all_term : term' -> bool
+val is_exists_term : term' -> bool
+val is_or_term : term' -> bool
+val is_and_term : term' -> bool
+val is_cor_term : term' -> bool
+val is_cand_term : term' -> bool
+val is_implies_term : term' -> bool
+val is_iff_term : term' -> bool
+val is_not_term : term' -> bool
+val is_fun_term : term -> bool
+val is_const_term : term -> bool
+
+
+(* Constructors for [jterms]: *)
+val var_ : string -> term'
+val fun_ : string -> term list -> term'
+val const_ : string -> term'
+val pred_ : string -> term list -> term'
+val not_ : term -> term'
+val and_ : term -> term -> term'
+val or_ : term -> term -> term'
+val imp_ : term -> term -> term'
+val cand_ : term -> term -> term'
+val cor_ : term -> term -> term'
+val iff_ : term -> term -> term'
+val false_ : term'
+val true_ : term'
+val nil_term : term'
+val forall : string -> term -> term'
+val exists : string -> term -> term'
+
+
+(* Destructors for [jterm]: *)
+val dest_var : term -> string
+val dest_fun : term -> string * term list
+val dest_const : term -> string
+val dest_not : term -> term
+val dest_iff : term -> term * term
+val dest_implies : term -> term * term
+val dest_cand : term -> term * term
+val dest_cor : term -> term * term
+val dest_and : term -> term * term
+val dest_or : term -> term * term
+val dest_exists : term -> string * term * term
+val dest_all : term -> string * term * term
+
+(* Wide-logical connectives: *)
+val wand_ : term list -> term
+val wor_ : term list -> term
+val wimp_ : term list -> term
+
+(* Printing and debugging tools: *)
+val fprint_str_list : out_channel -> string list -> unit
+val mbreak : string -> unit
+val print_strs : string list -> unit
+val print_term : out_channel -> term -> unit
+val print_error_msg : exn -> unit
+
+(* Other exported functions for [jall.ml]: *)
+val make_term : 'a -> 'a
+val dest_term : 'a -> 'a
+val make_op : 'a -> 'a
+val dest_op : 'a -> 'a
+val make_bterm : 'a -> 'a
+val dest_bterm : 'a -> 'a
+val dest_param : 'a -> 'a
+val mk_var_term : string -> term'
+val mk_string_term : Opname.opname -> string -> term'
diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml
new file mode 100644
index 00000000..2295e62c
--- /dev/null
+++ b/contrib/jprover/jtunify.ml
@@ -0,0 +1,507 @@
+(*
+ * Unification procedures for JProver. See jall.mli for more
+ * information on JProver.
+ *
+ * ----------------------------------------------------------------
+ *
+ * This file is part of MetaPRL, a modular, higher order
+ * logical framework that provides a logical programming
+ * environment for OCaml and other languages.
+ *
+ * See the file doc/index.html for information on Nuprl,
+ * OCaml, and more information about this system.
+ *
+ * Copyright (C) 2000 Stephan Schmitt
+ *
+ * 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 (at your option) 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * Author: Stephan Schmitt <schmitts@spmail.slu.edu>
+ * Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
+ *)
+
+exception Not_unifiable
+exception Failed
+
+let jprover_bug = Invalid_argument "Jprover bug (Jtunify module)"
+
+(* ************ T-STRING UNIFICATION *********************************)
+
+
+(* ******* printing ********** *)
+
+let rec list_to_string s =
+   match s with
+      [] -> ""
+    | f::r ->
+         f^"."^(list_to_string r)
+
+let rec print_eqlist eqlist =
+   match eqlist with
+      [] ->
+         print_endline ""
+    | (atnames,f)::r ->
+         let (s,t) = f in
+         let ls = list_to_string s
+         and lt = list_to_string t in
+         begin
+            print_endline ("Atom names: "^(list_to_string atnames));
+            print_endline (ls^" = "^lt);
+            print_eqlist r
+         end
+
+let print_equations eqlist =
+   begin
+      Format.open_box 0;
+      Format.force_newline ();
+      print_endline "Equations:";
+      print_eqlist eqlist;
+      Format.force_newline ();
+   end
+
+let rec print_subst sigma =
+   match sigma with
+      [] ->
+         print_endline ""
+    | f::r ->
+         let (v,s) = f in
+         let ls = list_to_string s in
+         begin
+            print_endline (v^" = "^ls);
+            print_subst r
+         end
+
+let print_tunify sigma =
+   let (n,subst) = sigma in
+   begin
+      print_endline " ";
+      print_endline ("MaxVar = "^(string_of_int (n-1)));
+      print_endline " ";
+      print_endline "Substitution:";
+      print_subst subst;
+      print_endline " "
+   end
+
+ (*****************************************************)
+
+let is_const name  =
+  (String.get name 0) = 'c'
+
+let is_var name  =
+  (String.get name 0) = 'v'
+
+let r_1 s ft rt =
+   (s = []) && (ft = []) && (rt = [])
+
+let r_2 s ft rt =
+   (s = []) && (ft = []) && (List.length rt >= 1)
+
+let r_3 s ft rt =
+   ft=[] && (List.length s >= 1) && (List.length rt >= 1) && (List.hd s = List.hd rt)
+
+let r_4 s ft rt =
+   ft=[]
+      && (List.length s >= 1)
+      && (List.length rt >= 1)
+      && is_const (List.hd s)
+      && is_var (List.hd rt)
+
+let r_5 s ft rt =
+   rt=[]
+      && (List.length s >= 1)
+      && is_var (List.hd s)
+
+let r_6 s ft rt =
+   ft=[]
+      && (List.length s >= 1)
+      && (List.length rt >= 1)
+      && is_var (List.hd s)
+      && is_const (List.hd rt)
+
+let r_7 s ft rt =
+   List.length s >= 1
+      && (List.length rt >= 2)
+      && is_var (List.hd s)
+      && is_const (List.hd rt)
+      && is_const (List.hd (List.tl rt))
+
+let r_8 s ft rt =
+  ft=[]
+    && List.length s >= 2
+    && List.length rt >= 1
+    && let v = List.hd s
+       and v1 = List.hd rt in
+         (is_var v) & (is_var v1) & (v <> v1)
+
+let r_9 s ft rt =
+   (List.length s >= 2) && (List.length ft >= 1) && (List.length rt >= 1)
+      && let v = (List.hd s)
+         and v1 = (List.hd rt) in
+         (is_var v) & (is_var v1) & (v <> v1)
+
+let r_10 s ft rt =
+   (List.length s >= 1) && (List.length rt >= 1)
+   && let v = List.hd s
+      and x = List.hd rt in
+      (is_var v) && (v <> x)
+      && (((List.tl s) =[]) or (is_const x) or ((List.tl rt) <> []))
+
+let rec com_subst slist ((ov,ovlist) as one_subst) =
+   match slist with
+      [] -> raise jprover_bug
+    | f::r ->
+         if f = ov then
+            (ovlist @ r)
+         else
+            f::(com_subst r one_subst)
+
+let rec combine subst ((ov,oslist) as one_subst)  =
+   match subst with
+      [] -> []
+    | ((v, slist) as f) :: r ->
+         let rest_combine = (combine r one_subst) in
+         if (List.mem ov slist) then  (* subst assumed to be idemponent *)
+            let com_element = com_subst slist one_subst in
+            ((v,com_element)::rest_combine)
+         else
+            (f::rest_combine)
+
+let compose ((n,subst) as sigma) ((ov,oslist) as one_subst) =
+   let com = combine subst one_subst in
+(* begin
+   print_endline "!!!!!!!!!test print!!!!!!!!!!";
+   print_subst [one_subst];
+   print_subst subst;
+   print_endline "!!!!!!!!! END test print!!!!!!!!!!";
+*)
+   if List.mem one_subst subst then
+      (n,com)
+   else
+(* ov may multiply as variable in subst with DIFFERENT values *)
+(* in order to avoid explicit atom instances!!! *)
+      (n,(com @ [one_subst]))
+(* end *)
+
+let rec apply_element fs ft (v,slist) =
+   match (fs,ft) with
+      ([],[]) ->
+         ([],[])
+    | ([],(ft_first::ft_rest)) ->
+         let new_ft_first =
+            if ft_first = v then
+               slist
+            else
+               [ft_first]
+         in
+         let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in
+         (emptylist,(new_ft_first @ new_ft_rest))
+    | ((fs_first::fs_rest),[]) ->
+         let new_fs_first =
+            if fs_first = v then
+               slist
+            else
+               [fs_first]
+         in
+         let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in
+         ((new_fs_first @ new_fs_rest),emptylist)
+    | ((fs_first::fs_rest),(ft_first::ft_rest)) ->
+         let new_fs_first =
+            if fs_first = v then
+               slist
+            else
+               [fs_first]
+         and new_ft_first =
+            if ft_first = v then
+               slist
+            else
+               [ft_first]
+         in
+         let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in
+         ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest))
+
+let rec shorten us ut =
+   match (us,ut) with
+      ([],_) | (_,[])  -> (us,ut) (*raise jprover_bug*)
+    | ((fs::rs),(ft::rt)) ->
+         if fs = ft then
+            shorten rs rt
+         else
+            (us,ut)
+
+let rec apply_subst_list eq_rest (v,slist) =
+   match eq_rest with
+      [] ->
+         (true,[])
+    | (atomnames,(fs,ft))::r ->
+         let (n_fs,n_ft) = apply_element fs ft (v,slist) in
+         let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *)
+         match (new_fs,new_ft) with
+            [],[] ->
+               let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+               (bool,((atomnames,([],[]))::new_eq_rest))
+          | [],(fft::rft) ->
+               if (is_const fft) then
+                  (false,[])
+               else
+                  let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                  (bool,((atomnames,([],new_ft))::new_eq_rest))
+          | (ffs::rfs),[] ->
+               if (is_const ffs) then
+                  (false,[])
+               else
+                  let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                  (bool,((atomnames,(new_fs,[]))::new_eq_rest))
+          | (ffs::rfs),(fft::rft) ->
+               if (is_const ffs) & (is_const fft) then
+                  (false,[])
+        (* different first constants cause local fail *)
+               else
+        (* at least one of firsts is a variable *)
+                  let (bool,new_eq_rest) = apply_subst_list r (v,slist) in
+                  (bool,((atomnames,(new_fs,new_ft))::new_eq_rest))
+
+let apply_subst eq_rest (v,slist) atomnames =
+   if (List.mem v atomnames) then (* don't apply subst to atom variables !! *)
+      (true,eq_rest)
+   else
+      apply_subst_list eq_rest (v,slist)
+
+
+(* let all_variable_check eqlist = false   needs some discussion with Jens! -- NOT done *)
+
+(*
+ let rec all_variable_check eqlist =
+  match eqlist with
+    [] -> true
+   | ((_,(fs,ft))::rest_eq) ->
+     if (fs <> []) & (ft <> []) then
+      let fs_first = List.hd fs
+      and ft_first = List.hd ft
+      in
+      if (is_const fs_first) or (is_const ft_first) then
+        false
+      else
+        all_variable_check rest_eq
+     else
+      false
+*)
+
+let rec  tunify_list eqlist init_sigma =
+   let rec tunify atomnames fs ft rt rest_eq sigma =
+      let apply_r1 fs ft rt rest_eq sigma =
+      (* print_endline "r1"; *)
+         tunify_list rest_eq sigma
+
+      in
+      let apply_r2 fs ft rt rest_eq sigma =
+      (* print_endline "r2"; *)
+         tunify atomnames rt fs ft rest_eq sigma
+
+      in
+      let apply_r3 fs ft rt rest_eq sigma =
+      (* print_endline "r3"; *)
+         let rfs =  (List.tl fs)
+         and rft =  (List.tl rt) in
+         tunify atomnames rfs ft rft rest_eq sigma
+
+      in
+      let apply_r4 fs ft rt rest_eq sigma =
+      (* print_endline "r4"; *)
+         tunify atomnames rt ft fs rest_eq sigma
+
+      in
+      let apply_r5 fs ft rt rest_eq sigma =
+      (* print_endline "r5"; *)
+         let v = (List.hd fs) in
+         let new_sigma = compose sigma (v,ft) in
+         let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in
+         if (bool=false) then
+            raise Not_unifiable
+         else
+            tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma
+
+      in
+      let apply_r6 fs ft rt rest_eq sigma =
+      (* print_endline "r6"; *)
+         let v = (List.hd fs) in
+         let new_sigma = (compose sigma (v,[])) in
+         let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in
+         if (bool=false) then
+            raise Not_unifiable
+         else
+            tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma
+
+      in
+      let apply_r7 fs ft rt rest_eq sigma =
+      (* print_endline "r7"; *)
+         let v = (List.hd fs)
+         and c1 = (List.hd rt)
+         and c2t =(List.tl rt) in
+         let new_sigma = (compose sigma (v,(ft @ [c1]))) in
+         let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in
+         if bool=false then
+            raise Not_unifiable
+         else
+            tunify atomnames (List.tl fs) []  c2t new_rest_eq new_sigma
+      in
+      let apply_r8 fs ft rt rest_eq sigma =
+      (* print_endline "r8"; *)
+         tunify atomnames  rt [(List.hd fs)] (List.tl fs) rest_eq sigma
+
+      in
+      let apply_r9 fs ft rt rest_eq sigma =
+      (* print_endline "r9"; *)
+         let v = (List.hd fs)
+         and (max,subst) = sigma in
+         let v_new = ("vnew"^(string_of_int max)) in
+         let new_sigma = (compose ((max+1),subst) (v,(ft @ [v_new]))) in
+         let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in
+         if (bool=false) then
+            raise Not_unifiable
+         else
+            tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma
+
+      in
+      let apply_r10 fs ft rt rest_eq sigma =
+      (* print_endline "r10"; *)
+         let x = List.hd rt in
+         tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma
+
+      in
+      if r_1 fs ft rt then
+         apply_r1 fs ft rt rest_eq sigma
+      else if r_2 fs ft rt then
+         apply_r2 fs ft rt rest_eq sigma
+      else if r_3 fs ft rt then
+         apply_r3 fs ft rt rest_eq sigma
+      else if r_4 fs ft rt then
+         apply_r4 fs ft rt rest_eq sigma
+      else if r_5 fs ft rt then
+         apply_r5 fs ft rt rest_eq sigma
+      else if r_6 fs ft rt then
+         (try
+            apply_r6 fs ft rt rest_eq sigma
+         with Not_unifiable ->
+            if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *)
+               (try
+                  apply_r7 fs ft rt rest_eq sigma
+               with Not_unifiable ->
+                  apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *)
+               )
+            else
+      (* r10 could be represented only once if we would try it before r7.*)
+      (* but looking at the transformation rules, r10 should be tried at last in any case *)
+               apply_r10 fs ft rt rest_eq sigma  (* r10 always applicable r6 was *)
+         )
+      else if r_7 fs ft rt then  (* not r6 and r7 possible if z <> [] *)
+         (try
+            apply_r7 fs ft rt rest_eq sigma
+         with Not_unifiable ->
+            apply_r10 fs ft rt rest_eq sigma  (* r10 always applicable if r7 was *)
+         )
+      else if r_8 fs ft rt then
+         (try
+            apply_r8 fs ft rt rest_eq sigma
+         with Not_unifiable ->
+            if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *)
+               apply_r10 fs ft rt rest_eq sigma
+            else
+               raise Not_unifiable (* simply back propagation *)
+         )
+      else if r_9 fs ft rt then
+         (try
+            apply_r9 fs ft rt rest_eq sigma
+         with Not_unifiable ->
+            if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *)
+               apply_r10 fs ft rt rest_eq sigma
+            else
+               raise Not_unifiable (* simply back propagation *)
+         )
+      else if r_10 fs ft rt then  (* not ri, i<10, and r10 possible if for instance *)
+                         (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *)
+         apply_r10 fs ft rt rest_eq sigma
+      else  (* NO rule applicable *)
+         raise Not_unifiable
+   in
+   match eqlist with
+      [] ->
+         init_sigma
+    | f::rest_eq ->
+         let (atomnames,(fs,ft)) = f in
+         tunify atomnames fs [] ft rest_eq init_sigma
+
+let rec test_apply_eq atomnames eqs eqt subst =
+   match subst with
+      [] -> (eqs,eqt)
+    | (f,flist)::r ->
+         let (first_appl_eqs,first_appl_eqt) =
+            if List.mem f atomnames then
+               (eqs,eqt)
+            else
+               (apply_element eqs eqt (f,flist))
+         in
+         test_apply_eq atomnames first_appl_eqs first_appl_eqt r
+
+let rec test_apply_eqsubst eqlist subst =
+   match eqlist with
+      [] -> []
+    | f::r ->
+         let (atomnames,(eqs,eqt)) = f in
+         let applied_element  = test_apply_eq atomnames eqs eqt subst in
+         (atomnames,applied_element)::(test_apply_eqsubst r subst)
+
+let ttest us ut ns nt eqlist orderingQ atom_rel =
+   let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *)
+                                           (* to eliminate common beginning *)
+   let new_element = ([ns;nt],(short_us,short_ut)) in
+   let full_eqlist =
+      if List.mem new_element eqlist then
+         eqlist
+      else
+         new_element::eqlist
+   in
+   let sigma = tunify_list full_eqlist (1,[]) in
+   let (n,subst) = sigma in
+   let test_apply  = test_apply_eqsubst full_eqlist subst in
+   begin
+      print_endline "";
+      print_endline "Final equations:";
+      print_equations full_eqlist;
+      print_endline "";
+      print_endline "Final substitution:";
+      print_tunify sigma;
+      print_endline "";
+      print_endline "Applied equations:";
+      print_equations test_apply
+   end
+
+let do_stringunify us ut ns nt equations =
+   let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *)
+   let new_element = ([ns;nt],(short_us,short_ut)) in
+   let full_eqlist =
+      if List.mem new_element equations then
+         equations
+      else
+         new_element::equations
+   in
+(*  print_equations full_eqlist; *)
+   (try
+      let new_sigma = tunify_list full_eqlist (1,[]) in
+      (new_sigma,(1,full_eqlist))
+   with Not_unifiable ->
+      raise Failed            (* new connection please *)
+   )
+
+
+(* type of one unifier: int * (string * string) list  *)
diff --git a/contrib/jprover/jtunify.mli b/contrib/jprover/jtunify.mli
new file mode 100644
index 00000000..0aabc79e
--- /dev/null
+++ b/contrib/jprover/jtunify.mli
@@ -0,0 +1,35 @@
+exception Not_unifiable
+exception Failed
+
+(* Utilities *)
+
+val is_const : string -> bool
+val is_var : string -> bool
+val r_1 : 'a list -> 'b list -> 'c list -> bool
+val r_2 : 'a list -> 'b list -> 'c list -> bool
+val r_3 : 'a list -> 'b list -> 'a list -> bool
+val r_4 : string list -> 'a list -> string list -> bool
+val r_5 : string list -> 'a -> 'b list -> bool
+val r_6 : string list -> 'a list -> string list -> bool
+val r_7 : string list -> 'a -> string list -> bool
+val r_8 : string list -> 'a list -> string list -> bool
+val r_9 : string list -> 'a list -> string list -> bool
+val r_10 : string list -> 'a -> string list -> bool
+val com_subst : 'a list -> 'a * 'a list -> 'a list
+
+(* Debugging *)
+
+val print_equations : (string list * (string list * string list)) list -> unit
+
+val print_tunify : int * (string * string list) list -> unit
+
+(* Main function *)
+
+val do_stringunify : string list ->
+                     string list ->
+                     string ->
+                     string ->
+                     (string list * (string list * string list)) list ->
+                     (int * (string * string list) list) *                 (* unifier *)
+                     (int * ((string list * (string list * string list)) list))    (* applied new eqlist *)
+
diff --git a/contrib/jprover/opname.ml b/contrib/jprover/opname.ml
new file mode 100644
index 00000000..d0aa9046
--- /dev/null
+++ b/contrib/jprover/opname.ml
@@ -0,0 +1,90 @@
+open Printf
+
+type token = string
+type atom = string list
+
+let opname_token = String.make 4 (Char.chr 0)
+
+type opname =
+   { mutable opname_token : token;
+     mutable opname_name : string list
+   }
+
+let (optable : (string list, opname) Hashtbl.t) = Hashtbl.create 97
+
+(* * Constructors.*)
+let nil_opname = { opname_token = opname_token; opname_name = [] }
+
+let _ = Hashtbl.add optable [] nil_opname
+
+let rec mk_opname s ({ opname_token = token; opname_name = name } as opname) =
+   if token == opname_token then
+      let name = s :: name in
+         try Hashtbl.find optable name with
+            Not_found ->
+               let op = { opname_token = opname_token; opname_name = name } in
+                  Hashtbl.add optable name op;
+                  op
+   else
+      mk_opname s (normalize_opname opname)
+
+and make_opname = function
+ | [] ->
+      nil_opname
+ | h :: t ->
+      mk_opname h (make_opname t)
+
+and normalize_opname opname =
+   if opname.opname_token == opname_token then
+      (* This opname is already normalized *)
+      opname
+   else
+      let res = make_opname opname.opname_name
+      in
+         opname.opname_name <- res.opname_name;
+         opname.opname_token <- opname_token;
+         res
+
+(*  * Atoms are the inner string list. *)
+let intern opname =
+   if opname.opname_token == opname_token then
+      opname.opname_name
+   else
+      let name = (normalize_opname opname).opname_name in
+         opname.opname_token <- opname_token;
+         opname.opname_name <- name;
+         name
+
+let eq_inner op1 op2 =
+   op1.opname_name <- (normalize_opname op1).opname_name;
+   op1.opname_token <- opname_token;
+   op2.opname_name <- (normalize_opname op2).opname_name;
+   op2.opname_token <- opname_token;
+   op1.opname_name == op2.opname_name
+
+let eq op1 op2 =
+   (op1.opname_name == op2.opname_name)
+   or ((op1.opname_token != opname_token or op2.opname_token != opname_token) & eq_inner op1 op2)
+
+(* * Destructor. *)
+let dst_opname = function
+ |  { opname_name = n :: name } -> n, { opname_token = opname_token; opname_name = name }
+ | _ -> raise (Invalid_argument "dst_opname")
+
+let dest_opname { opname_name = name } =
+   name
+
+let string_of_opname op =
+   let rec flatten = function
+    | [] ->
+         ""
+    | h::t ->
+         let rec collect s = function
+          | h::t ->
+               collect (h ^ "!" ^ s) t
+          | [] ->
+               s
+         in
+            collect h t
+   in
+      flatten op.opname_name
diff --git a/contrib/jprover/opname.mli b/contrib/jprover/opname.mli
new file mode 100644
index 00000000..56bf84e2
--- /dev/null
+++ b/contrib/jprover/opname.mli
@@ -0,0 +1,15 @@
+(* This module is extracted from Meta-Prl. *)
+
+type token = string
+and atom = string list
+val opname_token : token
+type opname = {
+  mutable opname_token : token;
+  mutable opname_name : string list;
+} 
+val nil_opname : opname
+val mk_opname : string -> opname -> opname
+val make_opname : string list -> opname
+val eq : opname -> opname -> bool
+val dest_opname : opname -> string list
+val string_of_opname : opname -> string
diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v
new file mode 100755
index 00000000..e72dcec2
--- /dev/null
+++ b/contrib/omega/Omega.v
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:30:12 herbelin Exp $ *)
+
+(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
+Require Export ZArith_base.
+Require Export OmegaLemmas.
+
+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.
+
+(*
+(* The constant minus is required in coq_omega.ml *)
+Require Minus.
+*)
+
+Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith.
+Hint Extern 10 (_ <= _) => abstract omega: zarith.
+Hint Extern 10 (_ < _) => abstract omega: zarith.
+Hint Extern 10 (_ >= _) => abstract omega: zarith.
+Hint Extern 10 (_ > _) => abstract omega: zarith.
+
+Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith.
+Hint Extern 10 (~ _ <= _) => abstract omega: zarith.
+Hint Extern 10 (~ _ < _) => abstract omega: zarith.
+Hint Extern 10 (~ _ >= _) => abstract omega: zarith.
+Hint Extern 10 (~ _ > _) => abstract omega: zarith.
+
+Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith.
+Hint Extern 10 (_ <= _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ < _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ >= _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ > _)%Z => abstract omega: zarith.
+
+Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith.
+
+Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file
diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v
new file mode 100644
index 00000000..6f0ea2c6
--- /dev/null
+++ b/contrib/omega/OmegaLemmas.v
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:30:12 herbelin Exp $ i*)
+
+Require Import ZArith_base.
+
+(** These are specific variants of theorems dedicated for the Omega tactic *)
+
+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.
+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.
+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.
+
+intros x y k H1 H2 H3; apply (Zmult_integral_l k);
+ [ unfold not in |- *; intros H4; absurd (k > 0)%Z;
+    [ 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.
+
+unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0)%Z;
+ [ intros H4; cut (0 <= z * y + x)%Z;
+    [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
+       absurd (z * y + x > 0)%Z;
+       [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
+       | apply Zle_gt_trans with x;
+          [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
+             apply Zplus_le_compat_r; rewrite Zmult_comm; 
+             generalize H4; unfold Zgt in |- *; case y;
+             [ simpl in |- *; intros H7; discriminate H7
+             | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
+                unfold Zle in |- *; rewrite Zcompare_mult_compat; 
+                exact H6
+             | simpl in |- *; intros p H7; discriminate H7 ]
+          | assumption ] ]
+    | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ]
+ | 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.
+
+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.
+
+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.
+
+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.
+
+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;
+       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.
+
+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.
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith.
+Qed.
+
+Lemma OMEGA11 :
+ forall v1 c1 l1 l2 k1:Z,
+   ((v1 * c1 + l1) * k1 + l2)%Z = (v1 * (c1 * k1) + (l1 * k1 + l2))%Z.
+
+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 OMEGA12 :
+ forall v2 c2 l1 l2 k2:Z,
+   (l1 + (v2 * c2 + l2) * k2)%Z = (v2 * (c2 * k2) + (l1 + l2 * k2))%Z.
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; 
+ rewrite Zplus_permute; trivial with arith.
+Qed.
+
+Lemma OMEGA13 :
+ forall (v l1 l2:Z) (x:positive),
+   (v * Zpos x + l1 + (v * Zneg x + l2))%Z = (l1 + l2)%Z.
+
+intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
+ rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
+ rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x));
+ rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
+ trivial with arith.
+Qed.
+ 
+Lemma OMEGA14 :
+ forall (v l1 l2:Z) (x:positive),
+   (v * Zneg x + l1 + (v * Zpos x + l2))%Z = (l1 + l2)%Z.
+
+intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
+ rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
+ rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r;
+ 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.
+
+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.
+
+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.
+
+unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
+ apply Zplus_reg_l with (y * z)%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.
+
+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.
+
+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;
+       rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
+    | intros H2; absurd (x = 0%Z); 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.
+
+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_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_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_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_OMEGA10 (v c1 c2 l1 l2 k1 k2:Z) (P:Z -> Prop)
+  (H:P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))%Z) :=
+  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) :=
+  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) :=
+  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) :=
+  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_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_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_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_Zmult_sym (x y:Z) (P:Z -> Prop) (H:P (y * x)%Z) :=
+  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_Zopp (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_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_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_Zred_factor1 (x:Z) (P:Z -> Prop) (H:P (x * 2)%Z) :=
+  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_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_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)%Z) :=
+  eq_ind_r P H (Zred_factor6 x).
diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml
new file mode 100644
index 00000000..7a20aeb6
--- /dev/null
+++ b/contrib/omega/coq_omega.ml
@@ -0,0 +1,1783 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq_omega.ml,v 1.59.2.3 2004/07/16 19:30:12 herbelin Exp $ *)
+
+open Util
+open Pp
+open Reduction
+open Proof_type
+open Ast
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Environ
+open Sign
+open Inductive
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Clenv
+open Logic
+open Libnames
+open Nametab
+open Omega
+open Contradiction
+
+(* Added by JCF, 09/03/98 *)
+
+let elim_id id gl = simplest_elim (pf_global gl id) gl
+let resolve_id id gl = apply (pf_global gl id) gl
+
+let timing timer_name f arg = f arg
+
+let display_time_flag = ref false
+let display_system_flag = ref false
+let display_action_flag = ref false
+let old_style_flag = ref false
+
+let read f () = !f
+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;
+      optname  = "Omega system time displaying flag";
+      optkey   = SecondaryTable ("Omega","System");
+      optread  = read display_system_flag;
+      optwrite = write display_system_flag }
+
+let _ =
+  declare_bool_option 
+    { optsync  = false;
+      optname  = "Omega action display flag";
+      optkey   = SecondaryTable ("Omega","Action");
+      optread  = read display_action_flag;
+      optwrite = write display_action_flag }
+
+let _ =
+  declare_bool_option 
+    { optsync  = false;
+      optname  = "Omega old style flag";
+      optkey   = SecondaryTable ("Omega","OldStyle");
+      optread  = read old_style_flag;
+      optwrite = write old_style_flag }
+
+
+let all_time        = timing "Omega     "
+let solver_time     = timing "Solver    "
+let exact_time      = timing "Rewrites  "
+let elim_time       = timing "Elim      "
+let simpl_time      = timing "Simpl     "
+let generalize_time = timing "Generalize"
+
+let new_identifier = 
+  let cpt = ref 0 in 
+  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
+
+let new_identifier_state = 
+  let cpt = ref 0 in 
+  (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s)
+
+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 mk_then = tclTHENLIST
+
+let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c])
+
+let generalize_tac t = generalize_time (generalize t)
+let elim t = elim_time (simplest_elim t)
+let exact t = exact_time (Tactics.refine t)
+let unfold s = Tactics.unfold_in_concl [[], Lazy.force s]
+ 
+let rev_assoc k =
+  let rec loop = function
+    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l 
+  in
+  loop
+
+let tag_hypothesis,tag_of_hyp, hyp_of_tag =
+  let l = ref ([]:(identifier * int) list) in
+  (fun h id -> l := (h,id):: !l),
+  (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
+  (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis")
+
+let hide_constr,find_constr,clear_tables,dump_tables =
+  let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
+  (fun h id eg b -> l := (h,(id,eg,b)):: !l),
+  (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"),
+  (fun () -> l := []),
+  (fun () -> !l)
+
+(* Lazy evaluation is used for Coq constants, because this code
+ is evaluated before the compiled modules are loaded.
+ To use the constant Zplus, one must type "Lazy.force coq_Zplus"
+ This is the right way to access to Coq constants in tactics ML code *)
+
+open Coqlib
+
+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 "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_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_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_Zgt = lazy (constant "Zgt")
+let coq_Zle = lazy (constant "Zle")
+let coq_inject_nat = lazy (constant "inject_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")
+let coq_inj_minus2 = lazy (constant "inj_minus2")
+let coq_inj_S = lazy (constant "inj_S")
+let coq_inj_le = lazy (constant "inj_le")
+let coq_inj_lt = lazy (constant "inj_lt")
+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_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_Zmult_le_approx = lazy (constant "Zmult_le_approx")
+let coq_OMEGA1 = lazy (constant "OMEGA1")
+let coq_OMEGA2 = lazy (constant "OMEGA2")
+let coq_OMEGA3 = lazy (constant "OMEGA3")
+let coq_OMEGA4 = lazy (constant "OMEGA4")
+let coq_OMEGA5 = lazy (constant "OMEGA5")
+let coq_OMEGA6 = lazy (constant "OMEGA6")
+let coq_OMEGA7 = lazy (constant "OMEGA7")
+let coq_OMEGA8 = lazy (constant "OMEGA8")
+let coq_OMEGA9 = lazy (constant "OMEGA9")
+let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10")
+let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11")
+let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12")
+let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13")
+let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14")
+let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15")
+let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16")
+let coq_OMEGA17 = lazy (constant "OMEGA17")
+let coq_OMEGA18 = lazy (constant "OMEGA18")
+let coq_OMEGA19 = lazy (constant "OMEGA19")
+let coq_OMEGA20 = lazy (constant "OMEGA20")
+let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0")
+let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1")
+let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2")
+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_Zegal_left = lazy (constant "Zegal_left")
+let coq_Zne_left = lazy (constant "Zne_left")
+let coq_Zlt_left = lazy (constant "Zlt_left")
+let coq_Zge_left = lazy (constant "Zge_left")
+let coq_Zgt_left = lazy (constant "Zgt_left")
+let coq_Zle_left = lazy (constant "Zle_left")
+let coq_new_var = lazy (constant "new_var")
+let coq_intro_Z = lazy (constant "intro_Z")
+
+let coq_dec_eq = lazy (constant "dec_eq")
+let coq_dec_Zne = lazy (constant "dec_Zne")
+let coq_dec_Zle = lazy (constant "dec_Zle")
+let coq_dec_Zlt = lazy (constant "dec_Zlt")
+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_neq = lazy (constant "neq")
+let coq_Zne = lazy (constant "Zne")
+let coq_Zle = lazy (constant "Zle")
+let coq_Zgt = lazy (constant "Zgt")
+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")
+
+(* Compare_dec/Peano_dec/Minus *)
+let coq_pred_of_minus = lazy (constant "pred_of_minus")
+let coq_le_gt_dec = lazy (constant "le_gt_dec")
+let coq_dec_eq_nat = lazy (constant "dec_eq_nat")
+let coq_dec_le = lazy (constant "dec_le")
+let coq_dec_lt = lazy (constant "dec_lt")
+let coq_dec_ge = lazy (constant "dec_ge")
+let coq_dec_gt = lazy (constant "dec_gt")
+let coq_not_eq = lazy (constant "not_eq")
+let coq_not_le = lazy (constant "not_le")
+let coq_not_lt = lazy (constant "not_lt")
+let coq_not_ge = lazy (constant "not_ge")
+let coq_not_gt = lazy (constant "not_gt")
+
+(* Logic/Decidable *)
+let coq_eq_ind_r = lazy (constant "eq_ind_r")
+
+let coq_dec_or = lazy (constant "dec_or")
+let coq_dec_and = lazy (constant "dec_and")
+let coq_dec_imp = lazy (constant "dec_imp")
+let coq_dec_not = lazy (constant "dec_not")
+let coq_dec_False = lazy (constant "dec_False")
+let coq_dec_not_not = lazy (constant "dec_not_not")
+let coq_dec_True = lazy (constant "dec_True")
+
+let coq_not_or = lazy (constant "not_or")
+let coq_not_and = lazy (constant "not_and")
+let coq_not_imp = lazy (constant "not_imp")
+let coq_not_not = lazy (constant "not_not")
+let coq_imp_simp = lazy (constant "imp_simp")
+
+(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *)
+
+(* For unfold *)
+open Closure
+let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
+  | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
+      EvalConstRef kn
+  | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
+
+let sp_Zs =     lazy (evaluable_ref_of_constr "Zs" coq_Zs)
+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)
+let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge)
+let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt)
+let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
+
+let mk_var v = mkVar (id_of_string v)
+let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |])
+let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
+let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
+let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |])
+let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |])
+let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |])
+let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |])
+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 |])
+
+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) |])
+  in
+  if n = 0 then Lazy.force coq_ZERO 
+  else mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG),
+		 [| loop (abs n) |])
+    
+type omega_constant =
+  | Zplus | Zmult | Zminus | Zs | Zopp
+  | Plus | Mult | Minus | Pred | S | O
+  | POS | NEG | ZERO | Inject_nat
+  | Eq | Neq
+  | Zne | Zle | Zlt | Zge | Zgt
+  | Z | Nat
+  | And | Or | False | True | Not
+  | Le | Lt | Ge | Gt
+  | Other of string
+
+type omega_proposition =
+  | Keq of constr * constr * constr
+  | Kn
+
+type result = 
+  | Kvar of identifier
+  | Kapp of omega_constant * constr list
+  | Kimp of constr * constr
+  | Kufo
+
+let destructurate_prop t =
+  let c, args = decompose_app t in
+  match kind_of_term c, args with
+    | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args)
+    | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args)
+    | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args)
+    | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args)
+    | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args)
+    | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args)
+    | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args)
+    | _, [_;_] when c = build_coq_and () -> Kapp (And,args)
+    | _, [_;_] when c = build_coq_or () -> Kapp (Or,args)
+    | _, [_] when c = build_coq_not () -> Kapp (Not,args)
+    | _, [] when c = build_coq_False () -> Kapp (False,args)
+    | _, [] when c = build_coq_True () -> Kapp (True,args)
+    | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args)
+    | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args)
+    | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args)
+    | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args)
+    | Const sp, args ->
+	Kapp (Other (string_of_id (id_of_global (ConstRef sp))),args)
+    | Construct csp , args ->
+	Kapp (Other (string_of_id (id_of_global (ConstructRef csp))), args)
+    | Ind isp, args ->
+	Kapp (Other (string_of_id (id_of_global (IndRef isp))),args)
+    | Var id,[] -> Kvar id
+    | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
+    | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal"
+    | _ -> Kufo
+
+let destructurate_type t =
+  let c, args = decompose_app t in
+  match kind_of_term c, args with
+    | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args)
+    | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args)
+    | _ -> Kufo
+
+let destructurate_term t =
+  let c, args = decompose_app t in
+  match kind_of_term c, args with
+    | _, [_;_] 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_Zopp -> Kapp (Zopp,args)
+    | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args)
+    | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args)
+    | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args)
+    | _, [_] 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)
+    | 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
+      | _ -> 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
+    | _ -> failwith "not a number"
+	  
+type constr_path =
+  | P_APP of int
+  (* Abstraction and product *)
+  | P_BODY 
+  | P_TYPE
+  (* Case *)
+  | P_BRANCH of int
+  | P_ARITY
+  | P_ARG
+
+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)
+      | ([], _) -> 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')
+      | ((P_BRANCH n :: p), Case (ci,q,c,v)) ->
+	  (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *)
+	  let v' = Array.copy v in
+	  v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v'))
+      | ((P_ARITY :: p),  App (f,l)) ->
+	  appvect (loop i p f,l)
+      | ((P_ARG :: p),  App (f,v)) ->
+	  let v' = Array.copy v in
+	  v'.(0) <- loop i p v'.(0); mkApp (f,v')
+      | (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')))
+      | ((P_BODY :: p), Prod (n,t,c)) ->
+	  (mkProd (n,t,loop (i+1) p c))
+      | ((P_BODY :: p), Lambda (n,t,c)) ->
+	  (mkLambda (n,t,loop (i+1) p c))
+      | ((P_BODY :: p), LetIn (n,b,t,c)) ->
+	  (mkLetIn (n,b,t,loop (i+1) p c))
+      | ((P_TYPE :: p), Prod (n,t,c)) ->
+	  (mkProd (n,loop i p t,c))
+      | ((P_TYPE :: p), Lambda (n,t,c)) ->
+	  (mkLambda (n,loop i p t,c))
+      | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
+	  (mkLetIn (n,b,loop i p t,c))
+      | (p, _) -> 
+	  ppnl (Printer.prterm 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
+    | ([], _) -> t
+    | ((P_APP n :: p),  App (f,v)) -> loop p v.(n-1)
+    | ((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)
+    | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n)
+    | ((P_BODY :: p), Prod (n,t,c)) -> loop p c
+    | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c
+    | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c
+    | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term
+    | ((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);
+	failwith ("occurence " ^ string_of_int(List.length p)) 
+  in
+  loop path t
+
+let abstract_path typ path t =
+  let term_occur = ref (mkRel 0) in
+  let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in
+  mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur
+
+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
+
+let focused_simpl path = simpl_time (focused_simpl path)
+
+type oformula =
+  | Oplus of oformula * oformula
+  | Oinv of  oformula
+  | Otimes of oformula * oformula
+  | Oatom of identifier
+  | Oz of int
+  | Oufo of constr
+
+let rec oprint = function 
+  | Oplus(t1,t2) -> 
+      print_string "("; oprint t1; print_string "+"; 
+      oprint t2; print_string ")"
+  | Oinv t -> print_string "~"; oprint t
+  | Otimes (t1,t2) -> 
+      print_string "("; oprint t1; print_string "*"; 
+      oprint t2; print_string ")"
+  | Oatom s -> print_string (string_of_id s)
+  | Oz i -> print_int i
+  | Oufo f -> print_string "?"
+
+let rec weight = function
+  | Oatom c -> intern_id c
+  | Oz _ -> -1
+  | Oinv c -> weight c
+  | Otimes(c,_) -> weight c
+  | Oplus _ -> failwith "weight"
+  | Oufo _ -> -1
+
+let rec val_of = function
+  | Oatom c -> mkVar c
+  | Oz c -> mk_integer c
+  | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |])
+  | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |])
+  | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |])
+  | Oufo c -> c
+
+let compile name kind = 
+  let rec loop accu = function
+    | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r
+    | Oz n ->
+	let id = new_id () in
+	tag_hypothesis name id;
+	{kind = kind; body = List.rev accu; constant = n; id = id}
+    | _ -> anomaly "compile_equation" 
+  in
+  loop []
+
+let rec decompile af = 
+  let rec loop = function
+    | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) 
+    | [] -> Oz af.constant 
+  in
+  loop af.body
+
+let mkNewMeta () = mkMeta (Clenv.new_meta())
+
+let clever_rewrite_base_poly typ p result theorem gl = 
+  let full = pf_concl gl in
+  let (abstracted,occ) = abstract_path typ (List.rev p) full in
+  let t = 
+    applist
+      (mkLambda
+	 (Name (id_of_string "P"), 
+	  mkArrow typ mkProp,
+          mkLambda
+	    (Name (id_of_string "H"),
+	     applist (mkRel 1,[result]),
+	     mkApp (Lazy.force coq_eq_ind_r, 
+		       [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
+       [abstracted]) 
+  in
+  exact (applist(t,[mkNewMeta()])) gl
+
+let clever_rewrite_base p result theorem gl = 
+  clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl
+
+let clever_rewrite_base_nat p result theorem gl = 
+  clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl
+
+let clever_rewrite_gen p result (t,args) = 
+  let theorem = applist(t, args) in 
+  clever_rewrite_base p result theorem
+
+let clever_rewrite_gen_nat p result (t,args) = 
+  let theorem = applist(t, args) in 
+  clever_rewrite_base_nat p result theorem
+
+let clever_rewrite p vpath t gl = 
+  let full = pf_concl gl in
+  let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in
+  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) ->
+	if weight l1 > weight l2 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)
+           :: tac,
+           Oplus(l1,t'))
+	else 
+	  let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
+          (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
+             (Lazy.force coq_fast_Zplus_permute)
+           :: tac,
+           Oplus(l2,t'))
+    | Oplus(l1,r1), 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)
+          :: tac, 
+          Oplus(l1, t')
+	else 
+          [clever_rewrite p [[P_APP 1];[P_APP 2]] 
+	     (Lazy.force coq_fast_Zplus_sym)],
+          Oplus(t2,t1)
+    | t1,Oplus(l2,r2) -> 
+	if weight l2 > weight t1 then
+          let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
+          clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
+            (Lazy.force coq_fast_Zplus_permute)
+          :: tac,
+          Oplus(l2,t')
+	else [],Oplus(t1,t2)
+    | Oz t1,Oz t2 ->
+	[focused_simpl p], Oz(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)],
+	  Oplus(t2,t1)
+	else [],Oplus(t1,t2)
+	  
+let rec shuffle_mult p_init k1 e1 k2 e2 =
+  let rec loop p = function
+    | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
+	if v1 = v2 then
+          let tac =
+            clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+                              [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+                              [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+                              [P_APP 1; P_APP 1; P_APP 2];
+                              [P_APP 2; P_APP 1; P_APP 2];
+                              [P_APP 1; P_APP 2];
+                              [P_APP 2; P_APP 2]]
+              (Lazy.force coq_fast_OMEGA10) 
+	  in
+          if k1*c1 + k2 * c2 = 0 then 
+            let tac' = 
+	      clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+                (Lazy.force coq_fast_Zred_factor5) in
+	    tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
+	    loop p (l1,l2)
+          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 1];
+                            [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+                            [P_APP 1; P_APP 1; P_APP 2];
+                            [P_APP 2];
+                            [P_APP 1; P_APP 2]]
+            (Lazy.force coq_fast_OMEGA11) ::
+          loop (P_APP 2 :: p) (l1,l2')
+	else
+          clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+                            [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+                            [P_APP 1];
+                            [P_APP 2; P_APP 1; P_APP 2];
+                            [P_APP 2; P_APP 2]]
+            (Lazy.force coq_fast_OMEGA12) ::
+          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 1];
+                          [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+                          [P_APP 1; P_APP 1; P_APP 2];
+                          [P_APP 2];
+                          [P_APP 1; P_APP 2]]
+          (Lazy.force coq_fast_OMEGA11) ::
+        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];
+                           [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+                           [P_APP 1];
+                           [P_APP 2; P_APP 1; P_APP 2];
+                           [P_APP 2; P_APP 2]]
+          (Lazy.force coq_fast_OMEGA12) ::
+        loop (P_APP 2 :: p) ([],l2)
+    | [],[] -> [focused_simpl p_init] 
+  in
+  loop p_init (e1,e2)
+    
+let rec shuffle_mult_right p_init e1 k2 e2 =
+  let rec loop p = function
+    | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
+	if v1 = v2 then
+          let tac =
+            clever_rewrite p
+              [[P_APP 1; P_APP 1; P_APP 1];
+               [P_APP 1; P_APP 1; P_APP 2];
+               [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+               [P_APP 1; P_APP 2];
+               [P_APP 2; P_APP 1; P_APP 2];
+               [P_APP 2; P_APP 2]]
+              (Lazy.force coq_fast_OMEGA15) 
+	  in
+          if c1 + k2 * c2 = 0 then 
+            let tac' = 
+              clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+                (Lazy.force coq_fast_Zred_factor5) 
+	    in
+            tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: 
+            loop p (l1,l2)
+          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) ::
+          loop (P_APP 2 :: p) (l1,l2')
+	else
+          clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+                            [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+                            [P_APP 1];
+                            [P_APP 2; P_APP 1; P_APP 2];
+                            [P_APP 2; P_APP 2]]
+            (Lazy.force coq_fast_OMEGA12) ::
+          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) ::
+        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];
+                          [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+                          [P_APP 1];
+                          [P_APP 2; P_APP 1; P_APP 2];
+                          [P_APP 2; P_APP 2]]
+          (Lazy.force coq_fast_OMEGA12) ::
+        loop (P_APP 2 :: p) ([],l2)
+    | [],[] -> [focused_simpl p_init] 
+  in
+  loop p_init (e1,e2)
+
+let rec shuffle_cancel p = function 
+  | [] -> [focused_simpl p]
+  | ({c=c1}::l1) ->
+      let tac = 
+	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 
+	     (Lazy.force coq_fast_OMEGA13) 
+	   else 
+	     (Lazy.force coq_fast_OMEGA14)) 
+      in
+      tac :: shuffle_cancel p l1
+	
+let rec scalar p n = function
+  | Oplus(t1,t2) -> 
+      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) :: 
+      (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))
+  | 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);
+       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"
+  | (Oatom _ as t) -> [], Otimes(t,Oz n)
+  | Oz i -> [focused_simpl p],Oz(n*i)
+  | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
+      
+let rec scalar_norm p_init = 
+  let rec loop p = function
+    | [] -> [focused_simpl p_init]
+    | (_::l) -> 
+	clever_rewrite p
+          [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2];
+           [P_APP 1; P_APP 2];[P_APP 2]]
+          (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l 
+  in
+  loop p_init
+
+let rec norm_add p_init =
+  let rec loop p = function
+    | [] -> [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) ::
+	loop (P_APP 2 :: p) l 
+  in
+  loop p_init
+
+let rec scalar_norm_add p_init =
+  let rec loop p = function
+    | [] -> [focused_simpl p_init]
+    | _ :: l -> 
+	clever_rewrite p
+          [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+           [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+           [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]]
+          (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l 
+  in
+  loop p_init
+
+let rec negate p = function
+  | Oplus(t1,t2) -> 
+      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) :: 
+      (tac1 @ tac2),
+      Oplus(t1',t2')
+  | Oinv t ->
+      [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_Zopp)], 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))
+  | 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)
+  | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |]))
+      
+let rec transform p t = 
+  let default () =
+    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 false;
+      [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
+  in
+  try match destructurate_term t with
+    | Kapp(Zplus,[t1;t2]) ->
+	let tac1,t1' = transform (P_APP 1 :: p) t1 
+	and tac2,t2' = transform (P_APP 2 :: p) t2 in
+	let tac,t' = shuffle p (t1',t2') in
+	tac1 @ tac2 @ tac, t'
+    | Kapp(Zminus,[t1;t2]) ->
+	let tac,t = 
+	  transform p
+	    (mkApp (Lazy.force coq_Zplus,
+		     [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
+	unfold sp_Zminus :: tac,t
+    | Kapp(Zs,[t1]) ->
+	let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
+					 [| t1; mk_integer 1 |])) in
+	unfold sp_Zs :: 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
+       begin match t1',t2' with
+         | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t'
+         | (Oz n,_) ->
+             let sym = 
+	       clever_rewrite p [[P_APP 1];[P_APP 2]] 
+		 (Lazy.force coq_fast_Zmult_sym) in
+             let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t'
+         | _ -> default ()
+       end
+   | Kapp((POS|NEG|ZERO),_) -> 
+       (try ([],Oz(recognize_number t)) with _ -> default ())
+   | 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 ()
+      
+let shrink_pair p f1 f2 =
+  match f1,f2 with
+    | Oatom v,Oatom _ -> 
+	let r = Otimes(Oatom v,Oz 2) 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
+	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
+	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) ->
+	let r = Otimes(Oatom v,Oplus(c1,c2)) in
+	clever_rewrite p 
+          [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]]
+          (Lazy.force coq_fast_Zred_factor4),r
+    | t1,t2 -> 
+	begin 
+	  oprint t1; print_newline (); oprint t2; print_newline (); 
+	  flush Pervasives.stdout; error "shrink.1"
+	end
+
+let reduce_factor p = function
+  | Oatom v ->
+      let r = Otimes(Oatom v,Oz 1) 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 
+	| _ -> error "condense.1" 
+      in
+      [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c))
+  | t -> oprint t; error "reduce_factor.1"
+
+let rec condense p = function
+  | Oplus(f1,(Oplus(f2,r) as t)) ->
+      if weight f1 = weight f2 then begin
+	let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
+	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
+	let tac_list,t' = condense p (Oplus(t,r)) in
+	(assoc_tac :: shrink_tac :: tac_list), t'
+      end else begin
+	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
+	let tac',t' = condense (P_APP 2 :: p) t in 
+	(tac @ tac'), Oplus(f,t') 
+      end
+  | Oplus(f1,Oz n) as t -> 
+      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
+	let tac_shrink,t = shrink_pair p f1 f2 in
+	let tac,t' = condense p t in
+	tac_shrink :: tac,t'
+      end else begin
+	let tac,f = reduce_factor (P_APP 1 :: p) f1 in
+	let tac',t' = condense (P_APP 2 :: p) f2 in 
+	(tac @ tac'),Oplus(f,t') 
+      end
+  | Oz _ as t -> [],t
+  | t -> 
+      let tac,t' = reduce_factor p t in
+      let final = Oplus(t',Oz 0) 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) ->
+      let tac =
+	clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] 
+	  (Lazy.force coq_fast_Zred_factor5) in
+      let tac',t = clear_zero p r in
+      tac :: tac',t
+  | Oplus(f,r) -> 
+      let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t)
+  | t -> [],t
+
+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 rec loop t =
+    match t with
+      | HYP e :: l -> 
+	  begin 
+	    try 
+	      tclTHEN 
+		(List.assoc (hyp_of_tag e.id) tactic_normalisation) 
+		(loop l)
+	    with Not_found -> loop l end
+      | NEGATE_CONTRADICT (e2,e1,b) :: l ->
+	  let eq1 = decompile e1 
+	  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 p_initial = [P_APP 1;P_TYPE] in
+	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
+	  tclTHENLIST [
+	    (generalize_tac 
+	      [mkApp (Lazy.force coq_OMEGA17, [| 
+		val_of eq1;
+		val_of eq2;
+		mk_integer k; 
+		mkVar id1; mkVar id2 |])]);
+	    (mk_then tac);
+	    (intros_using [aux]);
+	    (resolve_id aux);
+            reflexivity
+          ]
+      | CONTRADICTION (e1,e2) :: l -> 
+	  let eq1 = decompile e1 
+	  and eq2 = decompile e2 in 
+	  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 |])
+	    in
+            tclTHENS 
+	      (tclTHENLIST [
+		(unfold sp_Zle);
+		(simpl_in_concl);
+		intro;
+		(absurd not_sup_sup) ])
+	      [ assumption ; reflexivity ] 
+	  in
+	  let theorem =
+            mkApp (Lazy.force coq_OMEGA2, [| 
+		      val_of eq1; val_of eq2; 
+		      mkVar (hyp_of_tag e1.id);
+		      mkVar (hyp_of_tag e2.id) |])
+	  in
+	  tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
+      | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
+	  let id = hyp_of_tag e1.id in
+	  let eq1 = val_of(decompile e1) 
+	  and 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_eg = mk_eq eq1 rhs in
+	  let tac = scalar_norm_add [P_APP 3] e2.body in
+	  tclTHENS 
+	    (cut state_eg) 
+	    [ tclTHENS
+	        (tclTHENLIST [
+		  (intros_using [aux]);
+		  (generalize_tac 
+		    [mkApp (Lazy.force coq_OMEGA1,
+		      [| eq1; rhs; mkVar aux; mkVar id |])]);
+		  (clear [aux;id]);
+		  (intros_using [id]);
+		  (cut (mk_gt kk dd)) ])
+	        [ tclTHENS 
+		    (cut (mk_gt kk zero)) 
+		    [ tclTHENLIST [
+		        (intros_using [aux1; aux2]);
+		        (generalize_tac 
+			  [mkApp (Lazy.force coq_Zmult_le_approx,
+			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
+		        (clear [aux1;aux2;id]);
+		        (intros_using [id]);
+		        (loop l) ];
+		      tclTHENLIST [
+			(unfold sp_Zgt);
+			(simpl_in_concl);
+			reflexivity ] ];
+		  tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
+                ];
+	      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 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 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)) 
+	    [ tclTHENS (cut (mk_gt kk dd)) 
+		[tclTHENLIST [
+		  (intros_using [aux2;aux1]);
+		  (generalize_tac 
+		    [mkApp (Lazy.force coq_OMEGA4, 
+                      [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
+		  (clear [aux1;aux2]);
+		  (unfold sp_not);
+		  (intros_using [aux]);
+		  (resolve_id aux);
+		  (mk_then tac);
+		  assumption ] ;
+		 tclTHENLIST [
+		   (unfold sp_Zgt);
+		   simpl_in_concl; 
+		   reflexivity ] ];
+              tclTHENLIST [
+		(unfold sp_Zgt);
+                simpl_in_concl;
+		reflexivity ] ]
+      | EXACT_DIVIDE (e1,k) :: l ->
+	  let id = hyp_of_tag e1.id in
+	  let e2 =  map_eq_afine (fun c -> c / k) e1 in
+	  let eq1 = val_of(decompile e1) 
+	  and eq2 = val_of(decompile e2) in
+	  let kk = mk_integer k in
+	  let state_eq = mk_eq eq1 (mk_times eq2 kk) in
+	  if e1.kind = DISE then
+            let tac = scalar_norm [P_APP 3] e2.body in
+            tclTHENS 
+	      (cut state_eq) 
+	      [tclTHENLIST [
+		(intros_using [aux1]);
+		(generalize_tac 
+		  [mkApp (Lazy.force coq_OMEGA18, 
+                    [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
+		(clear [aux1;id]);
+		(intros_using [id]);
+		(loop l) ];
+	       tclTHEN (mk_then tac) reflexivity ]
+	  else
+            let tac = scalar_norm [P_APP 3] e2.body in
+            tclTHENS (cut state_eq) 
+	      [
+		tclTHENS 
+		 (cut (mk_gt kk zero)) 
+		 [tclTHENLIST [
+		   (intros_using [aux2;aux1]);
+		   (generalize_tac 
+		     [mkApp (Lazy.force coq_OMEGA3, 
+		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
+		   (clear [aux1;aux2;id]);
+		   (intros_using [id]);
+		   (loop l) ];
+		  tclTHENLIST [
+		    (unfold sp_Zgt);
+                    simpl_in_concl;
+		    reflexivity ] ];
+		tclTHEN (mk_then tac) reflexivity ]
+      | (MERGE_EQ(e3,e1,e2)) :: l ->
+	  let id = new_identifier () in
+	  tag_hypothesis id e3;
+	  let id1 = hyp_of_tag e1.id 
+	  and id2 = hyp_of_tag e2 in
+	  let eq1 = val_of(decompile e1) 
+	  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) ::
+            scalar_norm [P_APP 3] e1.body 
+	  in
+	  tclTHENS 
+	    (cut (mk_eq eq1 (mk_inv eq2))) 
+	    [tclTHENLIST [
+	      (intros_using [aux]);
+	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8, 
+	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
+	      (clear [id1;id2;aux]);
+	      (intros_using [id]);
+	      (loop l) ];
+            tclTHEN (mk_then tac) reflexivity]
+	    
+      | STATE(new_eq,def,orig,m,sigma) :: l ->
+	  let id = new_identifier () 
+	  and id2 = hyp_of_tag orig.id in
+	  tag_hypothesis id new_eq.id;
+	  let eq1 = val_of(decompile def) 
+	  and eq2 = val_of(decompile orig) in
+	  let vid = unintern_id sigma in
+	  let theorem =
+            mkApp (build_coq_ex (), [| 
+		      Lazy.force coq_Z;
+		      mkLambda
+			(Name vid,
+			 Lazy.force coq_Z,
+			 mk_eq (mkRel 1) eq1) |])
+	  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) ::
+            shuffle_mult_right p_initial
+              orig.body m ({c= -1;v=sigma}::def.body) in
+	  tclTHENS 
+	    (cut theorem)  
+	    [tclTHENLIST [
+	      (intros_using [aux]);
+	      (elim_id aux);
+	      (clear [aux]);
+	      (intros_using [vid; aux]);
+	      (generalize_tac
+		[mkApp (Lazy.force coq_OMEGA9, 
+		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
+	      (mk_then tac);
+	      (clear [aux]);
+	      (intros_using [id]);
+	      (loop l) ];
+            tclTHEN (exists_tac eq1) reflexivity ]
+      | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
+	  let id1 = new_identifier () 
+	  and id2 = new_identifier () in
+	  tag_hypothesis id1 e1; tag_hypothesis id2 e2;
+	  let id = hyp_of_tag e.id in
+	  let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
+	  let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
+	  let eq = val_of(decompile e) in
+	  tclTHENS 
+	    (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
+	    [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
+             tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
+      | SUM(e3,(k1,e1),(k2,e2)) :: l ->
+	  let id = new_identifier () in
+	  tag_hypothesis id e3;
+	  let id1 = hyp_of_tag e1.id 
+	  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
+            let tac_thm =
+              match e1.kind with
+		| EQUA -> Lazy.force coq_OMEGA5 
+		| INEQ -> Lazy.force coq_OMEGA6 
+		| DISE -> Lazy.force coq_OMEGA20 
+	    in
+            let kk = mk_integer k2 in
+            let p_initial =
+              if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
+            let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
+            tclTHENLIST [ 
+	      (generalize_tac
+                [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
+	      (mk_then tac);
+	      (intros_using [id]);
+	      (loop l)
+            ]
+	  else
+            let kk1 = mk_integer k1 
+	    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 kk2 zero)) 
+		 [tclTHENLIST [
+		   (intros_using [aux2;aux1]);
+		   (generalize_tac
+		     [mkApp (Lazy.force coq_OMEGA7, [| 
+		       eq1;eq2;kk1;kk2; 
+		       mkVar aux1;mkVar aux2;
+		       mkVar id1;mkVar id2 |])]);
+		   (clear [aux1;aux2]);
+		   (mk_then tac);
+		   (intros_using [id]);
+		   (loop l) ];
+		 tclTHENLIST [
+		   (unfold sp_Zgt);
+                   simpl_in_concl;
+		   reflexivity ] ];
+	      tclTHENLIST [
+		(unfold sp_Zgt);
+                simpl_in_concl; 
+		reflexivity ] ]
+      | CONSTANT_NOT_NUL(e,k) :: l -> 
+	  tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
+      | CONSTANT_NUL(e) :: l -> 
+	  tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
+      | CONSTANT_NEG(e,k) :: l ->
+	  tclTHENLIST [
+	    (generalize_tac [mkVar (hyp_of_tag e)]);
+            (unfold sp_Zle);
+	    simpl_in_concl;
+	    (unfold sp_not);
+	    (intros_using [aux]);
+	    (resolve_id aux);
+	    reflexivity 
+          ]
+      | _ -> tclIDTAC 
+  in
+  loop
+
+let normalize p_initial t =
+  let (tac,t') = transform p_initial t in
+  let (tac',t'') = condense p_initial t' in
+  let (tac'',t''') = clear_zero p_initial t'' in 
+  tac @ tac' @ tac'' , t'''
+    
+let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
+  let p_initial = [P_APP pos ;P_TYPE] in
+  let (tac,t') = normalize p_initial t in
+  let shift_left = 
+    tclTHEN 
+      (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
+      (tclTRY (clear [id]))
+  in
+  if tac <> [] then
+    let id' = new_identifier () in 
+    ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
+          :: tactic,
+     compile id' flag t' :: defs)
+  else 
+    (tactic,defs)
+    
+let destructure_omega gl tac_def (id,c) =
+  if atompart_of_id id = "State" then 
+    tac_def
+  else
+    try match destructurate_prop c with
+      | Kapp(Eq,[typ;t1;t2]) 
+	when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
+	  let t = mk_plus t1 (mk_inv t2) in
+	  normalize_equation 
+	    id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
+      | Kapp(Zne,[t1;t2]) ->
+	  let t = mk_plus t1 (mk_inv t2) in
+	  normalize_equation
+	    id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def
+      | Kapp(Zle,[t1;t2]) ->
+	  let t = mk_plus t2 (mk_inv t1) in
+	  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
+	  normalize_equation
+	    id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def
+      | Kapp(Zge,[t1;t2]) ->
+	  let t = mk_plus t1 (mk_inv t2) in
+	  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
+	  normalize_equation
+	    id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def
+      | _ -> tac_def
+    with e when catchable_exception e -> tac_def
+
+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 = 
+    List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
+  let prelude,sys = 
+    List.fold_left 
+      (fun (tac,sys) (t,(v,th,b)) ->
+	 if b then
+           let id = new_identifier () in
+           let i = new_id () in
+           tag_hypothesis id i;
+           (tclTHENLIST [
+	     (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
+	     (intros_using [v; id]);
+	     (elim_id id);
+	     (clear [id]);
+	     (intros_using [th;id]);
+	     tac ]),
+           {kind = INEQ; 
+	    body = [{v=intern_id v; c=1}]; 
+            constant = 0; id = i} :: sys
+	 else
+           (tclTHENLIST [
+	     (simplest_elim (applist (Lazy.force coq_new_var, [t])));
+	     (intros_using [v;th]);
+	     tac ]),
+           sys)
+      (tclIDTAC,[]) (dump_tables ())
+  in
+  let system = system @ sys in
+  if !display_system_flag then display_system system;
+  if !old_style_flag then begin
+    try let _ = simplify false system in tclIDTAC gl
+    with UNSOLVABLE -> 
+      let _,path = depend [] [] (history ()) in
+      if !display_action_flag then display_action 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; 
+      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+    with NO_CONTRADICTION -> error "Omega can't solve this system"
+  end
+
+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]) ->
+          tclTHENLIST [ 
+	    (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
+              ((Lazy.force coq_inj_plus),[t1;t2]));
+	    (explore (P_APP 1 :: p) t1);
+	    (explore (P_APP 2 :: p) t2)
+          ]
+      | Kapp(Mult,[t1;t2]) ->
+          tclTHENLIST [
+	    (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
+              ((Lazy.force coq_inj_mult),[t1;t2]));
+	    (explore (P_APP 1 :: p) t1);
+	    (explore (P_APP 2 :: p) t2)
+          ]
+      | Kapp(Minus,[t1;t2]) ->
+          let id = new_identifier () in
+          tclTHENS
+            (tclTHEN 
+	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) 
+	       (intros_using [id])) 
+	    [
+	      tclTHENLIST [
+	        (clever_rewrite_gen p 
+		  (mk_minus (mk_inj t1) (mk_inj t2))
+                  ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
+		(loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
+		(explore (P_APP 1 :: p) t1);
+		(explore (P_APP 2 :: p) t2) ];
+	      (tclTHEN 
+		 (clever_rewrite_gen p (mk_integer 0)
+                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
+		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
+	    ]
+      | Kapp(S,[t']) ->
+          let rec is_number t =
+            try match destructurate_term t with 
+		Kapp(S,[t]) -> is_number t
+              | Kapp(O,[]) -> true
+              | _ -> false
+            with e when catchable_exception e -> false 
+	  in
+          let rec loop p t =
+            try match destructurate_term t with 
+		Kapp(S,[t]) ->
+                  (tclTHEN 
+                     (clever_rewrite_gen p 
+			(mkApp (Lazy.force coq_Zs, [| mk_inj t |]))
+			((Lazy.force coq_inj_S),[t])) 
+		     (loop (P_APP 1 :: p) t))
+              | _ -> explore p t 
+            with e when catchable_exception e -> explore p t 
+	  in
+          if is_number t' then focused_simpl p else loop p t
+      | Kapp(Pred,[t]) ->
+          let t_minus_one = 
+	    mkApp (Lazy.force coq_minus, [| t; 
+		      mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
+          tclTHEN
+            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one 
+               ((Lazy.force coq_pred_of_minus),[t]))
+            (explore p t_minus_one) 
+      | Kapp(O,[]) -> focused_simpl p
+      | _ -> tclIDTAC 
+    with e when catchable_exception e -> tclIDTAC 
+	
+  and loop = function
+    | [] -> tclIDTAC
+    | (i,t)::lit -> 
+	  begin try match destructurate_prop t with 
+              Kapp(Le,[t1;t2]) ->
+		tclTHENLIST [
+		  (generalize_tac 
+		    [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
+		  (explore [P_APP 1; P_TYPE] t1);
+		  (explore [P_APP 2; P_TYPE] t2);
+		  (reintroduce i);
+		  (loop lit)
+                ]
+            | Kapp(Lt,[t1;t2]) ->
+		tclTHENLIST [
+		  (generalize_tac 
+		    [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
+		  (explore [P_APP 1; P_TYPE] t1);
+		  (explore [P_APP 2; P_TYPE] t2);
+		  (reintroduce i);
+		  (loop lit)
+                ]
+            | Kapp(Ge,[t1;t2]) ->
+		tclTHENLIST [
+		  (generalize_tac 
+		    [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
+		  (explore [P_APP 1; P_TYPE] t1);
+		  (explore [P_APP 2; P_TYPE] t2);
+		  (reintroduce i);
+		  (loop lit)
+                ]
+            | Kapp(Gt,[t1;t2]) ->
+		tclTHENLIST [
+		  (generalize_tac
+                    [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
+		  (explore [P_APP 1; P_TYPE] t1);
+		  (explore [P_APP 2; P_TYPE] t2);
+		  (reintroduce i);
+		  (loop lit)
+                ]
+            | Kapp(Neq,[t1;t2]) ->
+		tclTHENLIST [
+		  (generalize_tac
+		    [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
+		  (explore [P_APP 1; P_TYPE] t1);
+		  (explore [P_APP 2; P_TYPE] t2);
+		  (reintroduce i);
+		  (loop lit)
+                ]
+            | Kapp(Eq,[typ;t1;t2]) ->
+		if pf_conv_x gl typ (Lazy.force coq_nat) then
+                  tclTHENLIST [
+		    (generalize_tac 
+		      [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
+		    (explore [P_APP 2; P_TYPE] t1);
+		    (explore [P_APP 3; P_TYPE] t2);
+		    (reintroduce i);
+		    (loop lit)
+                  ]
+		else loop lit
+	    | _ -> loop lit
+	  with e when catchable_exception e -> loop lit end 
+  in
+  loop (List.rev (pf_hyps_types gl)) gl
+    
+let rec decidability gl t =
+  match destructurate_prop t with
+    | Kapp(Or,[t1;t2]) -> 
+	mkApp (Lazy.force coq_dec_or, [| t1; t2;
+		  decidability gl t1; decidability gl t2 |])
+    | Kapp(And,[t1;t2]) -> 
+	mkApp (Lazy.force coq_dec_and, [| t1; t2;
+		  decidability gl t1; decidability gl t2 |])
+    | Kimp(t1,t2) -> 
+	mkApp (Lazy.force coq_dec_imp, [| t1; t2;
+		  decidability gl t1; decidability gl t2 |])
+    | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; 
+				    decidability gl t1 |])
+    | Kapp(Eq,[typ;t1;t2]) -> 
+	begin match destructurate_type (pf_nf gl typ) with
+          | Kapp(Z,[]) ->  mkApp (Lazy.force coq_dec_eq, [| t1;t2 |])
+          | 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)
+	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 |])
+    | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |])
+    | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |])
+    | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |])
+    | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |])
+    | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |])
+    | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |])
+    | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |])
+    | Kapp(False,[]) -> Lazy.force coq_dec_False
+    | Kapp(True,[]) -> Lazy.force coq_dec_True
+    | Kapp(Other t,_::_) -> error 
+	("Omega: Unrecognized predicate or connective: "^t)
+    | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t)
+    | Kvar _ -> error "Omega: Can't solve a goal with proposition variables"
+    | _ -> error "Omega: Unrecognized proposition"
+
+let onClearedName id tac =
+  (* We cannot ensure that hyps can be cleared (because of dependencies), *)
+  (* so renaming may be necessary *)
+  tclTHEN
+    (tclTRY (clear [id]))
+    (fun gl -> 
+      let id = fresh_id [] id gl in
+      tclTHEN (introduction id) (tac id) gl)
+
+let destructure_hyps gl =
+  let rec loop = function
+    | [] -> (tclTHEN nat_inject coq_omega)
+    | (i,body,t)::lit ->
+	begin try match destructurate_prop t with
+	  | Kapp(False,[]) -> elim_id i
+          | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
+          | Kapp(Or,[t1;t2]) ->
+              (tclTHENS 
+                (elim_id i)
+                [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
+                  onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+          | Kapp(And,[t1;t2]) ->
+              tclTHENLIST [
+                (elim_id i);
+		(tclTRY (clear [i]));
+		(fun gl -> 
+		  let i1 = fresh_id [] (add_suffix i "_left") gl in
+		  let i2 = fresh_id [] (add_suffix i "_right") gl in
+		  tclTHENLIST [
+		    (introduction i1);
+		    (introduction i2);
+		    (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl)
+	      ]
+          | Kimp(t1,t2) ->
+              if
+                is_Prop (pf_type_of gl t1) &
+                is_Prop (pf_type_of gl t2) &
+                closed0 t2
+              then
+		tclTHENLIST [
+		  (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+                    [| t1; t2; decidability gl t1; mkVar i|])]);
+		  (onClearedName i (fun i ->
+		    (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
+                ]
+              else
+		loop lit
+          | Kapp(Not,[t]) -> 
+              begin match destructurate_prop t with 
+		  Kapp(Or,[t1;t2]) -> 
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
+		      (onClearedName i (fun i ->
+                        (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
+                    ]
+		| Kapp(And,[t1;t2]) -> 
+                    tclTHENLIST [
+		      (generalize_tac
+		        [mkApp (Lazy.force coq_not_and, [| t1; t2;
+			  decidability gl t1;mkVar i|])]);
+		      (onClearedName i (fun i ->
+                        (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
+                    ]
+		| Kimp(t1,t2) ->
+                    tclTHENLIST [
+		      (generalize_tac 
+		        [mkApp (Lazy.force coq_not_imp, [| t1; t2; 
+		          decidability gl t1;mkVar i |])]);
+		      (onClearedName i (fun i ->
+                        (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
+                    ]
+		| Kapp(Not,[t]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+			[mkApp (Lazy.force coq_not_not, [| t;
+			  decidability gl t; mkVar i |])]);
+		      (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+                    ]
+		| Kapp(Zle, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_Zle, [| 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|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Zlt, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac 
+                        [mkApp (Lazy.force coq_not_Zlt, [| 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|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Le, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Ge, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Lt, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Gt, [t1;t2]) ->
+                    tclTHENLIST [
+		      (generalize_tac
+                        [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]);
+		      (onClearedName i (fun _ -> loop lit))
+                    ]
+		| Kapp(Eq,[typ;t1;t2]) ->
+                    if !old_style_flag then begin 
+		      match destructurate_type (pf_nf gl typ) with
+			| Kapp(Nat,_) -> 
+                            tclTHENLIST [
+			      (simplest_elim 
+				(mkApp
+                                  (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
+			      (onClearedName i (fun _ -> loop lit))
+                            ]
+			| Kapp(Z,_) ->
+                            tclTHENLIST [
+			      (simplest_elim 
+				(mkApp
+				  (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
+			      (onClearedName i (fun _ -> loop lit))
+                            ]
+			| _ -> loop lit
+                    end else begin 
+		      match destructurate_type (pf_nf gl typ) with
+			| Kapp(Nat,_) -> 
+                               (tclTHEN 
+			       (convert_hyp_no_check
+                                  (i,body,
+				  (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
+			       (loop lit))
+			| Kapp(Z,_) ->
+                               (tclTHEN 
+			       (convert_hyp_no_check
+                                  (i,body,
+				  (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+			       (loop lit))
+			| _ -> loop lit
+                    end
+		| _ -> loop lit
+              end 
+          | _ -> loop lit 
+	with e when catchable_exception e -> loop lit
+	end 
+  in
+  loop (pf_hyps gl) gl
+
+let destructure_goal gl =
+  let concl = pf_concl gl in
+  let rec loop t =
+    match destructurate_prop t with
+      | Kapp(Not,[t]) ->
+          (tclTHEN 
+	     (tclTHEN (unfold sp_not) intro) 
+	     destructure_hyps)
+      | Kimp(a,b) -> (tclTHEN intro (loop b))
+      | Kapp(False,[]) -> destructure_hyps
+      | _ ->
+          (tclTHEN 
+	     (tclTHEN
+		(Tactics.refine 
+		   (mkApp (Lazy.force coq_dec_not_not, [| t;
+			      decidability gl t; mkNewMeta () |])))
+		intro) 
+	     (destructure_hyps)) 
+  in
+  (loop concl) gl
+
+let destructure_goal = all_time (destructure_goal)
+
+let omega_solver gl =
+  Library.check_required_library ["Coq";"omega";"Omega"];
+  let result = destructure_goal gl in 
+  (* if !display_time_flag then begin text_time (); 
+     flush Pervasives.stdout end; *)
+  result
diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4
new file mode 100644
index 00000000..726cf8bc
--- /dev/null
+++ b/contrib/omega/g_omega.ml4
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_omega.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+open Coq_omega
+
+TACTIC EXTEND Omega
+  [ "Omega" ] -> [ omega_solver ]
+END
diff --git a/contrib/omega/omega.ml b/contrib/omega/omega.ml
new file mode 100755
index 00000000..f2eeb5fe
--- /dev/null
+++ b/contrib/omega/omega.ml
@@ -0,0 +1,663 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.ml,v 1.7.2.1 2004/07/16 19:30:13 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
+
+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
+
+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 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 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 afine * afine * afine * int * int
+  | 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 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 _ = 
+    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 " (string_of_id (unintern_id f.v))
+	 else 
+	   Printf.printf "%d %s " c (string_of_id (unintern_id 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 operator_of_eq = function 
+  | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
+
+let kind_of = function
+  | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
+
+let display_system 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") 
+    l;
+  print_string "------------------------\n\n"
+
+let display_inequations l = 
+  List.iter (fun e -> display_eq e;print_string ">= 0\n") l;
+  print_string "------------------------\n\n"
+
+let rec display_action = 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 (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"
+      | HYP e ->   
+          Printf.printf "We define %d :" e.id; 
+          display_eq (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 l1;
+          print_newline ();
+          display_action l2;
+          print_newline ()
+    end; display_action l
+  | [] -> 
+      flush stdout
+
+(*""*)
+
+let add_event, history, clear_history =
+  let accu = ref [] in
+  (fun (v : action) -> if !debug then display_action [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 eq1 eq2 = 
+  { kind = eq1.kind; id = new_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 {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 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 original l1 l2 = 
+  let e = original.body in
+  let sigma = new_var_num () 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 [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_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_id (); kind = EQUA } in
+  add_event (STATE (new_eq,definition,original,m,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
+  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
+  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);
+  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) =
+  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 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)
+         end else begin
+           add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
+         end
+       else banerjee (eliminate_one_equation (eq,other,sys_ineq))
+type kind = INVERTED | NORMAL
+let redundancy_elimination system =
+  let normal = function
+     ({body=f::_} as e) when f.c < 0 ->  negate_eq e, INVERTED
+   | e -> e,NORMAL in
+  let table = 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) = 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;
+         remove table ne;
+         add table ne final
+       with Not_found ->
+         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
+    (fun p0 p1 -> match (p0,p1) with 
+       | (e, (Some x, Some y)) when x.constant = y.constant ->
+           let id=new_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 = 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
+  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
+  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 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)
+                (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 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 simplify 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 = (eqs @ simp_eq,simp_ineq) in
+  let rec loop1a system =
+    let sys_ineq = banerjee system in 
+    loop1b sys_ineq 
+  and loop1b sys_ineq =
+    let simp_eq,simp_ineq = redundancy_elimination 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
+      loop2 (loop1b expanded)
+    with SOLVED_SYSTEM -> if !debug then display_system 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 (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 solve system =
+  try let _ = simplify false system in failwith "no contradiction"
+  with UNSOLVABLE -> display_action (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 = create 7 in
+  List.iter (fun e -> 
+               let {body=ne;constant=c} ,kind = normal e in
+               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') = 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 =
+  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 
+    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
+    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
+      loop2 (loop1b expanded)
+    with SOLVED_SYSTEM -> if !debug then display_system system; system 
+  in
+  let rec explode_diseq = function 
+    | (de::diseq,ineqs,expl_map) ->
+	let id1 = new_id () 
+	and id2 = new_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 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 = create 7 in
+      let augment x = 
+        try incr (find tbl x) with Not_found -> 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;
+      !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) -> (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
+        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
+      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/ring/ArithRing.v b/contrib/ring/ArithRing.v
new file mode 100644
index 00000000..1a6e0ba6
--- /dev/null
+++ b/contrib/ring/ArithRing.v
@@ -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: ArithRing.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+(* Instantiation of the Ring tactic for the naturals of Arith $*)
+
+Require Export Ring.
+Require Export Arith.
+Require Import Eqdep_dec.
+
+Open Local Scope nat_scope.
+
+Fixpoint nateq (n m:nat) {struct m} : bool :=
+  match n, m with
+  | O, O => true
+  | S n', S m' => nateq n' m'
+  | _, _ => false
+  end.
+
+Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
+Proof.
+  simple induction n; simple induction m; intros; try contradiction.
+  trivial.
+  unfold Is_true in H1.
+  rewrite (H n1 H1).
+  trivial.
+Qed.
+
+Hint Resolve nateq_prop eq2eqT: 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.
+Defined.
+
+
+Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
+
+Goal forall n:nat, S n = 1 + 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  *)
+Ltac rewrite_S_to_plus_term t :=
+  match constr:t with
+  | 1 => constr:1
+  | (S ?X1) =>
+      let t1 := rewrite_S_to_plus_term X1 in
+      constr:(1 + t1)
+  | (?X1 + ?X2) =>
+      let t1 := rewrite_S_to_plus_term X1
+      with t2 := rewrite_S_to_plus_term X2 in
+      constr:(t1 + t2)
+  | (?X1 * ?X2) =>
+      let t1 := rewrite_S_to_plus_term X1
+      with t2 := rewrite_S_to_plus_term X2 in
+      constr:(t1 * t2)
+  | _ => constr:t
+  end.
+
+(* Apply S_to_plus on both sides of an equality *)
+Ltac rewrite_S_to_plus :=
+  match goal with
+  |  |- (?X1 = ?X2) =>
+      try
+       let t1 :=  
+       (**)  (**)
+       rewrite_S_to_plus_term X1
+       with t2 := rewrite_S_to_plus_term X2 in
+       change (t1 = t2) in |- *
+  |  |- (?X1 = ?X2) =>
+      try
+       let t1 := 
+       (**)  (**)
+       rewrite_S_to_plus_term X1
+       with t2 := rewrite_S_to_plus_term X2 in
+       change (t1 = t2) in |- *
+  end.
+
+Ltac ring_nat := rewrite_S_to_plus; ring.
\ No newline at end of file
diff --git a/contrib/ring/NArithRing.v b/contrib/ring/NArithRing.v
new file mode 100644
index 00000000..cfec29ce
--- /dev/null
+++ b/contrib/ring/NArithRing.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        *)
+(************************************************************************)
+
+(* $Id: NArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+(* Instantiation of the Ring tactic for the binary natural numbers *)
+
+Require Export Ring.
+Require Export ZArith_base.
+Require Import NArith.
+Require Import Eqdep_dec.
+
+Definition Neq (n m:N) :=
+  match (n ?= m)%N with
+  | Datatypes.Eq => true
+  | _ => false
+  end.
+
+Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
+  intros n m H; unfold Neq in H.
+  apply Ncompare_Eq_eq.
+  destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
+Qed.
+
+Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N 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.
+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
diff --git a/contrib/ring/Quote.v b/contrib/ring/Quote.v
new file mode 100644
index 00000000..b4ac5745
--- /dev/null
+++ b/contrib/ring/Quote.v
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Quote.v,v 1.7.2.1 2004/07/16 19:30:13 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) {struct v} : A :=
+  match i, v with
+  | 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) {struct m} : bool :=
+  match n, m with
+  | 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) {struct m} : bool :=
+  match n, m with
+  | 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 : forall n m:index, index_eq n m = true -> n = m.
+  simple induction n; simple induction m; simpl in |- *; intros.
+  rewrite (H i0 H1); reflexivity.
+  discriminate.
+  discriminate.
+  discriminate.
+  rewrite (H i0 H1); reflexivity.
+  discriminate.
+  discriminate.
+  discriminate.
+  reflexivity.
+Qed.
+
+End variables_map.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/contrib/ring/Ring.v b/contrib/ring/Ring.v
new file mode 100644
index 00000000..81497533
--- /dev/null
+++ b/contrib/ring/Ring.v
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.9.2.1 2004/07/16 19:30:13 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 (fun b:bool => b) eqb.
+split; simpl in |- *.
+destruct n; destruct m; reflexivity.
+destruct n; destruct m; destruct p; reflexivity.
+destruct n; destruct m; reflexivity.
+destruct n; destruct m; destruct p; reflexivity.
+destruct n; reflexivity.
+destruct n; reflexivity.
+destruct n; reflexivity.
+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
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
new file mode 100644
index 00000000..de42e8c3
--- /dev/null
+++ b/contrib/ring/Ring_abstract.v
@@ -0,0 +1,704 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.13.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+Require Import Ring_theory.
+Require Import Quote.
+Require Import Ring_normalize.
+
+Section abstract_semi_rings.
+
+Inductive aspolynomial : Type :=
+  | 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 :=
+  match s1 with
+  | Cons_acs l1 t1 =>
+      (fix asm_aux (s2:abstract_sum) : abstract_sum :=
+         match s2 with
+         | 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 => fun s2 => s2
+  end.
+
+Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
+ abstract_sum :=
+  match s2 with
+  | 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) {struct s2} :
+ abstract_sum :=
+  match s2 with
+  | 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 s2:abstract_sum) {struct s1} : abstract_sum :=
+  match s1 with
+  | 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 :=
+  match p with
+  | 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 :=
+  match p with
+  | 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 (a:A) (s:abstract_sum) {struct s} : A :=
+                 match s with
+                 | 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 :=
+  match s with
+  | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
+  | Nil_acs => Azero
+  end.
+
+Hint Resolve (SR_plus_comm T).
+Hint Resolve (SR_plus_assoc T).
+Hint Resolve (SR_plus_assoc2 T).
+Hint Resolve (SR_mult_comm T).
+Hint Resolve (SR_mult_assoc T).
+Hint Resolve (SR_mult_assoc2 T).
+Hint Resolve (SR_plus_zero_left T).
+Hint Resolve (SR_plus_zero_left2 T).
+Hint Resolve (SR_mult_one_left T).
+Hint Resolve (SR_mult_one_left2 T).
+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_permute T).
+Hint Resolve (SR_mult_permute T).
+Hint Resolve (SR_distr_right T).
+Hint Resolve (SR_distr_right2 T).
+Hint Resolve (SR_mult_zero_right T).
+Hint Resolve (SR_mult_zero_right2 T).
+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 refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Remark iacs_aux_ok :
+ forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
+Proof.
+  simple induction s; simpl in |- *; intros.
+  trivial.
+  reflexivity.
+Qed.
+
+Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.
+
+Lemma abstract_varlist_insert_ok :
+ forall (l:varlist) (s:abstract_sum),
+   interp_acs (abstract_varlist_insert l s) =
+   Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).
+
+  simple induction s.
+  trivial.
+
+  simpl in |- *; intros.
+  elim (varlist_lt l v); simpl in |- *.  	
+  eauto.
+  rewrite iacs_aux_ok.
+  rewrite H; auto.
+
+Qed.
+
+Lemma abstract_sum_merge_ok :
+ forall x y:abstract_sum,
+   interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
+
+Proof.  
+  simple induction x.
+  trivial.
+  simple induction y; intros.
+
+  auto.
+
+  simpl in |- *; elim (varlist_lt v v0); simpl in |- *.
+  repeat rewrite iacs_aux_ok.
+  rewrite H; simpl in |- *; auto.
+
+  simpl in H0.
+  repeat rewrite iacs_aux_ok.
+  rewrite H0. simpl in |- *; auto.
+Qed.
+
+Lemma abstract_sum_scalar_ok :
+ forall (l:varlist) (s:abstract_sum),
+   interp_acs (abstract_sum_scalar l s) =
+   Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
+Proof.
+  simple induction s.
+  simpl in |- *; eauto.
+
+  simpl in |- *; 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.
+Qed.
+
+Lemma abstract_sum_prod_ok :
+ forall x y:abstract_sum,
+   interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).
+
+Proof.
+  simple induction x.
+  intros; simpl in |- *; eauto.
+
+  destruct y as [| v0 a0]; intros.
+
+  simpl in |- *; rewrite H; eauto.
+
+  unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *.
+  rewrite abstract_sum_merge_ok.
+  rewrite abstract_sum_scalar_ok.
+  rewrite H; simpl in |- *; auto.
+Qed.
+
+Theorem aspolynomial_normalize_ok :
+ forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
+Proof.
+  simple induction x; simpl in |- *; intros; trivial.
+  rewrite abstract_sum_merge_ok.
+  rewrite H; rewrite H0; eauto.
+  rewrite abstract_sum_prod_ok.
+  rewrite H; rewrite H0; eauto.
+Qed.
+
+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 apolynomial : Type :=
+  | 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 :=
+  match s1 with
+  | Plus_varlist l1 t1 =>
+      (fix ssm_aux (s2:signed_sum) : signed_sum :=
+         match s2 with
+         | 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 (s2:signed_sum) : signed_sum :=
+         match s2 with
+         | 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 => fun s2 => s2
+  end.
+
+Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
+ signed_sum :=
+  match s2 with
+  | 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) {struct s2} :
+ signed_sum :=
+  match s2 with
+  | 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 :=
+  match s with
+  | 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) {struct s2} :
+ signed_sum :=
+  match s2 with
+  | 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) {struct s2} :
+ signed_sum :=
+  match s2 with
+  | 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 s2:signed_sum) {struct s1} : signed_sum :=
+  match s1 with
+  | 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 :=
+  match p with
+  | 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 (a:A) (s:signed_sum) {struct s} : A :=
+                 match s with
+                 | 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 :=
+  match s with
+  | 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 :=
+  match p with
+  | 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 Resolve (Th_plus_comm T).
+Hint Resolve (Th_plus_assoc T).
+Hint Resolve (Th_plus_assoc2 T).
+Hint Resolve (Th_mult_sym T).
+Hint Resolve (Th_mult_assoc T).
+Hint Resolve (Th_mult_assoc2 T).
+Hint Resolve (Th_plus_zero_left T).
+Hint Resolve (Th_plus_zero_left2 T).
+Hint Resolve (Th_mult_one_left T).
+Hint Resolve (Th_mult_one_left2 T).
+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_permute T).
+Hint Resolve (Th_mult_permute T).
+Hint Resolve (Th_distr_right T).
+Hint Resolve (Th_distr_right2 T).
+Hint Resolve (Th_mult_zero_right2 T).
+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 refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Lemma isacs_aux_ok :
+ forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
+Proof.
+  simple induction s; simpl in |- *; intros.
+  trivial.
+  reflexivity.
+  reflexivity.
+Qed.
+
+Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
+
+Ltac solve1 v v0 H H0 :=
+  simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok;
+   [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ].
+
+Lemma signed_sum_merge_ok :
+ forall x y:signed_sum,
+   interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
+
+  simple induction x.
+  intro; simpl in |- *; auto.
+
+  simple induction y; intros.
+
+  auto.
+
+  solve1 v v0 H H0.
+
+  simpl in |- *; generalize (varlist_eq_prop v v0).
+  elim (varlist_eq v v0); simpl in |- *.
+
+  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_comm 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.
+
+  simple induction y; intros.
+
+  auto.
+
+  simpl in |- *; generalize (varlist_eq_prop v v0).
+  elim (varlist_eq v v0); simpl in |- *.
+
+  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.
+
+Qed.
+
+Ltac solve2 l v H :=
+  elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok;
+   [ auto | rewrite H; auto ].
+
+Lemma plus_varlist_insert_ok :
+ forall (l:varlist) (s:signed_sum),
+   interp_sacs (plus_varlist_insert l s) =
+   Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
+Proof.
+
+  simple induction s.
+  trivial.
+
+  simpl in |- *; intros.
+  solve2 l v H.
+
+  simpl in |- *; intros.
+  generalize (varlist_eq_prop l v).
+  elim (varlist_eq l v); simpl in |- *.
+
+  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.
+
+Qed.
+
+Lemma minus_varlist_insert_ok :
+ forall (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.
+
+  simple induction s.
+  trivial.
+
+  simpl in |- *; intros.
+  generalize (varlist_eq_prop l v).
+  elim (varlist_eq l v); simpl in |- *.
+
+  intro Heq; rewrite (Heq I).
+  repeat rewrite isacs_aux_ok.
+  repeat rewrite (Th_plus_assoc T).
+  rewrite
+   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
+      (interp_vl Amult Aone Azero vm v)).
+  rewrite (Th_opp_def T).
+  auto.
+
+  simpl in |- *; intros.
+  solve2 l v H.
+
+  simpl in |- *; intros; solve2 l v H.
+
+Qed.
+
+Lemma signed_sum_opp_ok :
+ forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
+Proof.
+
+  simple induction s; simpl in |- *; intros.
+
+  symmetry  in |- *; 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.
+
+Qed.
+
+Lemma plus_sum_scalar_ok :
+ forall (l:varlist) (s:signed_sum),
+   interp_sacs (plus_sum_scalar l s) =
+   Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
+Proof.
+
+  simple induction s.
+  trivial.
+
+  simpl in |- *; 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 in |- *; 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.
+
+Qed.
+
+Lemma minus_sum_scalar_ok :
+ forall (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.
+
+  simple induction s; simpl in |- *; intros.
+
+  rewrite (Th_mult_zero_right T); symmetry  in |- *; apply (Th_opp_zero T).
+
+  simpl in |- *; 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 in |- *; 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.
+
+Qed.
+
+Lemma signed_sum_prod_ok :
+ forall x y:signed_sum,
+   interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
+Proof.
+
+  simple induction x.
+
+  simpl in |- *; eauto 1.
+
+  intros; simpl in |- *.
+  rewrite signed_sum_merge_ok.
+  rewrite plus_sum_scalar_ok.
+  repeat rewrite isacs_aux_ok.
+  rewrite H.
+  auto.
+
+  intros; simpl in |- *.
+  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.
+
+Qed.
+
+Theorem apolynomial_normalize_ok :
+ forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
+Proof.
+  simple induction p; simpl in |- *; 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.
+Qed.  
+
+End abstract_rings.
\ No newline at end of file
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
new file mode 100644
index 00000000..8c0fd5fb
--- /dev/null
+++ b/contrib/ring/Ring_normalize.v
@@ -0,0 +1,901 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+Require Import Ring_theory.
+Require Import Quote.
+
+Set Implicit Arguments.
+
+Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
+Proof.
+  intros.
+  apply index_eq_prop.
+  generalize H.
+  case (index_eq n m); simpl in |- *; trivial; intros.
+  contradiction.
+Qed.
+
+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) {struct y} : bool :=
+  match x, y with
+  | 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) {struct y} : bool :=
+  match x, y with
+  | 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 :=
+  match l1 with
+  | Cons_var v1 t1 =>
+      (fix vm_aux (l2:varlist) : varlist :=
+         match l2 with
+         | 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 => fun l2 => l2
+  end.
+
+(* returns the sum of two canonical sums  *)
+Fixpoint canonical_sum_merge (s1:canonical_sum) :
+ canonical_sum -> canonical_sum :=
+  match s1 with
+  | Cons_monom c1 l1 t1 =>
+      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
+         match s2 with
+         | 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 (s2:canonical_sum) : canonical_sum :=
+         match s2 with
+         | 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 => fun s2 => s2
+  end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+  match s2 with
+  | 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) {struct s2} :
+ canonical_sum :=
+  match s2 with
+  | 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) {struct s} :
+ canonical_sum :=
+  match s with
+  | 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) {struct s} :
+ canonical_sum :=
+  match s with
+  | 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) {struct s} : canonical_sum :=
+  match s with
+  | 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 s2:canonical_sum) {struct s1} :
+ canonical_sum :=
+  match s1 with
+  | 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 spolynomial : Type :=
+  | SPvar : index -> spolynomial
+  | SPconst : A -> spolynomial
+  | SPplus : spolynomial -> spolynomial -> spolynomial
+  | SPmult : spolynomial -> spolynomial -> spolynomial.
+
+Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
+  match p with
+  | 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 :=
+  match s with
+  | 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 (x:index) (t:varlist) {struct t} : A :=
+                 match t with
+                 | Nil_var => interp_var x
+                 | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
+                 end).
+
+Definition interp_vl (l:varlist) :=
+  match l with
+  | Nil_var => Aone
+  | Cons_var x t => ivl_aux x t
+  end.
+
+(* Local *) Definition interp_m (c:A) (l:varlist) :=
+              match l with
+              | Nil_var => c
+              | Cons_var x t => Amult c (ivl_aux x t)
+              end.
+
+(* Local *) Definition ics_aux :=
+              (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
+                 match s with
+                 | 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 (s:canonical_sum) : A :=
+  match s with
+  | 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 :=
+  match p with
+  | 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 Resolve (SR_plus_comm T).
+Hint Resolve (SR_plus_assoc T).
+Hint Resolve (SR_plus_assoc2 T).
+Hint Resolve (SR_mult_comm T).
+Hint Resolve (SR_mult_assoc T).
+Hint Resolve (SR_mult_assoc2 T).
+Hint Resolve (SR_plus_zero_left T).
+Hint Resolve (SR_plus_zero_left2 T).
+Hint Resolve (SR_mult_one_left T).
+Hint Resolve (SR_mult_one_left2 T).
+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_permute T).
+Hint Resolve (SR_mult_permute T).
+Hint Resolve (SR_distr_right T).
+Hint Resolve (SR_distr_right2 T).
+Hint Resolve (SR_mult_zero_right T).
+Hint Resolve (SR_mult_zero_right2 T).
+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 refl_equal sym_equal trans_equal.
+(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
+Hint Immediate T.
+
+Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
+Proof.
+  simple induction x; simple induction y; contradiction || (try reflexivity).
+  simpl in |- *; intros.
+  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
+  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
+Qed.
+
+Remark ivl_aux_ok :
+ forall (v:varlist) (i:index),
+   ivl_aux i v = Amult (interp_var i) (interp_vl v).
+Proof.
+  simple induction v; simpl in |- *; intros.
+  trivial.
+  rewrite H; trivial.
+Qed.
+
+Lemma varlist_merge_ok :
+ forall x y:varlist,
+   interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
+Proof.
+  simple induction x.
+  simpl in |- *; trivial.
+  simple induction y.
+  simpl in |- *; trivial.
+  simpl in |- *; intros.
+  elim (index_lt i i0); simpl in |- *; intros.
+
+  repeat rewrite ivl_aux_ok.
+  rewrite H. simpl in |- *.
+  rewrite ivl_aux_ok.
+  eauto.
+
+  repeat rewrite ivl_aux_ok.
+  rewrite H0.
+  rewrite ivl_aux_ok.
+  eauto.
+Qed.
+
+Remark ics_aux_ok :
+ forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
+Proof.
+  simple induction s; simpl in |- *; intros.
+  trivial.
+  reflexivity.
+  reflexivity.
+Qed.
+
+Remark interp_m_ok :
+ forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
+Proof.
+  destruct l as [| i v].
+  simpl in |- *; trivial.
+  reflexivity.
+Qed.
+
+Lemma canonical_sum_merge_ok :
+ forall x y:canonical_sum,
+   interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
+
+simple induction x; simpl in |- *.
+trivial.
+
+simple induction y; simpl in |- *; intros.
+(* monom and nil *)
+eauto.
+
+(* monom and monom *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+(* monom and varlist *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
+rewrite (SR_mult_one_left T).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+simple induction y; simpl in |- *; intros.
+(* varlist and nil *)
+trivial.
+
+(* varlist and monom *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; 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 f_equal with (f := Aplus (interp_vl v0)).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+(* varlist and varlist *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; 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 f_equal with (f := Aplus (interp_vl v0)).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+Qed.
+
+Lemma monom_insert_ok :
+ forall (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; simple induction s0.
+
+simpl in |- *; rewrite interp_m_ok; trivial.
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; 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 in |- *;
+ [ 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 in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; 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 in |- *;
+ [ 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 ].
+Qed.
+
+Lemma varlist_insert_ok :
+ forall (l:varlist) (s:canonical_sum),
+   interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
+intros; generalize s; simple induction s0.
+
+simpl in |- *; trivial.
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; 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 in |- *;
+ [ 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 in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; 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 in |- *;
+ [ 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 ].
+Qed.
+
+Lemma canonical_sum_scalar_ok :
+ forall (a:A) (s:canonical_sum),
+   interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
+simple induction s.
+simpl in |- *; eauto.
+
+simpl in |- *; 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 in |- *; 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.
+Qed.
+
+Lemma canonical_sum_scalar2_ok :
+ forall (l:varlist) (s:canonical_sum),
+   interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
+simple induction s.
+simpl in |- *; trivial.
+
+simpl in |- *; 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 in |- *; 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.
+Qed.
+
+Lemma canonical_sum_scalar3_ok :
+ forall (c:A) (l:varlist) (s:canonical_sum),
+   interp_cs (canonical_sum_scalar3 c l s) =
+   Amult c (Amult (interp_vl l) (interp_cs s)).
+simple induction s.
+simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity.
+
+simpl in |- *; 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 in |- *; 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.
+Qed.
+
+Lemma canonical_sum_prod_ok :
+ forall x y:canonical_sum,
+   interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
+simple induction x; simpl in |- *; 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  in |- *.
+eauto.
+
+rewrite canonical_sum_merge_ok.
+rewrite canonical_sum_scalar2_ok.
+rewrite ics_aux_ok.
+rewrite H.
+trivial.
+Qed.
+
+Theorem spolynomial_normalize_ok :
+ forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
+simple induction p; simpl in |- *; intros.
+
+reflexivity.
+reflexivity.
+
+rewrite canonical_sum_merge_ok.
+rewrite H; rewrite H0.
+reflexivity.
+
+rewrite canonical_sum_prod_ok.
+rewrite H; rewrite H0.
+reflexivity.
+Qed.
+
+Lemma canonical_sum_simplify_ok :
+ forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
+simple induction s.
+
+reflexivity.
+
+(* cons_monom *)
+simpl in |- *; intros.
+generalize (SR_eq_prop T a 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 in |- *.
+generalize (SR_eq_prop T a Aone).
+elim (Aeq a Aone).
+intro Heq; rewrite (Heq I).
+simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite H.
+rewrite (SR_mult_one_left T).
+reflexivity.
+
+simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite H.
+reflexivity.
+
+(* cons_varlist *)
+simpl in |- *; intros.
+repeat rewrite ics_aux_ok.
+rewrite H.
+reflexivity.
+
+Qed.
+
+Theorem spolynomial_simplify_ok :
+ forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
+intro.
+unfold spolynomial_simplify in |- *.
+rewrite canonical_sum_simplify_ok.
+apply spolynomial_normalize_ok.
+Qed.
+
+(* End properties. *)
+End semi_rings.
+
+Implicit Arguments Cons_varlist.
+Implicit Arguments Cons_monom.
+Implicit Arguments SPconst.
+Implicit Arguments SPplus.
+Implicit Arguments 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 Resolve (Th_plus_comm T).
+Hint Resolve (Th_plus_assoc T).
+Hint Resolve (Th_plus_assoc2 T).
+Hint Resolve (Th_mult_sym T).
+Hint Resolve (Th_mult_assoc T).
+Hint Resolve (Th_mult_assoc2 T).
+Hint Resolve (Th_plus_zero_left T).
+Hint Resolve (Th_plus_zero_left2 T).
+Hint Resolve (Th_mult_one_left T).
+Hint Resolve (Th_mult_one_left2 T).
+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_permute T).
+Hint Resolve (Th_mult_permute T).
+Hint Resolve (Th_distr_right T).
+Hint Resolve (Th_distr_right2 T).
+Hint Resolve (Th_mult_zero_right T).
+Hint Resolve (Th_mult_zero_right2 T).
+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 refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+(*** Definitions *)
+
+Inductive polynomial : Type :=
+  | 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 :=
+  match x with
+  | 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 :=
+  match x with
+  | 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 :=
+  match p with
+  | 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 :
+ forall p:polynomial,
+   interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
+simple induction p; reflexivity || (simpl in |- *; 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.
+Qed.
+
+Theorem polynomial_normalize_ok :
+ forall p:polynomial,
+   polynomial_normalize p =
+   spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
+simple induction p; reflexivity || (simpl in |- *; intros).
+rewrite H; rewrite H0; reflexivity.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; simpl in |- *.
+elim
+ (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
+    (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
+ [ reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity ].
+Qed.
+
+Theorem polynomial_simplify_ok :
+ forall p:polynomial,
+   interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
+intro.
+unfold polynomial_simplify in |- *.
+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.
+Qed.
+
+End rings.
+
+Infix "+" := Pplus : ring_scope.
+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
diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/Ring_theory.v
new file mode 100644
index 00000000..dfdfdf66
--- /dev/null
+++ b/contrib/ring/Ring_theory.v
@@ -0,0 +1,376 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.21.2.1 2004/07/16 19:30:13 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 "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+
+Record Semi_Ring_Theory : Prop := 
+  {SR_plus_comm : forall n m:A, n + m = m + n;
+   SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
+   SR_mult_comm : forall n m:A, n * m = m * n;
+   SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
+   SR_plus_zero_left : forall n:A, 0 + n = n;
+   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_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
+
+Variable T : Semi_Ring_Theory.
+
+Let plus_comm := SR_plus_comm T.
+Let plus_assoc := SR_plus_assoc T.
+Let mult_comm := SR_mult_comm T.
+Let mult_assoc := SR_mult_assoc T.
+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.
+
+Hint Resolve plus_comm plus_assoc mult_comm 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 : forall n m p:A, n * m * p = n * (m * p).
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
+symmetry  in |- *; eauto. Qed.
+
+Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
+intros.
+rewrite plus_assoc.
+elim (plus_comm m n).
+rewrite <- plus_assoc.
+reflexivity.
+Qed.
+
+Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
+intros.
+rewrite mult_assoc.
+elim (mult_comm m n).
+rewrite <- mult_assoc.
+reflexivity.
+Qed.
+
+Hint Resolve SR_plus_permute SR_mult_permute.
+
+Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
+intros.
+repeat rewrite (mult_comm n).
+eauto.
+Qed.
+
+Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
+symmetry  in |- *; apply SR_distr_right. Qed.
+
+Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
+intro; rewrite mult_comm; eauto.
+Qed.
+
+Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0.
+intro; rewrite mult_comm; eauto.
+Qed.
+
+Lemma SR_plus_zero_right : forall n:A, n + 0 = n.
+intro; rewrite plus_comm; eauto.
+Qed.
+Lemma SR_plus_zero_right2 : forall n:A, n = n + 0.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma SR_mult_one_right : forall n:A, n * 1 = n.
+intro; elim mult_comm; auto.
+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.
+
+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 "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+Notation "- x" := (Aopp x).
+
+Record Ring_Theory : Prop := 
+  {Th_plus_comm : forall n m:A, n + m = m + n;
+   Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
+   Th_mult_sym : forall n m:A, n * m = m * n;
+   Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
+   Th_plus_zero_left : forall n:A, 0 + n = n;
+   Th_mult_one_left : forall n:A, 1 * n = n;
+   Th_opp_def : forall n:A, n + - n = 0;
+   Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
+   Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
+
+Variable T : Ring_Theory.
+
+Let plus_comm := Th_plus_comm T.
+Let plus_assoc := Th_plus_assoc T.
+Let mult_comm := Th_mult_sym T.
+Let mult_assoc := Th_mult_assoc T.
+Let plus_zero_left := Th_plus_zero_left T.
+Let mult_one_left := Th_mult_one_left T. 
+Let opp_def := Th_opp_def T.
+Let distr_left := Th_distr_left T.
+
+Hint Resolve plus_comm plus_assoc mult_comm 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 : forall n m p:A, n * m * p = n * (m * p).
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
+intros.
+rewrite plus_assoc.
+elim (plus_comm m n).
+rewrite <- plus_assoc.
+reflexivity.
+Qed.
+
+Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
+intros.
+rewrite mult_assoc.
+elim (mult_comm m n).
+rewrite <- mult_assoc.
+reflexivity.
+Qed.
+
+Hint Resolve Th_plus_permute Th_mult_permute.
+
+Lemma aux1 : forall a:A, a + a = a -> a = 0.
+intros.
+generalize (opp_def a).
+pattern a at 1 in |- *.
+rewrite <- H.
+rewrite <- plus_assoc.
+rewrite opp_def.
+elim plus_comm.
+rewrite plus_zero_left.
+trivial.
+Qed.
+
+Lemma Th_mult_zero_left : forall n:A, 0 * n = 0.
+intros.
+apply aux1.
+rewrite <- distr_left.
+rewrite plus_zero_left.
+reflexivity.
+Qed.
+Hint Resolve Th_mult_zero_left.
+
+Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma aux2 : forall 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_comm y z).
+rewrite plus_assoc.
+rewrite H.
+rewrite plus_zero_left.
+reflexivity.
+Qed.
+
+Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y.
+intros.
+apply (aux2 (x:=(x * y)));
+ [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ].
+Qed.
+Hint Resolve Th_opp_mult_left.
+
+Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_plus_zero_right : forall n:A, n + 0 = n.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma Th_plus_zero_right2 : forall n:A, n = n + 0.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma Th_mult_one_right : forall n:A, n * 1 = n.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_mult_one_right2 : forall n:A, n = n * 1.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y.
+intros; do 2 rewrite (mult_comm x); auto.
+Qed.
+
+Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y).
+intros; do 2 rewrite (mult_comm x); auto.
+Qed.
+
+Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y).
+intros.
+apply (aux2 (x:=(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 : forall n m p:A, - m + (n + p) = n + (- m + p).
+eauto. Qed.
+
+Lemma Th_opp_opp : forall n:A, - - n = n.
+intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ].
+Qed.
+Hint Resolve Th_opp_opp.
+
+Lemma Th_opp_opp2 : forall n:A, n = - - n.
+symmetry  in |- *; eauto. Qed.
+
+Lemma Th_mult_opp_opp : forall 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 : forall x y:A, x * y = - x * - y.
+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.
+rewrite (plus_comm (- n) n).
+rewrite opp_def.
+repeat rewrite Th_plus_zero_left; eauto.
+Qed.
+
+Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
+intros.
+eapply Th_plus_reg_left with n. 
+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).
+eauto.
+Qed.
+
+Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
+symmetry  in |- *; apply Th_distr_right.
+Qed.
+
+End Theory_of_rings.
+
+Hint Resolve Th_mult_zero_left Th_plus_reg_left: core.
+
+Unset Implicit Arguments.
+
+Definition Semi_Ring_Theory_of :
+  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone 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 in |- *; 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.
\ No newline at end of file
diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v
new file mode 100644
index 00000000..c4537fe3
--- /dev/null
+++ b/contrib/ring/Setoid_ring.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.v,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+Require Export Setoid_ring_theory.
+Require Export Quote.
+Require Export Setoid_ring_normalize.
\ No newline at end of file
diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v
new file mode 100644
index 00000000..0c9c1e6a
--- /dev/null
+++ b/contrib/ring/Setoid_ring_normalize.v
@@ -0,0 +1,1137 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+Require Import Setoid_ring_theory.
+Require Import Quote.
+
+Set Implicit Arguments.
+
+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 |- *;
+   try reflexivity || contradiction.
+  intros; rewrite (H i0); trivial.
+  intros; rewrite (H i0); trivial.
+Qed.
+
+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 :
+    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 opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
+
+Add Morphism Aplus : Aplus_ext.
+exact plus_morph.
+Qed.
+
+Add Morphism Amult : Amult_ext.
+exact mult_morph.
+Qed.
+
+Add Morphism Aopp : Aopp_ext.
+exact opp_morph.
+Qed.
+
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve equiv_refl equiv_trans.
+Hint 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) {struct y} : bool :=
+  match x, y with
+  | 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) {struct y} : bool :=
+  match x, y with
+  | 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 :=
+  match l1 with
+  | Cons_var v1 t1 =>
+      (fix vm_aux (l2:varlist) : varlist :=
+         match l2 with
+         | 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 => fun l2 => l2
+  end.
+
+(* returns the sum of two canonical sums  *)
+Fixpoint canonical_sum_merge (s1:canonical_sum) :
+ canonical_sum -> canonical_sum :=
+  match s1 with
+  | Cons_monom c1 l1 t1 =>
+      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
+         match s2 with
+         | 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 (s2:canonical_sum) : canonical_sum :=
+         match s2 with
+         | 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 => fun s2 => s2
+  end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+  match s2 with
+  | 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) {struct s2} :
+ canonical_sum :=
+  match s2 with
+  | 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) {struct s} :
+ canonical_sum :=
+  match s with
+  | 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) {struct s} :
+ canonical_sum :=
+  match s with
+  | 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) {struct s} : canonical_sum :=
+  match s with
+  | 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 s2:canonical_sum) {struct s1} :
+ canonical_sum :=
+  match s1 with
+  | 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 setspolynomial : Type :=
+  | SetSPvar : index -> setspolynomial
+  | SetSPconst : A -> setspolynomial
+  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
+  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
+
+Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
+  match p with
+  | 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 :=
+  match s with
+  | 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 (x:index) (t:varlist) {struct t} : A :=
+     match t with
+     | Nil_var => interp_var x
+     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
+     end).
+
+Definition interp_vl (l:varlist) :=
+  match l with
+  | Nil_var => Aone
+  | Cons_var x t => ivl_aux x t
+  end.
+
+Definition interp_m (c:A) (l:varlist) :=
+  match l with
+  | Nil_var => c
+  | Cons_var x t => Amult c (ivl_aux x t)
+  end.
+
+Definition ics_aux :=
+  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
+     match s with
+     | 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 (s:canonical_sum) : A :=
+  match s with
+  | 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 :=
+  match p with
+  | 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 Resolve (SSR_plus_comm T).
+Hint Resolve (SSR_plus_assoc T).
+Hint Resolve (SSR_plus_assoc2 S T).
+Hint Resolve (SSR_mult_comm T).
+Hint Resolve (SSR_mult_assoc T).
+Hint Resolve (SSR_mult_assoc2 S T).
+Hint Resolve (SSR_plus_zero_left T).
+Hint Resolve (SSR_plus_zero_left2 S T).
+Hint Resolve (SSR_mult_one_left T).
+Hint Resolve (SSR_mult_one_left2 S T).
+Hint Resolve (SSR_mult_zero_left T).
+Hint Resolve (SSR_mult_zero_left2 S T).
+Hint Resolve (SSR_distr_left T).
+Hint Resolve (SSR_distr_left2 S T).
+Hint Resolve (SSR_plus_reg_left T).
+Hint Resolve (SSR_plus_permute S plus_morph T).
+Hint Resolve (SSR_mult_permute S mult_morph T).
+Hint Resolve (SSR_distr_right S plus_morph T).
+Hint Resolve (SSR_distr_right2 S plus_morph T).
+Hint Resolve (SSR_mult_zero_right S T).
+Hint Resolve (SSR_mult_zero_right2 S T).
+Hint Resolve (SSR_plus_zero_right S T).
+Hint Resolve (SSR_plus_zero_right2 S T).
+Hint Resolve (SSR_mult_one_right S T).
+Hint Resolve (SSR_mult_one_right2 S T).
+Hint Resolve (SSR_plus_reg_right S T).
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
+Proof.
+  simple induction x; simple induction y; contradiction || (try reflexivity).
+  simpl in |- *; intros.
+  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
+  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
+Qed.
+
+Remark ivl_aux_ok :
+ forall (v:varlist) (i:index),
+   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
+Proof.
+  simple induction v; simpl in |- *; intros.
+  trivial.
+  rewrite (H i); trivial.
+Qed.
+
+Lemma varlist_merge_ok :
+ forall x y:varlist,
+   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
+Proof.
+  simple induction x.
+  simpl in |- *; trivial.
+  simple induction y.
+  simpl in |- *; trivial.
+  simpl in |- *; intros.
+  elim (index_lt i i0); simpl in |- *; 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 in |- *.
+  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 (l2:varlist) : varlist :=
+          match l2 with
+          | 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.
+Qed.
+
+Remark ics_aux_ok :
+ forall (x:A) (s:canonical_sum),
+   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
+Proof.
+ simple induction s; simpl in |- *; intros; trivial.
+Qed.
+
+Remark interp_m_ok :
+ forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
+Proof.
+  destruct l as [| i v]; trivial.
+Qed.
+
+Hint Resolve ivl_aux_ok.
+Hint Resolve ics_aux_ok.
+Hint Resolve interp_m_ok.
+
+(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
+
+Lemma canonical_sum_merge_ok :
+ forall x y:canonical_sum,
+   Aequiv (interp_setcs (canonical_sum_merge x y))
+     (Aplus (interp_setcs x) (interp_setcs y)).
+Proof.
+simple induction x; simpl in |- *.
+trivial.
+
+simple induction y; simpl in |- *; intros.
+eauto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+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 in |- *.
+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 in |- *.
+rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
+
+intro.
+rewrite
+ (ics_aux_ok (interp_m a0 v0)
+    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
+        match s2 with
+        | 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 in |- *; 
+ auto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+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 in |- *.
+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 in |- *.
+rewrite (ics_aux_ok (interp_vl v0) c0).
+auto.
+
+intro.
+rewrite
+ (ics_aux_ok (interp_vl v0)
+    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
+        match s2 with
+        | 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 in |- *.
+auto.
+
+simple induction y; simpl in |- *; intros.
+trivial.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+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 in |- *; 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 in |- *.
+rewrite (ics_aux_ok (interp_m a v0) c0); auto.
+
+rewrite
+ (ics_aux_ok (interp_m a v0)
+    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+        match s2 with
+        | 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 in |- *; auto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0); intros.
+rewrite (H1 I); simpl in |- *.
+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 in |- *.
+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 in |- *.
+rewrite (ics_aux_ok (interp_vl v0) c0); auto.
+
+rewrite
+ (ics_aux_ok (interp_vl v0)
+    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+        match s2 with
+        | 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 in |- *; auto.
+Qed.
+
+Lemma monom_insert_ok :
+ forall (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.
+simple induction s; intros.
+simpl in |- *; rewrite (interp_m_ok a l); trivial.
+
+simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+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 in |- *; 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 in |- *.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+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 in |- *; 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.
+Qed.
+
+Lemma varlist_insert_ok :
+ forall (l:varlist) (s:canonical_sum),
+   Aequiv (interp_setcs (varlist_insert l s))
+     (Aplus (interp_vl l) (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; intros.
+trivial.
+
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+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 in |- *; 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 in |- *.
+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 in |- *; intros; auto.
+rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
+rewrite H.
+rewrite (ics_aux_ok (interp_vl v) c); auto.
+Qed.
+
+Lemma canonical_sum_scalar_ok :
+ forall (a:A) (s:canonical_sum),
+   Aequiv (interp_setcs (canonical_sum_scalar a s))
+     (Amult a (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; 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.
+Qed.
+
+Lemma canonical_sum_scalar2_ok :
+ forall (l:varlist) (s:canonical_sum),
+   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
+     (Amult (interp_vl l) (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; 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.
+Qed.
+
+Lemma canonical_sum_scalar3_ok :
+ forall (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.
+simple induction s; simpl in |- *; 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.
+Qed.
+
+Lemma canonical_sum_prod_ok :
+ forall x y:canonical_sum,
+   Aequiv (interp_setcs (canonical_sum_prod x y))
+     (Amult (interp_setcs x) (interp_setcs y)).
+Proof.
+simple induction x; simpl in |- *; 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.
+Qed.
+
+Theorem setspolynomial_normalize_ok :
+ forall p:setspolynomial,
+   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
+Proof.
+simple induction p; simpl in |- *; 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.
+Qed.
+
+Lemma canonical_sum_simplify_ok :
+ forall s:canonical_sum,
+   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
+Proof.
+simple induction s; simpl in |- *; intros.
+trivial.
+
+generalize (SSR_eq_prop T a Azero).
+elim (Aeq a Azero).
+simpl in |- *.
+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 in |- *.
+generalize (SSR_eq_prop T a 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 in |- *.
+rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
+rewrite H.
+auto.
+
+simpl in |- *.
+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.
+Qed.
+
+Theorem setspolynomial_simplify_ok :
+ forall p:setspolynomial,
+   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
+Proof.
+intro.
+unfold setspolynomial_simplify in |- *.
+rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
+exact (setspolynomial_normalize_ok p).
+Qed.
+
+End semi_setoid_rings.
+
+Implicit Arguments Cons_varlist.
+Implicit Arguments Cons_monom.
+Implicit Arguments SetSPconst.
+Implicit Arguments SetSPplus.
+Implicit Arguments SetSPmult.
+
+
+
+Section setoid_rings.
+
+Set Implicit Arguments.
+
+Variable vm : varmap A.
+Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.
+
+Hint Resolve (STh_plus_comm T).
+Hint Resolve (STh_plus_assoc T).
+Hint Resolve (STh_plus_assoc2 S T).
+Hint Resolve (STh_mult_sym T).
+Hint Resolve (STh_mult_assoc T).
+Hint Resolve (STh_mult_assoc2 S T).
+Hint Resolve (STh_plus_zero_left T).
+Hint Resolve (STh_plus_zero_left2 S T).
+Hint Resolve (STh_mult_one_left T).
+Hint Resolve (STh_mult_one_left2 S T).
+Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
+Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
+Hint Resolve (STh_distr_left T).
+Hint Resolve (STh_distr_left2 S T).
+Hint Resolve (STh_plus_reg_left S plus_morph T).
+Hint Resolve (STh_plus_permute S plus_morph T).
+Hint Resolve (STh_mult_permute S mult_morph T).
+Hint Resolve (STh_distr_right S plus_morph T).
+Hint Resolve (STh_distr_right2 S plus_morph T).
+Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
+Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
+Hint Resolve (STh_plus_zero_right S T).
+Hint Resolve (STh_plus_zero_right2 S T).
+Hint Resolve (STh_mult_one_right S T).
+Hint Resolve (STh_mult_one_right2 S T).
+Hint Resolve (STh_plus_reg_right S plus_morph T).
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+
+(*** Definitions *)
+
+Inductive setpolynomial : Type :=
+  | SetPvar : index -> setpolynomial
+  | SetPconst : A -> setpolynomial
+  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
+  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
+  | SetPopp : setpolynomial -> setpolynomial.
+
+Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
+  match x with
+  | 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 :=
+  match x with
+  | 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 :=
+  match p with
+  | 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 :
+ forall p:setpolynomial,
+   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
+simple induction p; trivial; simpl in |- *; 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.
+Qed.
+
+Theorem setpolynomial_normalize_ok :
+ forall p:setpolynomial,
+   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
+simple induction p; trivial; simpl in |- *; intros.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; simpl in |- *.
+elim
+ (canonical_sum_scalar3 (Aopp Aone) Nil_var
+    (setspolynomial_normalize (setspolynomial_of s)));
+ [ reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity ].
+Qed.
+
+Theorem setpolynomial_simplify_ok :
+ forall p:setpolynomial,
+   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
+intro.
+unfold setpolynomial_simplify in |- *.
+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.
+Qed.
+
+End setoid_rings.
+
+End setoid.
\ No newline at end of file
diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v
new file mode 100644
index 00000000..69712216
--- /dev/null
+++ b/contrib/ring/Setoid_ring_theory.v
@@ -0,0 +1,427 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:30:13 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 70, 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 "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+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 opp_morph : forall a a0:A, a == a0 -> - a == - a0.
+
+Add Morphism Aplus : Aplus_ext.
+exact plus_morph.
+Qed.
+
+Add Morphism Amult : Amult_ext.
+exact mult_morph.
+Qed.
+
+Add Morphism Aopp : Aopp_ext.
+exact opp_morph.
+Qed.
+
+Section Theory_of_semi_setoid_rings.
+
+Record Semi_Setoid_Ring_Theory : Prop := 
+  {SSR_plus_comm : forall n m:A, n + m == m + n;
+   SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
+   SSR_mult_comm : forall n m:A, n * m == m * n;
+   SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
+   SSR_plus_zero_left : forall n:A, 0 + n == n;
+   SSR_mult_one_left : forall n:A, 1 * n == n;
+   SSR_mult_zero_left : forall n:A, 0 * n == 0;
+   SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
+   SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
+   SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
+
+Variable T : Semi_Setoid_Ring_Theory.
+
+Let plus_comm := SSR_plus_comm T.
+Let plus_assoc := SSR_plus_assoc T.
+Let mult_comm := SSR_mult_comm T.
+Let mult_assoc := SSR_mult_assoc T.
+Let plus_zero_left := SSR_plus_zero_left T.
+Let mult_one_left := SSR_mult_one_left T. 
+Let mult_zero_left := SSR_mult_zero_left T.
+Let distr_left := SSR_distr_left T.
+Let plus_reg_left := SSR_plus_reg_left T.
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
+  mult_one_left mult_zero_left distr_left plus_reg_left
+  equiv_refl (*equiv_sym*).
+Hint 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 : forall n m p:A, n * m * p == n * (m * p).
+auto. Qed.
+
+Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
+auto. Qed.
+
+Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
+auto. Qed.
+
+Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
+auto. Qed.
+
+Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
+auto. Qed.
+
+Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
+auto. Qed.
+
+Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
+intros.
+rewrite (plus_assoc n m p).
+rewrite (plus_comm n m).
+rewrite <- (plus_assoc m n p).
+trivial.
+Qed.
+
+Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
+intros.
+rewrite (mult_assoc n m p).
+rewrite (mult_comm n m).
+rewrite <- (mult_assoc m n p).
+trivial.
+Qed.
+
+Hint Resolve SSR_plus_permute SSR_mult_permute.
+
+Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
+intros.
+rewrite (mult_comm n (m + p)).
+rewrite (mult_comm n m).
+rewrite (mult_comm n p).
+auto.
+Qed.
+
+Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
+intros.
+apply equiv_sym.
+apply SSR_distr_right.
+Qed.
+
+Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma SSR_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).
+intro; apply plus_reg_left with n; trivial.
+Qed.
+
+End Theory_of_semi_setoid_rings.
+
+Section Theory_of_setoid_rings.
+
+Record Setoid_Ring_Theory : Prop := 
+  {STh_plus_comm : forall n m:A, n + m == m + n;
+   STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
+   STh_mult_sym : forall n m:A, n * m == m * n;
+   STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
+   STh_plus_zero_left : forall n:A, 0 + n == n;
+   STh_mult_one_left : forall n:A, 1 * n == n;
+   STh_opp_def : forall n:A, n + - n == 0;
+   STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
+   STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
+
+Variable T : Setoid_Ring_Theory.
+
+Let plus_comm := STh_plus_comm T.
+Let plus_assoc := STh_plus_assoc T.
+Let mult_comm := STh_mult_sym T.
+Let mult_assoc := STh_mult_assoc T.
+Let plus_zero_left := STh_plus_zero_left T.
+Let mult_one_left := STh_mult_one_left T. 
+Let opp_def := STh_opp_def T.
+Let distr_left := STh_distr_left T.
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve plus_comm plus_assoc mult_comm 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 : forall n m p:A, n * m * p == n * (m * p).
+auto. Qed.
+
+Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
+auto. Qed.
+
+Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
+auto. Qed.
+
+Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
+auto. Qed.
+
+Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
+auto. Qed.
+
+Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
+auto. Qed.
+
+Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
+intros.
+rewrite (plus_assoc n m p).
+rewrite (plus_comm n m).
+rewrite <- (plus_assoc m n p).
+trivial.
+Qed.
+
+Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
+intros.
+rewrite (mult_assoc n m p).
+rewrite (mult_comm n m).
+rewrite <- (mult_assoc m n p).
+trivial.
+Qed.
+
+Hint Resolve STh_plus_permute STh_mult_permute.
+
+Lemma Saux1 : forall a:A, a + a == a -> a == 0.
+intros.
+rewrite <- (plus_zero_left a).
+rewrite (plus_comm 0 a).
+setoid_replace (a + 0) with (a + (a + - a)); auto.
+rewrite (plus_assoc a a (- a)).
+rewrite H.
+apply opp_def.
+Qed.
+
+Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
+intros.
+apply Saux1.
+rewrite <- (distr_left 0 0 n).
+rewrite (plus_zero_left 0).
+trivial.
+Qed.
+Hint Resolve STh_mult_zero_left.
+
+Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
+auto.
+Qed.
+
+Lemma Saux2 : forall 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_comm z y).
+rewrite (plus_assoc x y z).
+rewrite H.
+auto.
+Qed.
+
+Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
+intros.
+apply Saux2 with (x * y); auto.
+rewrite <- (distr_left x (- x) y).
+rewrite (opp_def x).
+auto.
+Qed.
+Hint Resolve STh_opp_mult_left.
+
+Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
+auto.
+Qed.
+
+Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma STh_mult_one_right : forall n:A, n * 1 == n.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
+intros.
+rewrite (mult_comm x y).
+rewrite (mult_comm x (- y)).
+auto.
+Qed.
+
+Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
+intros.
+rewrite (mult_comm x y).
+rewrite (mult_comm x (- y)).
+auto.
+Qed.
+
+Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
+intros.
+apply Saux2 with (x + y); auto.
+rewrite (STh_plus_permute (x + y) (- x) (- y)).
+rewrite <- (plus_assoc x y (- y)).
+rewrite (opp_def y); rewrite (STh_plus_zero_right x).
+rewrite (STh_opp_def2 x); trivial.
+Qed.
+
+Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
+auto.
+Qed.
+
+Lemma STh_opp_opp : forall n:A, - - n == n.
+intro.
+apply Saux2 with (- n); auto.
+rewrite (plus_comm (- n) n); auto.
+Qed.
+Hint Resolve STh_opp_opp.
+
+Lemma STh_opp_opp2 : forall n:A, n == - - n.
+auto.
+Qed.
+
+Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
+intros.
+rewrite (STh_opp_mult_left2 x (- y)).
+rewrite (STh_opp_mult_right2 x y).
+trivial.
+Qed.
+
+Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
+intros.
+apply equiv_sym.
+apply STh_mult_opp_opp.
+Qed.
+
+Lemma STh_opp_zero : - 0 == 0.
+rewrite <- (plus_zero_left (- 0)).
+trivial.
+Qed.
+
+Lemma STh_plus_reg_left : forall 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_comm n (- n)).
+rewrite <- (plus_assoc (- n) n m).
+rewrite <- (plus_assoc (- n) n p).
+auto.
+Qed.
+
+Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
+intros.
+apply STh_plus_reg_left with n.
+rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
+Qed.
+
+Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
+intros.
+rewrite (mult_comm n (m + p)).
+rewrite (mult_comm n m).
+rewrite (mult_comm n p).
+trivial.
+Qed.
+
+Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
+intros.
+apply equiv_sym.
+apply STh_distr_right.
+Qed.
+
+End Theory_of_setoid_rings.
+
+Hint 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 in |- *; 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.
\ No newline at end of file
diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/ZArithRing.v
new file mode 100644
index 00000000..c511c076
--- /dev/null
+++ b/contrib/ring/ZArithRing.v
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+(* Instantiation of the Ring tactic for the binary integers of ZArith *)
+
+Require Export ArithRing.
+Require Export ZArith_base.
+Require Import Eqdep_dec.
+
+Definition Zeq (x y:Z) :=
+  match (x ?= y)%Z with
+  | Datatypes.Eq => true
+  | _ => false
+  end.
+
+Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
+  intros x y H; unfold Zeq in H.
+  apply Zcompare_Eq_eq.
+  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
+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.
+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
diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4
new file mode 100644
index 00000000..af23a8f7
--- /dev/null
+++ b/contrib/ring/g_quote.ml4
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_quote.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+open Quote
+
+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
new file mode 100644
index 00000000..f7c74c0b
--- /dev/null
+++ b/contrib/ring/g_ring.ml4
@@ -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 camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_ring.ml4,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *)
+
+open Quote
+open Ring
+
+TACTIC EXTEND Ring
+  [ "Ring" constr_list(l) ] -> [ polynom l ]
+END
+
+(* The vernac commands "Add Ring" and co *)
+
+let cset_of_constrarg_list l = 
+  List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
+
+VERNAC COMMAND EXTEND AddRing
+  [ "Add" "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
+			 (constr_of a)
+			 None
+			 None
+			 None
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 (Some (constr_of aopp))
+			 (constr_of aeq)
+			 (constr_of t)
+			 (cset_of_constrarg_list l) ]
+
+| [ "Add" "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
+			 (constr_of a)
+			 None
+			 None
+			 None
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 None
+			 (constr_of aeq)
+			 (constr_of t)
+			 (cset_of_constrarg_list l) ]
+
+| [ "Add" "Abstract" "Ring" 
+    	  constr(a) constr(aplus) constr(amult) constr(aone)
+          constr(azero) constr(aopp) constr(aeq) constr(t) ] 
+  -> [ add_theory true true false
+			 (constr_of a)
+			 None
+			 None
+			 None
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 (Some (constr_of aopp))
+			 (constr_of aeq)
+			 (constr_of t)
+			 ConstrSet.empty ]
+
+| [ "Add" "Abstract" "Semi" "Ring" 
+          constr(a) constr(aplus) constr(amult) constr(aone)
+          constr(azero) constr(aeq) constr(t) ] 
+  -> [ add_theory false true false
+			 (constr_of a)
+			 None
+			 None
+			 None
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 None
+			 (constr_of aeq)
+			 (constr_of t)
+			 ConstrSet.empty ]
+
+| [ "Add" "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) "]" ] 
+  -> [ add_theory true false true
+			 (constr_of a)
+			 (Some (constr_of aequiv))
+			 (Some (constr_of asetth))
+			 (Some {
+			    plusm = (constr_of pm);
+			    multm = (constr_of mm);
+			    oppm = Some (constr_of om) })
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 (Some (constr_of aopp))
+			 (constr_of aeq)
+			 (constr_of t)
+			 (cset_of_constrarg_list l) ]
+
+| [ "Add" "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) "]" ] 
+  -> [ add_theory false false true
+			 (constr_of a)
+			 (Some (constr_of aequiv))
+			 (Some (constr_of asetth))
+			 (Some {
+			    plusm = (constr_of pm);
+			    multm = (constr_of mm);
+			    oppm = None })
+			 (constr_of aplus)
+			 (constr_of amult)
+			 (constr_of aone)
+			 (constr_of azero)
+			 None
+			 (constr_of aeq)
+			 (constr_of t)
+			 (cset_of_constrarg_list l) ]
+END
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
new file mode 100644
index 00000000..bda04db3
--- /dev/null
+++ b/contrib/ring/quote.ml
@@ -0,0 +1,489 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.ml,v 1.30.2.1 2004/07/16 19:30:14 herbelin Exp $ *)
+
+(* The `Quote' tactic *)
+
+(* The basic idea is to automatize the inversion of interpetation functions 
+   in 2-level approach 
+
+   Examples are given in \texttt{theories/DEMOS/DemoQuote.v}
+
+   Suppose you have a langage \texttt{L} of 'abstract terms' 
+   and a type \texttt{A} of 'concrete terms' 
+   and a function \texttt{f : L -> (varmap A L) -> A}.
+
+   Then, the tactic \texttt{Quote f} will replace an
+   expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} 
+   such that \texttt{e} and \texttt{(f vm t)} are convertible.
+
+   The problem is then inverting the function f.
+
+   The tactic works when:
+
+   \begin{itemize}
+   \item L is a simple inductive datatype. The constructors of L may
+     have one of the three following forms:
+
+     \begin{enumerate}
+     \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L|
+     \item variable leaf like: \verb|Cvar : index -> L|
+     \item constant leaf like \verb|Cconst : A -> L|
+     \end{enumerate}
+
+     The definition of \texttt{L} must contain at most one variable
+     leaf and at most one constant leaf.
+
+     When there are both a variable leaf and a constant leaf, there is
+     an ambiguity on inversion. The term t can be either the
+     interpretation of \texttt{(Cconst t)} or the interpretation of
+     (\texttt{Cvar}~$i$) in a variables map containing the binding $i
+     \rightarrow$~\texttt{t}. How to discriminate between these
+     choices ?
+     
+     To solve the dilemma, one gives to \texttt{Quote} a list of
+     \emph{constant constructors}: a term will be considered as a
+     constant if it is either a constant constructor of the
+     application of a constant constructor to constants. For example
+     the list \verb+[S, O]+ defines the closed natural
+     numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is
+     not. 
+
+     The definition of constants vary for each application of the
+     tactic, so it can even be different for two applications of 
+     \texttt{Quote} with the same function.
+     
+   \item \texttt{f} is a quite simple fixpoint on
+     \texttt{L}. In particular, \texttt{f} must verify: 
+
+\begin{verbatim}
+     (f (Cvar i)) = (varmap_find vm default_value i)
+\end{verbatim}
+\begin{verbatim}
+     (f (Cconst c)) = c
+\end{verbatim}
+
+     where \texttt{index} and \texttt{varmap\_find} are those defined
+     the \texttt{Quote} module. \emph{The tactic won't work with
+     user's own variables map !!}  It is mandatory to use the
+     variables map defined in module \texttt{Quote}.
+     
+   \end{itemize}
+
+   The method to proceed is then clear:
+
+   \begin{itemize}
+   \item Start with an empty hashtable of "registed leafs"
+      that map constr to integers and a "variable counter" equal to 0.
+    \item Try to match the term with every right hand side of the 
+      definition of f.
+
+      If there is one match, returns the correponding left hand
+      side and call yourself recursively to get the arguments of this
+      left hand side.
+
+      If there is no match, we are at a leaf. That is the
+      interpretation of either a variable or a constant.
+
+      If it is a constant, return \texttt{Cconst} applied to that
+      constant. 
+
+      If not, it is a variable. Look in the hashtable 
+      if this leaf has been already encountered. If not, increment
+      the variables counter and add an entry to the hashtable; then
+      return \texttt{(Cvar !variables\_counter)}
+   \end{itemize}
+*)
+
+
+(*i*) 
+open Pp
+open Util
+open Names
+open Term
+open Instantiate
+open Pattern
+open Matching
+open Tacmach
+open Tactics
+open Proof_trees
+open Tacexpr
+(*i*)
+
+(*s First, we need to access some Coq constants
+  We do that lazily, because this code can be linked before
+  the constants are loaded in the environment *)
+
+let constant dir s = Coqlib.gen_constant "Quote" ("ring"::dir) s
+
+let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm")
+let coq_Node_vm = lazy (constant ["Quote"] "Node_vm")
+let coq_varmap_find = lazy (constant ["Quote"] "varmap_find")
+let coq_Right_idx = lazy (constant ["Quote"] "Right_idx")
+let coq_Left_idx = lazy (constant ["Quote"] "Left_idx")
+let coq_End_idx = lazy (constant ["Quote"] "End_idx")
+
+(*s Then comes the stuff to decompose the body of interpetation function
+  and pre-compute the inversion data.
+
+For a function like:
+
+\begin{verbatim}
+  Fixpoint interp[vm:(varmap Prop); f:form] :=
+     Cases f of
+     | (f_and f1  f1 f2) => (interp f1)/\(interp f2)
+     | (f_or f1  f1 f2) => (interp f1)\/(interp f2)
+     | (f_var i) => (varmap_find Prop default_v i vm)
+     | (f_const c) => c
+\end{verbatim}
+
+With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the
+corresponding scheme will be: 
+
+\begin{verbatim}
+  {normal_lhs_rhs = 
+     [ "(f_and ?1 ?2)", "?1 /\ ?2";
+       "(f_or ?1 ?2)", " ?1 \/ ?2";];
+   return_type = "Prop";
+   constants = Some [C1,...Cn];
+   variable_lhs = Some "(f_var ?1)";
+   constant_lhs = Some "(f_const ?1)"
+  }
+\end{verbatim}
+
+If there is no constructor for variables in the type \texttt{form}, 
+then [variable_lhs] is [None]. Idem for constants and
+[constant_lhs]. Both cannot be equal to [None].
+
+The metas in the RHS must correspond to those in the LHS (one cannot 
+exchange ?1 and ?2 in the example above) 
+
+*)
+
+module ConstrSet = Set.Make(
+  struct 
+    type t = constr
+    let compare = (Pervasives.compare : t->t->int)
+  end)
+
+type inversion_scheme = {
+  normal_lhs_rhs : (constr * constr_pattern) list;
+  variable_lhs : constr option;
+  return_type : constr;
+  constants : ConstrSet.t;
+  constant_lhs : constr option }
+
+(*s [compute_ivs gl f cs] computes the inversion scheme associated to
+  [f:constr] with constants list [cs:constr list] in the context of 
+  goal [gl]. This function uses the auxiliary functions
+  [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *)
+
+let i_can't_do_that () = error "Quote: not a simple fixpoint"
+
+let decomp_term c = kind_of_term (strip_outer_cast c)
+
+(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ...
+  ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
+  type [typ] *)
+
+let coerce_meta_out id = int_of_string (string_of_id id)
+let coerce_meta_in n = id_of_string (string_of_int n)
+
+let compute_lhs typ i nargsi =
+  match kind_of_term typ with
+    | Ind(sp,0) -> 
+        let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
+        mkApp (mkConstruct ((sp,0),i+1), argsi)
+    | _ -> i_can't_do_that ()
+
+(*s This function builds the pattern from the RHS. Recursive calls are
+  replaced by meta-variables ?i corresponding to those in the LHS *)
+
+let compute_rhs bodyi index_of_f =
+  let rec aux c = 
+    match kind_of_term c with
+      | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> 
+          let i = destRel (array_last args) in 
+	  PMeta (Some (coerce_meta_in i))
+      | App (f,args) ->
+          PApp (pattern_of_constr f, Array.map aux args)
+      | Cast (c,t) -> aux c 
+      | _ -> pattern_of_constr c
+  in
+  aux bodyi
+
+(*s Now the function [compute_ivs] itself *)
+
+let compute_ivs gl f cs =
+  let cst = try destConst f with _ -> i_can't_do_that () in
+  let body = Environ.constant_value (Global.env()) cst in
+  match decomp_term body with
+    | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
+        let (args3, body3) = decompose_lam body2 in
+        let nargs3 = List.length args3 in
+        begin match decomp_term body3 with
+          | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
+              let n_lhs_rhs = ref []
+              and v_lhs = ref (None : constr option)
+              and c_lhs = ref (None : constr option) in
+              Array.iteri
+                (fun i ci -> 
+                   let argsi, bodyi = decompose_lam ci in
+                   let nargsi = List.length argsi in
+           (* REL (narg3 + nargsi + 1) is f *)
+           (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
+           (* REL 1 to REL nargsi are argsi (reverse order) *)
+           (* First we test if the RHS is the RHS for constants *)
+                   if bodyi = mkRel 1 then 
+                     c_lhs := Some (compute_lhs (snd (List.hd args3))
+                                      i nargsi)
+           (* Then we test if the RHS is the RHS for variables *)
+                   else begin match decompose_app bodyi with 
+                     | vmf, [_; _; a3; a4 ]
+                         when isRel a3 & isRel a4 &
+			   pf_conv_x gl vmf 
+                           (Lazy.force coq_varmap_find)->
+                             v_lhs := Some (compute_lhs 
+                                              (snd (List.hd args3))
+                                              i nargsi)
+           (* Third case: this is a normal LHS-RHS *)
+                     | _ -> 
+                         n_lhs_rhs :=
+                         (compute_lhs (snd (List.hd args3)) i nargsi,
+                          compute_rhs bodyi (nargs3 + nargsi + 1))
+                         :: !n_lhs_rhs
+                   end) 
+                lci;
+	      
+              if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
+
+	      (* The Cases predicate is a lambda; we assume no dependency *)
+	      let p = match kind_of_term p with
+		| Lambda (_,_,p) -> Termops.pop p
+		| _ -> p
+	      in
+              
+              { normal_lhs_rhs = List.rev !n_lhs_rhs;
+                variable_lhs = !v_lhs;
+                return_type = p;
+                constants = List.fold_right ConstrSet.add cs ConstrSet.empty;
+                constant_lhs = !c_lhs }
+                     
+              | _ -> i_can't_do_that ()
+        end
+    |_ -> i_can't_do_that ()
+
+(* TODO for that function:
+\begin{itemize}
+\item handle the case where the return type is an argument of the
+  function
+\item handle the case of simple mutual inductive (for example terms
+  and lists of terms) formulas with the corresponding mutual
+  recursvive interpretation functions. 
+\end{itemize}
+*) 
+
+(*s Stuff to build variables map, currently implemented as complete
+binary search trees (see file \texttt{Quote.v}) *)
+
+(* First the function to distinghish between constants (closed terms) 
+   and variables (open terms) *)
+
+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
+     | _ -> false)
+    
+(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
+   binary search tree containing the [ci], that is:
+
+\begin{verbatim}
+                  c1
+                 /  \
+               c2    c3
+              /  \
+             c4  c5
+\end{verbatim}
+
+The second argument is a constr (the common type of the [ci])
+*)
+    
+let btree_of_array a ty =
+  let size_of_a = Array.length a in
+  let semi_size_of_a = size_of_a lsr 1 in
+  let node = Lazy.force coq_Node_vm  
+  and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in
+  let rec aux n =
+    if n > size_of_a 
+    then empty
+    else if  n > semi_size_of_a 
+    then mkApp (node, [| ty; a.(n-1); empty; empty |])
+    else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |])
+  in 
+  aux 1
+
+(*s [btree_of_array] and [path_of_int] verify the following invariant:\\
+   {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] 
+  = [a.(n)]\\
+  [n] must be [> 0] *)
+
+let path_of_int n = 
+  (* returns the list of digits of n in reverse order with
+     initial 1 removed *)
+  let rec digits_of_int n =
+    if n=1 then [] 
+    else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+  in
+  List.fold_right 
+    (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx 
+                         else Lazy.force coq_Left_idx),
+                         [| c |]))
+    (List.rev (digits_of_int n))
+    (Lazy.force coq_End_idx)
+
+(*s The tactic works with a list of subterms sharing the same
+  variables map. We need to sort terms in order to avoid than
+  strange things happen during replacement of terms by their
+  'abstract' counterparties. *)
+
+(* [subterm t t'] tests if constr [t'] occurs in [t] *)
+(* This function does not descend under binders (lambda and Cases) *)
+
+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')
+     | _ -> false)
+           
+(*s We want to sort the list according to reverse subterm order. *)
+(* Since it's a partial order the algoritm of Sort.list won't work !! *)
+
+let rec sort_subterm gl l = 
+  let rec insert c = function
+    | [] -> [c]
+    | (h::t as l) when c = h -> l (* Avoid doing the same work twice *)
+    | h::t -> if subterm gl c h then c::h::t else h::(insert c t)  
+  in 
+  match l with 
+    | [] -> []
+    | h::t -> insert h (sort_subterm gl t)
+
+(*s Now we are able to do the inversion itself.
+  We destructurate the term and use an imperative hashtable
+  to store leafs that are already encountered. 
+  The type of arguments is:\\
+  [ivs : inversion_scheme]\\
+  [lc: constr list]\\
+  [gl: goal sigma]\\ *)
+
+let quote_terms ivs lc gl =
+  Library.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 *)
+  let rec aux c = 
+    let rec auxl l = 
+      match l with
+        | (lhs, rhs)::tail ->
+            begin try 
+              let s1 = matches rhs c in
+              let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
+	      in
+              Termops.subst_meta s2 lhs
+            with PatternMatchingFailure -> auxl tail
+            end 
+        |  [] -> 
+             begin match ivs.variable_lhs with 
+               | None -> 
+                   begin match ivs.constant_lhs with
+                     | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
+                     | None -> anomaly "invalid inversion scheme for quote"
+                   end
+               | Some var_lhs -> 
+                   begin match ivs.constant_lhs with
+                     | Some c_lhs when closed_under ivs.constants c ->
+			 Termops.subst_meta [1, c] c_lhs
+                     | _ -> 
+			 begin 
+                           try Hashtbl.find varhash c 
+                           with Not_found -> 
+                             let newvar = 
+                               Termops.subst_meta [1, (path_of_int !counter)] 
+				 var_lhs in
+                             begin 
+                               incr counter;
+                               varlist := c :: !varlist;
+                               Hashtbl.add varhash c newvar;
+                               newvar
+                             end
+			 end
+                   end 
+             end
+    in 
+    auxl ivs.normal_lhs_rhs 
+  in
+  let lp = List.map aux lc in 
+  (lp, (btree_of_array (Array.of_list (List.rev !varlist)) 
+          ivs.return_type ))
+
+(*s actually we could "quote" a list of terms instead of the 
+  conclusion of current goal. Ring for example needs that, but Ring doesn't
+  uses Quote yet. *)
+ 
+let quote f lid gl =
+  let f = pf_global gl f in
+  let cl = List.map (pf_global gl) lid in
+  let ivs = compute_ivs gl f cl in
+  let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with
+    | [p], vm -> (p,vm)
+    | _ -> 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
+
+(*i 
+
+Just testing ...
+
+#use "include.ml";;
+open Quote;;
+
+let r = raw_constr_of_string;;
+
+let ivs = {
+  normal_lhs_rhs = 
+   [ r "(f_and ?1 ?2)", r "?1/\?2";
+     r "(f_not ?1)", r "~?1"];
+  variable_lhs = Some (r "(f_atom ?1)");
+  return_type = r "Prop";
+  constants = ConstrSet.empty;
+  constant_lhs = (r "nat") 
+};;
+
+let t1 = r "True/\(True /\ ~False)";;
+let t2 = r "True/\~~False";;
+
+quote_term ivs () t1;;
+quote_term ivs () t2;;
+
+let ivs2 =
+  normal_lhs_rhs = 
+   [ r "(f_and ?1 ?2)", r "?1/\?2";
+     r "(f_not ?1)", r "~?1"
+     r "True", r "f_true"];
+  variable_lhs = Some (r "(f_atom ?1)");
+  return_type = r "Prop";
+  constants = ConstrSet.empty;
+  constant_lhs = (r "nat")
+
+i*)
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
new file mode 100644
index 00000000..378f19a4
--- /dev/null
+++ b/contrib/ring/ring.ml
@@ -0,0 +1,904 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.ml,v 1.49.2.1 2004/07/16 19:30:14 herbelin Exp $ *)
+
+(* ML part of the Ring tactic *)
+
+open Pp
+open Util
+open Options
+open Term
+open Names
+open Libnames
+open Nameops
+open Reductionops
+open Tacticals
+open Tacexpr
+open Tacmach
+open Proof_trees
+open Printer
+open Equality
+open Vernacinterp
+open Vernacexpr
+open Libobject
+open Closure
+open Tacred
+open Tactics
+open Pattern 
+open Hiddentac
+open Nametab
+open Quote
+
+let mt_evd = Evd.empty
+let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
+
+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@["Setoid_ring_theory"];
+   ring_dir@["Ring_normalize"];
+   ring_dir@["Ring_abstract"];
+   setoids_dir@["Setoid"];
+   ring_dir@["Setoid_ring_normalize"]]
+
+(* Ring theory *)
+let coq_Ring_Theory = lazy (ring_constant "Ring_Theory")
+let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory")
+
+(* Setoid ring theory *)
+let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory")
+let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory")
+
+(* Ring normalize *)
+let coq_SPplus = lazy (ring_constant "SPplus")
+let coq_SPmult = lazy (ring_constant "SPmult")
+let coq_SPvar = lazy (ring_constant "SPvar")
+let coq_SPconst = lazy (ring_constant "SPconst")
+let coq_Pplus = lazy (ring_constant "Pplus")
+let coq_Pmult = lazy (ring_constant "Pmult")
+let coq_Pvar = lazy (ring_constant "Pvar")
+let coq_Pconst = lazy (ring_constant "Pconst")
+let coq_Popp = lazy (ring_constant "Popp")
+let coq_interp_sp = lazy (ring_constant "interp_sp")
+let coq_interp_p = lazy (ring_constant "interp_p")
+let coq_interp_cs = lazy (ring_constant "interp_cs")
+let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify")
+let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify")
+let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok")
+let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok")
+
+(* Setoid theory *)
+let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory")
+
+let coq_seq_refl = lazy(ring_constant "Seq_refl")
+let coq_seq_sym = lazy(ring_constant "Seq_sym")
+let coq_seq_trans = lazy(ring_constant "Seq_trans")
+
+(* Setoid Ring normalize *)
+let coq_SetSPplus = lazy (ring_constant "SetSPplus")
+let coq_SetSPmult = lazy (ring_constant "SetSPmult")
+let coq_SetSPvar = lazy (ring_constant "SetSPvar")
+let coq_SetSPconst = lazy (ring_constant "SetSPconst")
+let coq_SetPplus = lazy (ring_constant "SetPplus")
+let coq_SetPmult = lazy (ring_constant "SetPmult")
+let coq_SetPvar = lazy (ring_constant "SetPvar")
+let coq_SetPconst = lazy (ring_constant "SetPconst")
+let coq_SetPopp = lazy (ring_constant "SetPopp")
+let coq_interp_setsp = lazy (ring_constant "interp_setsp")
+let coq_interp_setp = lazy (ring_constant "interp_setp")
+let coq_interp_setcs = lazy (ring_constant "interp_setcs")
+let coq_setspolynomial_simplify = 
+  lazy (ring_constant "setspolynomial_simplify")
+let coq_setpolynomial_simplify = 
+  lazy (ring_constant "setpolynomial_simplify")
+let coq_setspolynomial_simplify_ok = 
+  lazy (ring_constant "setspolynomial_simplify_ok")
+let coq_setpolynomial_simplify_ok = 
+  lazy (ring_constant "setpolynomial_simplify_ok")
+
+(* Ring abstract *)
+let coq_ASPplus = lazy (ring_constant "ASPplus")
+let coq_ASPmult = lazy (ring_constant "ASPmult")
+let coq_ASPvar = lazy (ring_constant "ASPvar")
+let coq_ASP0 = lazy (ring_constant "ASP0")
+let coq_ASP1 = lazy (ring_constant "ASP1")
+let coq_APplus = lazy (ring_constant "APplus")
+let coq_APmult = lazy (ring_constant "APmult")
+let coq_APvar = lazy (ring_constant "APvar")
+let coq_AP0 = lazy (ring_constant "AP0")
+let coq_AP1 = lazy (ring_constant "AP1")
+let coq_APopp = lazy (ring_constant "APopp")
+let coq_interp_asp = lazy (ring_constant "interp_asp")
+let coq_interp_ap = lazy (ring_constant "interp_ap")
+let coq_interp_acs = lazy (ring_constant "interp_acs")
+let coq_interp_sacs = lazy (ring_constant "interp_sacs")
+let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
+let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
+let coq_aspolynomial_normalize_ok = 
+  lazy (ring_constant "aspolynomial_normalize_ok")
+let coq_apolynomial_normalize_ok = 
+  lazy (ring_constant "apolynomial_normalize_ok")
+
+(* Logic --> to be found in Coqlib *)
+open Coqlib
+
+let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
+
+(*********** Useful types and functions ************)
+
+module OperSet = 
+  Set.Make (struct 
+	      type t = global_reference
+	      let compare = (Pervasives.compare : t->t->int)
+	    end)
+
+type morph =
+    { plusm : constr;
+      multm : constr;
+      oppm : constr option;
+    }
+
+type theory =
+    { th_ring : bool;                  (* false for a semi-ring *)
+      th_abstract : bool;
+      th_setoid : bool;                (* true for a setoid ring *)
+      th_equiv : constr option;
+      th_setoid_th : constr option;
+      th_morph : morph option;
+      th_a : constr;                   (* e.g. nat *)
+      th_plus : constr;
+      th_mult : constr;
+      th_one : constr;
+      th_zero : constr;
+      th_opp : constr option;          (* None if semi-ring *)
+      th_eq : constr;
+      th_t : constr;                   (* e.g. NatTheory *)
+      th_closed : ConstrSet.t;         (* e.g. [S; O] *)
+                                       (* Must be empty for an abstract ring *)
+    }
+
+(* Theories are stored in a table which is synchronised with the Reset 
+   mechanism. *)
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let theories_map = ref Cmap.empty
+
+let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
+let theories_map_find c = Cmap.find c !theories_map
+let theories_map_mem c = Cmap.mem c !theories_map
+
+let _ = 
+  Summary.declare_summary "tactic-ring-table"
+    { Summary.freeze_function = (fun () -> !theories_map);
+      Summary.unfreeze_function = (fun t -> theories_map := t);
+      Summary.init_function = (fun () -> theories_map := Cmap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* declare a new type of object in the environment, "tactic-ring-theory"
+   The functions theory_to_obj and obj_to_theory do the conversions
+   between theories and environement objects. *)
+
+
+let subst_morph subst morph = 
+  let plusm' = subst_mps subst morph.plusm in
+  let multm' = subst_mps subst morph.multm in
+  let oppm' = option_smartmap (subst_mps subst) morph.oppm in
+    if plusm' == morph.plusm 
+      && multm' == morph.multm 
+      && oppm' == morph.oppm then 
+	morph
+    else
+      { plusm = plusm' ;
+	multm = multm' ;
+	oppm = oppm' ;
+      }
+  
+let subst_set subst cset = 
+  let same = ref true in
+  let copy_subst c newset = 
+    let c' = subst_mps subst c in
+      if not (c' == c) then same := false;
+      ConstrSet.add c' newset
+  in
+  let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
+    if !same then cset else cset'
+
+let subst_theory subst th = 
+  let th_equiv' = option_smartmap (subst_mps subst) th.th_equiv in
+  let th_setoid_th' = option_smartmap (subst_mps subst) th.th_setoid_th in
+  let th_morph' = option_smartmap (subst_morph subst) th.th_morph in
+  let th_a' = subst_mps subst th.th_a in                   
+  let th_plus' = subst_mps subst th.th_plus in
+  let th_mult' = subst_mps subst th.th_mult in
+  let th_one' = subst_mps subst th.th_one in
+  let th_zero' = subst_mps subst th.th_zero in
+  let th_opp' = option_smartmap (subst_mps subst) th.th_opp in
+  let th_eq' = subst_mps subst th.th_eq in
+  let th_t' = subst_mps subst th.th_t in          
+  let th_closed' = subst_set subst th.th_closed in
+    if th_equiv' == th.th_equiv 
+      && th_setoid_th' == th.th_setoid_th 
+      && th_morph' == th.th_morph
+      && th_a' == th.th_a
+      && th_plus' == th.th_plus
+      && th_mult' == th.th_mult
+      && th_one' == th.th_one
+      && th_zero' == th.th_zero
+      && th_opp' == th.th_opp
+      && th_eq' == th.th_eq
+      && th_t' == th.th_t
+      && th_closed' == th.th_closed 
+    then 
+      th 
+    else
+    { th_ring = th.th_ring ;  
+      th_abstract = th.th_abstract ;
+      th_setoid = th.th_setoid ;  
+      th_equiv = th_equiv' ;
+      th_setoid_th = th_setoid_th' ;
+      th_morph = th_morph' ;
+      th_a = th_a' ;            
+      th_plus = th_plus' ;
+      th_mult = th_mult' ;
+      th_one = th_one' ;
+      th_zero = th_zero' ;
+      th_opp = th_opp' ;        
+      th_eq = th_eq' ;
+      th_t = th_t' ;            
+      th_closed = th_closed' ;  
+    }
+
+
+let subst_th (_,subst,(c,th as obj)) = 
+  let c' = subst_mps subst c in
+  let th' = subst_theory subst th in
+    if c' == c && th' == th then obj else
+      (c',th')
+
+
+let (theory_to_obj, obj_to_theory) = 
+  let cache_th (_,(c, th)) = theories_map_add (c,th)
+  and export_th x = Some x in
+  declare_object {(default_object "tactic-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 }
+
+(* from the set A, guess the associated theory *)
+(* With this simple solution, the theory to use is automatically guessed *)
+(* But only one theory can be declared for a given Set *)
+
+let guess_theory a =
+  try 
+    theories_map_find a
+  with Not_found -> 
+    errorlabstrm "Ring" 
+      (str "No Declared Ring Theory for " ++
+	 prterm a ++ fnl () ++
+	 str "Use Add [Semi] Ring to declare it")
+
+(* Looks up an option *)
+
+let unbox = function 
+  | Some w -> w
+  | None -> anomaly "Ring : Not in case of a setoid ring."
+
+(* Protects the convertibility test against undue exceptions when using it 
+   with untyped terms *)
+
+let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
+
+
+(* Add a Ring or a Semi-Ring to the database after a type verification *)
+
+let implement_theory env t th args =
+  is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
+
+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);
+  let env = Global.env () in
+    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 
+      errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
+    if (not want_ring & want_setoid &
+        not (implement_theory env t coq_Semi_Setoid_Ring_Theory 
+	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) &
+	not (implement_theory env (unbox asetth) coq_Setoid_Theory
+	  [| a; (unbox aequiv) |])) 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
+	  [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then
+      errorlabstrm "addring" (str "Not a valid Ring theory");
+    if (not want_ring & not want_setoid &
+	not (implement_theory env t coq_Semi_Ring_Theory
+	  [| a; aplus; amult; aone; azero; aeq |])) then 
+      errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
+    Lib.add_anonymous_leaf
+      (theory_to_obj 
+	 (a, { th_ring = want_ring;
+	       th_abstract = want_abstract;
+	       th_setoid = want_setoid;
+	       th_equiv = aequiv;
+	       th_setoid_th = asetth;
+	       th_morph = amorph;
+	       th_a = a;
+	       th_plus = aplus;
+	       th_mult = amult;
+	       th_one = aone;
+	       th_zero = azero;
+	       th_opp = aopp;
+	       th_eq = aeq;
+	       th_t = t;
+	       th_closed = cset }))
+
+(******** The tactic itself *********)
+
+(*
+   gl : goal sigma
+   th : semi-ring theory (concrete)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_spolynom gl th lc =
+  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 *)
+  (* aux creates the spolynom p by a recursive destructuration of c 
+     and builds the varmap with side-effects *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
+      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
+      | _ when closed_under th.th_closed c ->
+	  mkLApp(coq_SPconst, [|th.th_a; c |])
+      | _ -> 
+	  try Hashtbl.find varhash c 
+	  with Not_found -> 
+	    let newvar =
+              mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in 
+  let lp = List.map aux lc in
+  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
+  List.map 
+    (fun p -> 
+       (mkLApp (coq_interp_sp,
+               [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
+	mkLApp (coq_interp_cs,
+               [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp (coq_spolynomial_simplify, 
+			    [| th.th_a; th.th_plus; th.th_mult; 
+			       th.th_one; th.th_zero; 
+			       th.th_eq; p|])) |]),
+	mkLApp (coq_spolynomial_simplify_ok,
+	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+		  th.th_eq; v; th.th_t; p |])))
+    lp
+
+(*
+   gl : goal sigma
+   th : ring theory (concrete)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_polynom gl th lc =
+  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 *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
+      (* The special case of Zminus *)
+      | App (binop, [|c1; c2|])
+	  when safe_pf_conv_x gl c
+            (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
+	    mkLApp(coq_Pplus,
+                  [|th.th_a; aux c1;
+	            mkLApp(coq_Popp, [|th.th_a; aux c2|]) |])
+      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+	  mkLApp(coq_Popp, [|th.th_a; aux c1|])
+      | _ when closed_under th.th_closed c ->
+	  mkLApp(coq_Pconst, [|th.th_a; c |])
+      | _ -> 
+	  try Hashtbl.find varhash c 
+	  with Not_found -> 
+	    let newvar =
+              mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in
+  let lp = List.map aux lc in
+  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+  List.map 
+    (fun p -> 
+       (mkLApp(coq_interp_p,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
+                 (unbox th.th_opp); v; p |])),
+	mkLApp(coq_interp_cs,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp(coq_polynomial_simplify,
+			    [| th.th_a; th.th_plus; th.th_mult; 
+			       th.th_one; th.th_zero; 
+			       (unbox th.th_opp); th.th_eq; p |])) |]),
+	mkLApp(coq_polynomial_simplify_ok,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
+    lp
+
+(*
+   gl : goal sigma
+   th : semi-ring theory (abstract)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_aspolynom gl th lc =
+  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 *)
+  (* aux creates the aspolynom p by a recursive destructuration of c 
+     and builds the varmap with side-effects *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
+      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
+      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
+      | _ -> 
+	  try Hashtbl.find varhash c 
+	  with Not_found -> 
+	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in 
+  let lp = List.map aux lc in
+  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
+  List.map 
+    (fun p -> 
+       (mkLApp(coq_interp_asp,
+               [| th.th_a; th.th_plus; th.th_mult; 
+		  th.th_one; th.th_zero; v; p |]),
+	mkLApp(coq_interp_acs,
+               [| th.th_a; th.th_plus; th.th_mult; 
+		  th.th_one; th.th_zero; v;
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
+	mkLApp(coq_spolynomial_simplify_ok,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+		  th.th_eq; v; th.th_t; p |])))
+    lp
+
+(*
+   gl : goal sigma
+   th : ring theory (abstract)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_apolynom gl th lc =
+  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 *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
+      (* The special case of Zminus *)
+      | App (binop, [|c1; c2|]) 
+	  when safe_pf_conv_x gl c
+            (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
+	    mkLApp(coq_APplus,
+                   [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |])
+      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+	  mkLApp(coq_APopp, [| aux c1 |])
+      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
+      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
+      | _ -> 
+	  try Hashtbl.find varhash c 
+	  with Not_found -> 
+	    let newvar =
+              mkLApp(coq_APvar, [| path_of_int !counter |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in
+  let lp = List.map aux lc in
+  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+  List.map 
+    (fun p -> 
+       (mkLApp(coq_interp_ap,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; 
+		  th.th_zero; (unbox th.th_opp); v; p |]),
+	mkLApp(coq_interp_sacs,
+	       [| th.th_a; th.th_plus; th.th_mult; 
+		  th.th_one; th.th_zero; (unbox th.th_opp); v; 
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
+	mkLApp(coq_apolynomial_normalize_ok,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; 
+		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
+    lp
+    
+(*
+   gl : goal sigma
+   th : setoid ring theory (concrete)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_setpolynom gl th lc =
+  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 *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
+      (* The special case of Zminus *)
+      | App (binop, [|c1; c2|])
+	  when safe_pf_conv_x gl c
+	    (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
+	      mkLApp(coq_SetPplus,
+                     [| th.th_a; aux c1;
+			mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |])
+      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+	  mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
+      | _ when closed_under th.th_closed c ->
+	  mkLApp(coq_SetPconst, [| th.th_a; c |])
+      | _ -> 
+	  try Hashtbl.find varhash c 
+	  with Not_found -> 
+	    let newvar =
+              mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in
+  let lp = List.map aux lc in
+  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+  List.map 
+    (fun p -> 
+       (mkLApp(coq_interp_setp,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
+                  (unbox th.th_opp); v; p |]),
+	mkLApp(coq_interp_setcs,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp(coq_setpolynomial_simplify,
+			    [| th.th_a; th.th_plus; th.th_mult; 
+			       th.th_one; th.th_zero; 
+			       (unbox th.th_opp); th.th_eq; p |])) |]),
+	mkLApp(coq_setpolynomial_simplify_ok,
+	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
+                  th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp);
+                  th.th_eq; (unbox th.th_setoid_th);
+		  (unbox th.th_morph).plusm; (unbox th.th_morph).multm;
+		  (unbox (unbox th.th_morph).oppm); v; th.th_t; p |])))
+    lp
+
+(*
+   gl : goal sigma
+   th : semi setoid ring theory (concrete)
+   cl : constr list [c1; c2; ...]
+ 
+Builds 
+   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] 
+  where c'i is convertible with ci and
+  c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_setspolynom gl th lc =
+  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 *)
+  let rec aux c = 
+    match (kind_of_term (strip_outer_cast c)) with 
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+	  mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
+      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+	  mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
+      | _ when closed_under th.th_closed c ->
+	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
+      | _ -> 
+	  try Hashtbl.find varhash c
+	  with Not_found ->
+	    let newvar =
+              mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
+	    begin 
+	      incr counter;
+	      varlist := c :: !varlist;
+	      Hashtbl.add varhash c newvar;
+	      newvar
+	    end
+  in
+  let lp = List.map aux lc in
+  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+  List.map
+    (fun p ->
+       (mkLApp(coq_interp_setsp,
+	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
+	mkLApp(coq_interp_setcs,
+               [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+		  pf_reduce cbv_betadeltaiota gl 
+		    (mkLApp(coq_setspolynomial_simplify,
+			    [| th.th_a; th.th_plus; th.th_mult; 
+			       th.th_one; th.th_zero; 
+			       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);
+		  (unbox th.th_morph).plusm;
+                  (unbox th.th_morph).multm; p |])))
+    lp
+
+module SectionPathSet =
+  Set.Make(struct
+	     type t = section_path
+	     let compare = Pervasives.compare
+	   end)
+
+(* Avec l'uniformisation des red_kind, on perd ici sur la structure
+   SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
+let constants_to_unfold = 
+(*  List.fold_right SectionPathSet.add *)
+  let transform s = 
+    let sp = path_of_string s in
+    let dir, id = repr_path sp in
+      Libnames.encode_kn dir id 
+  in
+  List.map transform
+    [ "Coq.ring.Ring_normalize.interp_cs";
+      "Coq.ring.Ring_normalize.interp_var";
+      "Coq.ring.Ring_normalize.interp_vl";
+      "Coq.ring.Ring_abstract.interp_acs";
+      "Coq.ring.Ring_abstract.interp_sacs";
+      "Coq.ring.Quote.varmap_find";
+      (* anciennement des Local devenus Definition *)
+      "Coq.ring.Ring_normalize.ics_aux";
+      "Coq.ring.Ring_normalize.ivl_aux";
+      "Coq.ring.Ring_normalize.interp_m";
+      "Coq.ring.Ring_abstract.iacs_aux";
+      "Coq.ring.Ring_abstract.isacs_aux";
+      "Coq.ring.Setoid_ring_normalize.interp_cs";
+      "Coq.ring.Setoid_ring_normalize.interp_var";
+      "Coq.ring.Setoid_ring_normalize.interp_vl";
+      "Coq.ring.Setoid_ring_normalize.ics_aux";
+      "Coq.ring.Setoid_ring_normalize.ivl_aux";
+      "Coq.ring.Setoid_ring_normalize.interp_m";
+    ]
+(*    SectionPathSet.empty *)
+
+(* Unfolds the functions interp and find_btree in the term c of goal gl *)
+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)
+      
+let polynom_unfold_tac_in_term gl =
+  let flags = 
+    (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
+  in
+  cbv_norm_flags flags (pf_env gl) (project gl)
+
+(* lc : constr list *)
+(* th : theory associated to t *)
+(* op : clause (None for conclusion or Some id for hypothesis id) *)
+(* gl : goal  *)
+(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) 
+   where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
+   are guessed and such that c_i = (interp R RC v p_i) *)
+let raw_polynom th op lc gl =
+  (* first we sort the terms : if t' is a subterm of t it must appear
+     after t in the list. This is to avoid that the normalization of t'
+     modifies t in a non-desired way *)
+  let lc = sort_subterm gl lc in
+  let ltriplets = 
+    if th.th_setoid then
+      if th.th_ring
+      then build_setpolynom gl th lc
+      else build_setspolynom gl th lc
+    else
+      if th.th_ring then
+	if th.th_abstract
+	then build_apolynom gl th lc
+	else build_polynom gl th lc
+      else
+	if th.th_abstract 
+	then build_aspolynom gl th lc
+	else build_spolynom gl th lc in 
+  let polynom_tac = 
+    List.fold_right2
+      (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
+         let c'''i = 
+	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i 
+	 in
+         if !term_quality && safe_pf_conv_x gl c'''i ci then 
+	   tac (* convertible terms *)
+         else if th.th_setoid
+	 then
+           (tclORELSE 
+              (tclORELSE
+		 (h_exact c'i_eq_c''i)
+		 (h_exact (mkLApp(coq_seq_sym, 
+				  [| 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)))
+	 else
+           (tclORELSE
+              (tclORELSE
+		 (h_exact c'i_eq_c''i)
+		 (h_exact (mkApp(build_coq_sym_eqT (),
+				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
+	      (tclTHENS 
+		 (elim_type 
+		    (mkApp(build_coq_eqT (), [|th.th_a; c'''i; ci |])))
+		 [ tac;
+                   h_exact c'i_eq_c''i ]))
+)
+      lc ltriplets polynom_unfold_tac 
+  in
+  polynom_tac gl
+
+let guess_eq_tac th =
+  (tclORELSE reflexivity
+     (tclTHEN
+	polynom_unfold_tac
+        (tclTHEN
+	   (* Normalized sums associate on the right *)
+	   (tclREPEAT
+	      (tclTHENFIRST
+		 (apply (mkApp(build_coq_f_equal2 (),
+		               [| th.th_a; th.th_a; th.th_a;
+				  th.th_plus |])))
+		 reflexivity))
+	   (tclTRY
+	      (tclTHENLAST
+		 (apply (mkApp(build_coq_f_equal2 (),
+			       [| th.th_a; th.th_a; th.th_a;
+				  th.th_plus |])))
+		 reflexivity)))))
+
+let guess_equiv_tac th = 
+  (tclORELSE (apply (mkLApp(coq_seq_refl,
+			    [| th.th_a; (unbox th.th_equiv);
+			       (unbox th.th_setoid_th)|])))
+     (tclTHEN 
+	polynom_unfold_tac
+	(tclREPEAT 
+	   (tclORELSE 
+	      (apply (unbox th.th_morph).plusm)
+	      (apply (unbox th.th_morph).multm)))))
+
+let match_with_equiv c = match (kind_of_term c) with
+  | App (e,a) -> 
+      if (List.mem e (Setoid_replace.equiv_list ()))
+      then Some (decompose_app c)
+      else None
+  | _ -> None
+
+let polynom lc gl =
+  Library.check_required_library ["Coq";"ring";"Ring"];
+  match lc with 
+   (* If no argument is given, try to recognize either an equality or
+      a declared relation with arguments c1 ... cn, 
+      do "Ring c1 c2 ... cn" and then try to apply the simplification
+      theorems declared for the relation *)
+    | [] ->
+	(match Hipattern.match_with_equation (pf_concl gl) with
+	   | Some (eq,t::args) ->
+	       let th = guess_theory t in
+	       if List.exists 
+		 (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) args
+	       then 
+		 errorlabstrm "Ring :"
+		   (str" All terms must have the same type");
+	       (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl
+	   | _ -> (match match_with_equiv (pf_concl gl) with
+		     | Some (equiv, c1::args) ->
+			 let t = (pf_type_of gl c1) in
+			 let th = (guess_theory t) in
+			   if List.exists 
+			     (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
+			   then 
+			     errorlabstrm "Ring :"
+			       (str" All terms must have the same type");
+			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl		   
+		     | _ -> errorlabstrm "polynom :" 
+			 (str" This goal is not an equality nor a setoid equivalence")))
+    (* Elsewhere, guess the theory, check that all terms have the same type
+       and apply raw_polynom *)
+    | c :: lc' -> 
+	let t = pf_type_of gl c in 
+	let th = guess_theory t in 
+	  if List.exists 
+	    (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
+	  then 
+	    errorlabstrm "Ring :"
+	      (str" All terms must have the same type");
+	  (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/contrib/romega/README b/contrib/romega/README
new file mode 100644
index 00000000..86c9e58a
--- /dev/null
+++ b/contrib/romega/README
@@ -0,0 +1,6 @@
+This work was done for the RNRT Project Calife. 
+As such it is distributed under the LGPL licence.
+
+Report bugs to :
+  pierre.cregut@francetelecom.com
+
diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v
new file mode 100644
index 00000000..b3895b2a
--- /dev/null
+++ b/contrib/romega/ROmega.v
@@ -0,0 +1,11 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Import Omega.
+Require Import ReflOmegaCore.
+
diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v
new file mode 100644
index 00000000..3dfb5593
--- /dev/null
+++ b/contrib/romega/ReflOmegaCore.v
@@ -0,0 +1,2787 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence du projet : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Import Arith.
+Require Import List.
+Require Import Bool.
+Require Import 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) (default : Prop) {struct l} :
+ Prop :=
+  match n, l with
+  | 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 *)
+Notation hyps := (list proposition) (only parsing).      
+
+(* Definition of lists of subgoals  (set of open goals) *)
+Notation lhyps := (list (list proposition)) (only parsing).
+
+(* a syngle goal packed in a subgoal list *)
+Notation singleton := (fun a : list proposition => a :: nil) (only parsing).
+
+(* an absurd goal *)
+Definition absurd := FalseTerm :: nil.
+
+(* \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 *)
+
+Ltac absurd_case := simpl in |- *; intros; discriminate.
+Ltac trivial_case := unfold not in |- *; intros; discriminate.
+
+(* \subsubsection{Entiers naturels} *)
+
+Fixpoint eq_nat (t1 t2 : nat) {struct t2} : bool :=
+  match t1 with
+  | O => match t2 with
+         | O => true
+         | _ => false
+         end
+  | S n1 => match t2 with
+            | O => false
+            | S n2 => eq_nat n1 n2
+            end
+  end.
+
+Theorem eq_nat_true : forall t1 t2 : nat, eq_nat t1 t2 = true -> t1 = t2.
+
+simple induction t1;
+ [ intro t2; case t2; [ trivial | absurd_case ]
+ | intros n H t2; case t2;
+    [ absurd_case
+    | simpl in |- *; intros; rewrite (H n0); [ trivial | assumption ] ] ].
+
+Qed.
+  
+Theorem eq_nat_false : forall t1 t2 : nat, eq_nat t1 t2 = false -> t1 <> t2.
+
+simple induction t1;
+ [ intro t2; case t2; [ simpl in |- *; intros; discriminate | trivial_case ]
+ | intros n H t2; case t2; simpl in |- *; unfold not in |- *; intros;
+    [ discriminate | elim (H n0 H0); simplify_eq H1; trivial ] ].
+
+Qed.
+                                   
+
+(* \subsubsection{Entiers positifs} *)
+
+Fixpoint eq_pos (p1 p2 : positive) {struct p2} : bool :=
+  match p1 with
+  | xI n1 => match p2 with
+             | xI n2 => eq_pos n1 n2
+             | _ => false
+             end
+  | xO n1 => match p2 with
+             | xO n2 => eq_pos n1 n2
+             | _ => false
+             end
+  | xH => match p2 with
+          | xH => true
+          | _ => false
+          end
+  end.
+
+Theorem eq_pos_true : forall t1 t2 : positive, eq_pos t1 t2 = true -> t1 = t2.
+
+simple induction t1;
+ [ intros p H t2; case t2;
+    [ simpl in |- *; intros; rewrite (H p0 H0); trivial
+    | absurd_case
+    | absurd_case ]
+ | intros p H t2; case t2;
+    [ absurd_case
+    | simpl in |- *; intros; rewrite (H p0 H0); trivial
+    | absurd_case ]
+ | intro t2; case t2; [ absurd_case | absurd_case | auto ] ].
+
+Qed.
+  
+Theorem eq_pos_false :
+ forall t1 t2 : positive, eq_pos t1 t2 = false -> t1 <> t2.
+
+simple induction t1;
+ [ intros p H t2; case t2;
+    [ simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
+       simplify_eq H1; auto
+    | trivial_case
+    | trivial_case ]
+ | intros p H t2; case t2;
+    [ trivial_case
+    | simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
+       simplify_eq H1; auto
+    | trivial_case ]
+ | intros t2; case t2; [ trivial_case | trivial_case | absurd_case ] ].
+Qed.
+
+(* \subsubsection{Entiers relatifs} *)
+
+Definition eq_Z (z1 z2 : Z) : bool :=
+  match z1 with
+  | Z0 => match z2 with
+          | Z0 => true
+          | _ => false
+          end
+  | Zpos p1 => match z2 with
+               | Zpos p2 => eq_pos p1 p2
+               | _ => false
+               end
+  | Zneg p1 => match z2 with
+               | Zneg p2 => eq_pos p1 p2
+               | _ => false
+               end
+  end.
+
+Theorem eq_Z_true : forall t1 t2 : Z, eq_Z t1 t2 = true -> t1 = t2.
+
+simple induction t1;
+ [ intros t2; case t2; [ auto | absurd_case | absurd_case ]
+ | intros p t2; case t2;
+    [ absurd_case
+    | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial
+    | absurd_case ]
+ | intros p t2; case t2;
+    [ absurd_case
+    | absurd_case
+    | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial ] ].
+
+Qed.
+
+Theorem eq_Z_false : forall t1 t2 : Z, eq_Z t1 t2 = false -> t1 <> t2.
+
+simple induction t1;
+ [ intros t2; case t2; [ absurd_case | trivial_case | trivial_case ]
+ | intros p t2; case t2;
+    [ absurd_case
+    | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
+       simplify_eq H0; auto
+    | trivial_case ]
+ | intros p t2; case t2;
+    [ absurd_case
+    | trivial_case
+    | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
+       simplify_eq H0; auto ] ].
+Qed.
+
+(* \subsubsection{Termes réifiés} *)
+
+Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
+  match t1 with
+  | Tint st1 => match t2 with
+                | Tint st2 => eq_Z st1 st2
+                | _ => false
+                end
+  | Tplus st11 st12 =>
+      match t2 with
+      | Tplus st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | _ => false
+      end
+  | Tmult st11 st12 =>
+      match t2 with
+      | Tmult st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | _ => false
+      end
+  | Tminus st11 st12 =>
+      match t2 with
+      | Tminus st21 st22 => eq_term st11 st21 && eq_term st12 st22
+      | _ => 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.
+
+
+simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *;
+ [ 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 ].
+
+Qed.
+
+Theorem eq_term_false :
+ forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2.
+
+simple induction t1;
+ [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
+    intros; elim eq_Z_false with (1 := H); simplify_eq H0; 
+    auto
+ | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
+    intros t21 t22 H3; unfold not in |- *; 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 in |- *;
+    intros t21 t22 H3; unfold not in |- *; 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 in |- *;
+    intros t21 t22 H3; unfold not in |- *; 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 in |- *; intros t21 H3;
+    unfold not in |- *; intro H4; elim H1 with (1 := H3); 
+    simplify_eq H4; auto
+ | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
+    intros; elim eq_nat_false with (1 := H); simplify_eq H0; 
+    auto ].
+
+Qed.
+
+(* \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 :
+ forall (P : bool -> Prop) (b : bool),
+ (b = true -> P true) -> (b = false -> P false) -> P b.
+
+simple induction b; auto.
+Qed.
+
+(* 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. *)
+
+Ltac elim_eq_term t1 t2 :=
+  pattern (eq_term t1 t2) in |- *; apply bool_ind2; intro Aux;
+   [ generalize (eq_term_true t1 t2 Aux); clear Aux
+   | generalize (eq_term_false t1 t2 Aux); clear Aux ].
+
+Ltac elim_eq_Z t1 t2 :=
+  pattern (eq_Z t1 t2) in |- *; apply bool_ind2; intro Aux;
+   [ generalize (eq_Z_true t1 t2 Aux); clear Aux
+   | generalize (eq_Z_false t1 t2 Aux); clear Aux ].
+
+Ltac elim_eq_pos t1 t2 :=
+  pattern (eq_pos t1 t2) in |- *; 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 :
+ 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.
+
+simple induction b; auto.
+Qed.
+
+Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2.
+
+(* \subsection{Interprétations}
+   \subsubsection{Interprétation des termes dans Z} *)
+
+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
+  end.
+
+(* \subsubsection{Interprétation des prédicats} *) 
+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
+  | 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
+  | 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 : list proposition) {struct l} : Prop :=
+  match l with
+  | nil => True
+  | 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 : list proposition) {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'
+  end.
+
+Notation interp_goal :=
+  (fun (envp : PropList) (env : list Z) (l : list proposition) =>
+   interp_goal_concl envp env FalseTerm l) (only parsing).
+
+(* 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.
+
+simple induction l;
+ [ simpl in |- *; auto
+ | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ].
+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.
+
+simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
+Qed.
+      
+(* \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) :=
+  forall (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) :=
+  forall (ep : PropList) (e : list Z) (p1 : proposition),
+  interp_proposition ep e p1 -> interp_proposition ep e (f p1).
+
+Definition valid2 (f : proposition -> proposition -> proposition) :=
+  forall (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 : list proposition -> list proposition) :=
+  forall (ep : PropList) (e : list Z) (lp : list proposition),
+  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.
+
+intros; simpl in |- *; apply goal_to_hyps; intro H1;
+ apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
+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 :=
+  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 :=
+  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'
+  end.
+
+Theorem list_goal_to_hyps :
+ forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
+
+simple induction l; simpl in |- *;
+ [ auto
+ | intros h1 l1 H H1; split;
+    [ apply goal_to_hyps; intro H2; apply H1; auto
+    | apply H; intro H2; apply H1; auto ] ].
+Qed.
+
+Theorem list_hyps_to_goal :
+ forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
+
+simple induction l; simpl in |- *;
+ [ auto
+ | intros h1 l1 H (H1, H2) H3; elim H3; intro H4;
+    [ 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),
+  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.
+
+Theorem goal_valid :
+ forall f : list proposition -> list (list proposition),
+ 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); 
+ apply (H ep e lp); assumption.
+Qed.
+ 
+Theorem append_valid :
+ forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)),
+ interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
+ interp_list_hyps ep e (l1 ++ l2).
+
+intros ep e; simple induction l1;
+ [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ]
+ | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H];
+    [ auto
+    | right; apply (HR l2); left; trivial
+    | right; apply (HR l2); right; trivial ] ].
+
+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.
+
+Theorem nth_valid :
+ forall (ep : PropList) (e : list Z) (i : nat) (l : list proposition),
+ interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
+
+unfold nth_hyps in |- *; simple induction i;
+ [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ]
+ | intros n H; simple induction l;
+    [ simpl in |- *; trivial
+    | intros; simpl in |- *; apply H; elim H1; auto ] ].
+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 (nth_hyps i l) (nth_hyps j l) :: l.
+
+Theorem apply_oper_2_valid :
+ forall (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 in |- *; simpl in |- *;
+ intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ].
+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 :=
+  match l with
+  | nil => nil (A:=proposition)
+  | p :: l' =>
+      match i with
+      | O => f p :: l'
+      | S j => p :: apply_oper_1 j f l'
+      end
+  end.
+
+Theorem apply_oper_1_valid :
+ forall (i : nat) (f : proposition -> proposition),
+ valid1 f -> valid_hyps (apply_oper_1 i f).
+
+unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
+ [ intro lp; case lp;
+    [ simpl in |- *; trivial
+    | simpl in |- *; intros p l' (H1, H2); split;
+       [ apply Hf with (1 := H1) | assumption ] ]
+ | intros n Hrec lp; case lp;
+    [ simpl in |- *; auto
+    | simpl in |- *; intros p l' (H1, H2); split;
+       [ assumption | apply Hrec; assumption ] ] ].
+
+Qed.
+
+(* \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) :=
+  match t with
+  | 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) :=
+  match t with
+  | 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) :=
+  match t with
+  | 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 :
+ forall f : term -> term, term_stable f -> term_stable (apply_left f).
+
+unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ intros; elim H; trivial.
+Qed.
+
+Theorem apply_right_stable :
+ forall f : term -> term, term_stable f -> term_stable (apply_right f).
+
+unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ intros t0 t1; elim H; trivial.
+Qed.
+
+Theorem apply_both_stable :
+ forall f g : term -> term,
+ term_stable f -> term_stable g -> term_stable (apply_both f g).
+
+unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
+ intros t0 t1; elim H1; elim H2; trivial.
+Qed.
+
+Theorem compose_term_stable :
+ forall f g : term -> term,
+ term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)).
+
+unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
+Qed.
+
+(* \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é} *)
+
+Ltac loop t :=
+  match constr:t with
+  | (?X1 = ?X2) => 
+                    (* Global *)
+                    loop X1 || loop X2
+  | (_ -> ?X1) => loop X1
+  | (interp_hyps _ _ ?X1) =>
+      
+  (* Interpretations *)
+  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
+  | (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
+  | match ?X1 with
+    | EqTerm x x0 => _
+    | LeqTerm x x0 => _
+    | TrueTerm => _
+    | FalseTerm => _
+    | Tnot x => _
+    | GeqTerm x x0 => _
+    | GtTerm x x0 => _
+    | LtTerm x x0 => _
+    | NeqTerm x x0 => _
+    | Tor x x0 => _
+    | Tand x x0 => _
+    | Timp x x0 => _
+    | Tprop x => _
+    end =>
+      
+       (* Eliminations *)
+       case X1;
+       [ intro; intro
+       | intro; intro
+       | idtac
+       | idtac
+       | intro
+       | intro; intro
+       | intro; intro
+       | intro; intro
+       | intro; intro
+       | intro; intro
+       | intro; intro
+       | intro; intro
+       | intro ]; auto; Simplify
+  | match ?X1 with
+    | Tint x => _
+    | Tplus x x0 => _
+    | Tmult x x0 => _
+    | Tminus x x0 => _
+    | Topp x => _
+    | Tvar x => _
+    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 => _
+    end =>
+      elim_Zcompare X1 X2; intro; auto; Simplify
+  | match ?X1 with
+    | Z0 => _
+    | Zpos x => _
+    | Zneg x => _
+    end =>
+      case X1; [ idtac | intro | intro ]; auto; Simplify
+  | (if eq_Z ?X1 ?X2 then _ else _) =>
+      elim_eq_Z X1 X2; intro H; [ rewrite H; clear H | clear H ];
+       simpl in |- *; auto; Simplify
+  | (if eq_term ?X1 ?X2 then _ else _) =>
+      elim_eq_term X1 X2; intro H; [ rewrite H; clear H | clear H ];
+       simpl in |- *; auto; Simplify
+  | (if eq_pos ?X1 ?X2 then _ else _) =>
+      elim_eq_pos X1 X2; intro H; [ rewrite H; clear H | clear H ];
+       simpl in |- *; auto; Simplify
+  | _ => fail
+  end
+ with Simplify := match goal with
+                  |  |- ?X1 => try loop X1
+                  | _ => idtac
+                  end.
+
+
+Ltac prove_stable x th :=
+  match constr:x with
+  | ?X1 =>
+      unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *;
+       apply th
+  end.
+
+(* \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
+  | _ => t
+  end.
+
+Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l.
+
+prove_stable Tplus_assoc_l Zplus_assoc.
+Qed.
+
+Definition Tplus_assoc_r (t : term) :=
+  match t with
+  | Tplus (Tplus n m) p => Tplus n (Tplus m p)
+  | _ => t
+  end.
+
+Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r.
+
+prove_stable Tplus_assoc_r Zplus_assoc_reverse.
+Qed.
+
+Definition Tmult_assoc_r (t : term) :=
+  match t with
+  | Tmult (Tmult n m) p => Tmult n (Tmult m p)
+  | _ => t
+  end.
+
+Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r.
+
+prove_stable Tmult_assoc_r Zmult_assoc_reverse.
+Qed.
+
+Definition Tplus_permute (t : term) :=
+  match t with
+  | Tplus n (Tplus m p) => Tplus m (Tplus n p)
+  | _ => t
+  end.
+
+Theorem Tplus_permute_stable : term_stable Tplus_permute.
+
+prove_stable Tplus_permute Zplus_permute.
+Qed.
+
+Definition Tplus_sym (t : term) :=
+  match t with
+  | Tplus x y => Tplus y x
+  | _ => t
+  end.
+
+Theorem Tplus_sym_stable : term_stable Tplus_sym.
+
+prove_stable Tplus_sym Zplus_comm.
+Qed.
+
+Definition Tmult_sym (t : term) :=
+  match t with
+  | Tmult x y => Tmult y x
+  | _ => t
+  end.
+
+Theorem Tmult_sym_stable : term_stable Tmult_sym.
+
+prove_stable Tmult_sym Zmult_comm.
+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)) =>
+      match eq_term v v' with
+      | true =>
+          Tplus (Tmult v (Tint (c1 * k1 + c2 * k2)))
+            (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2)))
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem T_OMEGA10_stable : term_stable T_OMEGA10.
+
+prove_stable T_OMEGA10 OMEGA10.
+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)
+  | _ => t
+  end.
+
+Theorem T_OMEGA11_stable : term_stable T_OMEGA11.
+
+prove_stable T_OMEGA11 OMEGA11.
+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)))
+  | _ => t
+  end.
+
+Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
+
+prove_stable T_OMEGA12 OMEGA12.
+Qed. 
+
+Definition T_OMEGA13 (t : term) :=
+  match t with
+  | Tplus (Tplus (Tmult v (Tint (Zpos x))) l1) (Tplus (Tmult v' (Tint (Zneg
+    x'))) l2) =>
+      match eq_term v v' with
+      | true => match eq_pos x x' with
+                | true => Tplus l1 l2
+                | false => t
+                end
+      | false => t
+      end
+  | Tplus (Tplus (Tmult v (Tint (Zneg x))) l1) (Tplus (Tmult v' (Tint (Zpos
+    x'))) l2) =>
+      match eq_term v v' with
+      | true => match eq_pos x x' with
+                | true => Tplus l1 l2
+                | false => t
+                end
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem T_OMEGA13_stable : term_stable T_OMEGA13.
+
+unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
+ [ apply OMEGA13 | apply OMEGA14 ].
+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)) =>
+      match eq_term v v' with
+      | true =>
+          Tplus (Tmult v (Tint (c1 + c2 * k2)))
+            (Tplus l1 (Tmult l2 (Tint k2)))
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem T_OMEGA15_stable : term_stable T_OMEGA15.
+
+prove_stable T_OMEGA15 OMEGA15.
+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))
+  | _ => t
+  end.
+
+
+Theorem T_OMEGA16_stable : term_stable T_OMEGA16.
+
+prove_stable T_OMEGA16 OMEGA16.
+Qed.
+
+Definition Tred_factor5 (t : term) :=
+  match t with
+  | Tplus (Tmult x (Tint Z0)) y => y
+  | _ => t
+  end.
+
+Theorem Tred_factor5_stable : term_stable Tred_factor5.
+
+
+prove_stable Tred_factor5 Zred_factor5.
+Qed.
+
+Definition Topp_plus (t : term) :=
+  match t with
+  | Topp (Tplus x y) => Tplus (Topp x) (Topp y)
+  | _ => t
+  end.
+
+Theorem Topp_plus_stable : term_stable Topp_plus.
+
+prove_stable Topp_plus Zopp_plus_distr.
+Qed.
+
+
+Definition Topp_opp (t : term) :=
+  match t with
+  | Topp (Topp x) => x
+  | _ => t
+  end.
+
+Theorem Topp_opp_stable : term_stable Topp_opp.
+
+prove_stable Topp_opp Zopp_involutive.
+Qed.
+
+Definition Topp_mult_r (t : term) :=
+  match t with
+  | Topp (Tmult x (Tint k)) => Tmult x (Tint (- k))
+  | _ => t
+  end.
+
+Theorem Topp_mult_r_stable : term_stable Topp_mult_r.
+
+prove_stable Topp_mult_r Zopp_mult_distr_r.
+Qed.
+
+Definition Topp_one (t : term) :=
+  match t with
+  | Topp x => Tmult x (Tint (-1))
+  | _ => t
+  end.
+
+Theorem Topp_one_stable : term_stable Topp_one.
+
+prove_stable Topp_one Zopp_eq_mult_neg_1.
+Qed.
+
+Definition Tmult_plus_distr (t : term) :=
+  match t with
+  | Tmult (Tplus n m) p => Tplus (Tmult n p) (Tmult m p)
+  | _ => t
+  end.
+
+Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr.
+
+prove_stable Tmult_plus_distr Zmult_plus_distr_l.
+Qed.
+
+Definition Tmult_opp_left (t : term) :=
+  match t with
+  | Tmult (Topp x) (Tint y) => Tmult x (Tint (- y))
+  | _ => t
+  end.
+
+Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left.
+
+prove_stable Tmult_opp_left Zmult_opp_comm.
+Qed.
+
+Definition Tmult_assoc_reduced (t : term) :=
+  match t with
+  | Tmult (Tmult n (Tint m)) (Tint p) => Tmult n (Tint (m * p))
+  | _ => t
+  end.
+
+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).
+
+Theorem Tred_factor0_stable : term_stable Tred_factor0.
+
+prove_stable Tred_factor0 Zred_factor0.
+Qed.
+
+Definition Tred_factor1 (t : term) :=
+  match t with
+  | Tplus x y =>
+      match eq_term x y with
+      | true => Tmult x (Tint 2)
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem Tred_factor1_stable : term_stable Tred_factor1.
+
+prove_stable Tred_factor1 Zred_factor1.
+Qed.
+
+Definition Tred_factor2 (t : term) :=
+  match t with
+  | Tplus x (Tmult y (Tint k)) =>
+      match eq_term x y with
+      | true => Tmult x (Tint (1 + k))
+      | false => 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.
+prove_stable Tred_factor2 Zred_factor2.
+Qed.
+
+Definition Tred_factor3 (t : term) :=
+  match t with
+  | Tplus (Tmult x (Tint k)) y =>
+      match eq_term x y with
+      | true => Tmult x (Tint (1 + k))
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem Tred_factor3_stable : term_stable Tred_factor3.
+
+prove_stable Tred_factor3 Zred_factor3.
+Qed.
+
+
+Definition Tred_factor4 (t : term) :=
+  match t with
+  | Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2)) =>
+      match eq_term x y with
+      | true => Tmult x (Tint (k1 + k2))
+      | false => t
+      end
+  | _ => t
+  end.
+
+Theorem Tred_factor4_stable : term_stable Tred_factor4.
+
+prove_stable Tred_factor4 Zred_factor4.
+Qed.
+
+Definition Tred_factor6 (t : term) := Tplus t (Tint 0).
+
+Theorem Tred_factor6_stable : term_stable Tred_factor6.
+
+prove_stable Tred_factor6 Zred_factor6.
+Qed.
+
+Transparent Zplus.
+
+Definition Tminus_def (t : term) :=
+  match t with
+  | 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. *)
+prove_stable Tminus_def False.
+Qed.
+
+(* \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 :=
+  match t with
+  | Tplus x y =>
+      match reduce x with
+      | Tint x' =>
+          match reduce y with
+          | Tint y' => Tint (x' + y')
+          | y' => Tplus (Tint x') y'
+          end
+      | x' => Tplus x' (reduce y)
+      end
+  | Tmult x y =>
+      match reduce x with
+      | Tint x' =>
+          match reduce y with
+          | Tint y' => Tint (x' * y')
+          | y' => Tmult (Tint x') y'
+          end
+      | x' => Tmult x' (reduce y)
+      end
+  | Tminus x y =>
+      match reduce x with
+      | Tint x' =>
+          match reduce y with
+          | Tint y' => Tint (x' - y')
+          | y' => Tminus (Tint x') y'
+          end
+      | x' => Tminus x' (reduce y)
+      end
+  | Topp x =>
+      match reduce x with
+      | Tint x' => Tint (- x')
+      | x' => Topp x'
+      end
+  | _ => t
+  end.
+
+Theorem reduce_stable : term_stable reduce.
+
+unfold term_stable in |- *; intros e t; elim t; auto;
+ try
+  (intros t0 H0 t1 H1; simpl in |- *; 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 in |- *; 
+ rewrite H0; case (reduce t0); intros; auto.
+Qed.
+
+(* \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) (t : term) {struct trace} : term :=
+  match trace with
+  | nil => reduce t
+  | step :: trace' =>
+      match step with
+      | 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 : forall t : list t_fusion, term_stable (fusion t).
+
+simple induction t; simpl in |- *;
+ [ 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 in |- *; 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 ] ] ].
+
+Qed.
+
+(* \paragraph{Fusion de deux équations dont une sans coefficient} *)
+
+Definition fusion_right (trace : list t_fusion) (t : term) : term :=
+  match trace with
+  | nil => reduce t (* Il faut mettre un compute *)
+  | step :: trace' =>
+      match step with
+      | 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) (t : term) {struct trace} : term :=
+  match trace with
+  | O => reduce t
+  | S trace' => fusion_cancel trace' (T_OMEGA13 t)
+  end.
+
+Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
+
+unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
+ [ exact (reduce_stable e)
+ | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
+Qed. 
+
+(* \subsubsection{Opérations afines sur une équation} *)
+(* \paragraph{Multiplication scalaire et somme d'une constante} *)
+
+Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
+  match trace with
+  | O => reduce t
+  | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t)
+  end.
+
+Theorem scalar_norm_add_stable :
+ forall t : nat, term_stable (scalar_norm_add t).
+
+unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
+ [ exact reduce_stable
+ | intros n H e t; elim apply_right_stable;
+    [ exact (T_OMEGA11_stable e t) | exact H ] ].
+Qed.
+   
+(* \paragraph{Multiplication scalaire} *)
+Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
+  match trace with
+  | O => reduce t
+  | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t)
+  end.
+
+Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
+
+unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
+ [ exact reduce_stable
+ | intros n H e t; elim apply_right_stable;
+    [ exact (T_OMEGA16_stable e t) | exact H ] ].
+Qed.
+
+(* \paragraph{Somme d'une constante} *)
+Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
+  match trace with
+  | O => reduce t
+  | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t)
+  end.
+
+Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
+
+unfold term_stable, add_norm in |- *; 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 ] ].
+Qed.
+
+(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
+
+
+Fixpoint rewrite (s : step) : term -> term :=
+  match s with
+  | 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 => fun t : term => rewrite s2 (rewrite s1 t)
+  | C_NOP => fun 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 : forall s : step, term_stable (rewrite s).
+
+simple induction s; simpl in |- *;
+ [ intros; apply apply_both_stable; auto
+ | intros; apply apply_left_stable; auto
+ | intros; apply apply_right_stable; auto
+ | unfold term_stable in |- *; intros; elim H0; apply H
+ | unfold term_stable in |- *; 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 ].
+Qed.
+
+(* \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 : list proposition) :=
+  match nth_hyps i h with
+  | EqTerm (Tint Z0) (Tint n) =>
+      match eq_Z n 0 with
+      | true => h
+      | false => absurd
+      end
+  | _ => h
+  end.
+
+Theorem constant_not_nul_valid :
+ forall i : nat, valid_hyps (constant_not_nul i).
+
+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 H1; symmetry  in |- *; auto.
+Qed.   
+
+(* \paragraph{[O_CONSTANT_NEG]} *)
+
+Definition constant_neg (i : nat) (h : list proposition) :=
+  match nth_hyps i h with
+  | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd
+  | _ => h
+  end.
+
+Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i).
+
+unfold valid_hyps, constant_neg in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
+ unfold Zle in |- *; simpl in |- *; intros H1; elim H1;
+ [ assumption | trivial ].
+Qed.   
+
+(* \paragraph{[NOT_EXACT_DIVIDE]} *)
+Definition not_exact_divide (k1 k2 : Z) (body : term) 
+  (t i : nat) (l : list proposition) :=
+  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
+      with
+      | true =>
+          match (k2 ?= 0)%Z with
+          | Datatypes.Gt =>
+              match (k1 ?= k2)%Z with
+              | Datatypes.Gt => absurd
+              | _ => l
+              end
+          | _ => l
+          end
+      | false => l
+      end
+  | _ => l
+  end.
+
+Theorem not_exact_divide_valid :
+ forall (k1 k2 : Z) (body : term) (t i : nat),
+ valid_hyps (not_exact_divide k1 k2 body t i).
+
+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;
+ 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);
+ [ apply OMEGA4; assumption | symmetry  in |- *; auto ].
+
+Qed.
+
+(* \paragraph{[O_CONTRADICTION]} *)
+
+Definition contradiction (t i j : nat) (l : list proposition) :=
+  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
+          | _ => l
+          end
+      | _ => l
+      end
+  | _ => l
+  end.
+
+Theorem contradiction_valid :
+ forall t i j : nat, valid_hyps (contradiction t i j).
+
+unfold valid_hyps, contradiction in |- *; 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 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 |- *; 
+ 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; 
+ elim H3; auto.
+
+Qed.
+
+(* \paragraph{[O_NEGATE_CONTRADICT]} *)
+
+Definition negate_contradict (i1 i2 : nat) (h : list proposition) :=
+  match nth_hyps i1 h with
+  | EqTerm (Tint Z0) b1 =>
+      match nth_hyps i2 h with
+      | NeqTerm (Tint Z0) b2 =>
+          match eq_term b1 b2 with
+          | true => absurd
+          | false => h
+          end
+      | _ => h
+      end
+  | NeqTerm (Tint Z0) b1 =>
+      match nth_hyps i2 h with
+      | EqTerm (Tint Z0) b2 =>
+          match eq_term b1 b2 with
+          | true => absurd
+          | false => h
+          end
+      | _ => h
+      end
+  | _ => h
+  end.
+
+Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) :=
+  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
+          | true => absurd
+          | false => h
+          end
+      | _ => h
+      end
+  | 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
+          | true => absurd
+          | false => h
+          end
+      | _ => h
+      end
+  | _ => h
+  end.
+
+Theorem negate_contradict_valid :
+ forall i j : nat, valid_hyps (negate_contradict i j).
+
+unfold valid_hyps, negate_contradict in |- *; 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 in |- *; 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 ] ].
+
+Qed.
+
+Theorem negate_contradict_inv_valid :
+ forall t i j : nat, valid_hyps (negate_contradict_inv t i j).
+
+
+unfold valid_hyps, negate_contradict_inv in |- *; 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 in |- *; intros H1 H2;
+ (pattern (eq_term t2 (scalar_norm t (Tmult t4 (Tint (-1))))) in |- *;
+   apply bool_ind2; intro Aux;
+   [ generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux);
+      clear Aux
+   | generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux);
+      clear Aux ]);
+ [ intro H3; elim H1; generalize H2; rewrite H3;
+    rewrite <- (scalar_norm_stable t e); simpl in |- *;
+    elim (interp_term e t4); simpl in |- *; auto; intros p H4;
+    discriminate H4
+ | auto
+ | intro H3; elim H2; rewrite H3; elim (scalar_norm_stable t e);
+    simpl in |- *; elim H1; simpl in |- *; trivial
+ | auto ].
+
+Qed.
+
+(* \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) :=
+  match prop1 with
+  | 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))))
+      | LeqTerm (Tint Z0) b2 =>
+          match (k2 ?= 0)%Z with
+          | Datatypes.Gt =>
+              LeqTerm (Tint 0)
+                (fusion trace
+                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+          | _ => TrueTerm
+          end
+      | _ => TrueTerm
+      end
+  | LeqTerm (Tint Z0) b1 =>
+      match (k1 ?= 0)%Z with
+      | Datatypes.Gt =>
+          match prop2 with
+          | EqTerm (Tint Z0) b2 =>
+              LeqTerm (Tint 0)
+                (fusion trace
+                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+          | LeqTerm (Tint Z0) b2 =>
+              match (k2 ?= 0)%Z with
+              | Datatypes.Gt =>
+                  LeqTerm (Tint 0)
+                    (fusion trace
+                       (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+              | _ => TrueTerm
+              end
+          | _ => TrueTerm
+          end
+      | _ => TrueTerm
+      end
+  | NeqTerm (Tint Z0) b1 =>
+      match prop2 with
+      | EqTerm (Tint Z0) b2 =>
+          match eq_Z k1 0 with
+          | true => TrueTerm
+          | false =>
+              NeqTerm (Tint 0)
+                (fusion trace
+                   (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2))))
+          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.
+
+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.
+
+intros; elim H0; simpl in |- *; generalize H H1; case b; case d;
+ unfold Zle in |- *; simpl in |- *; auto.  
+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.
+
+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.
+
+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.
+
+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 |- *; 
+ intros; try discriminate; assumption.
+Qed.
+
+
+Theorem sum_valid :
+ forall (k1 k2 : Z) (t : list t_fusion), valid2 (sum k1 k2 t).
+
+unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
+ Simplify; simpl in |- *; auto; try elim (fusion_stable t); 
+ simpl in |- *; intros;
+ [ apply sum1; assumption
+ | 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 ].
+Qed.
+
+(* \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) :=
+  match prop with
+  | EqTerm (Tint Z0) b =>
+      match eq_term (scalar_norm t (Tmult body (Tint k))) b with
+      | true =>
+          match eq_Z k 0 with
+          | true => TrueTerm
+          | false => EqTerm (Tint 0) body
+          end
+      | false => TrueTerm
+      end
+  | _ => TrueTerm
+  end.
+
+Theorem exact_divide_valid :
+ forall (k : Z) (t : term) (n : nat), valid1 (exact_divide k t n).
+
+
+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 |- *; 
+ 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 p2 p3 H3 H4; discriminate H4
+   | intros p2 p3 H3 H4; discriminate H4 ]).
+
+Qed.
+
+
+
+(* \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) :=
+  match prop with
+  | LeqTerm (Tint Z0) b =>
+      match
+        eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2)))
+          b
+      with
+      | true =>
+          match (k1 ?= 0)%Z with
+          | Datatypes.Gt =>
+              match (k1 ?= k2)%Z with
+              | Datatypes.Gt => LeqTerm (Tint 0) body
+              | _ => prop
+              end
+          | _ => prop
+          end
+      | false => prop
+      end
+  | _ => prop
+  end.
+
+Theorem divide_and_approx_valid :
+ forall (k1 k2 : Z) (body : term) (t : nat),
+ valid1 (divide_and_approx k1 k2 body t).
+
+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;
+ 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.
+Qed.
+
+(* \paragraph{[MERGE_EQ]} *)
+
+Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
+  match prop1 with
+  | LeqTerm (Tint Z0) b1 =>
+      match prop2 with
+      | LeqTerm (Tint Z0) b2 =>
+          match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with
+          | true => EqTerm (Tint 0) b1
+          | false => TrueTerm
+          end
+      | _ => TrueTerm
+      end
+  | _ => TrueTerm
+  end.
+
+Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n).
+
+unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
+ auto; elim (scalar_norm_stable n e); simpl in |- *; 
+ intros; symmetry  in |- *; apply OMEGA8 with (2 := H0);
+ [ assumption | elim Zopp_eq_mult_neg_1; trivial ].
+Qed.
+
+
+
+(* \paragraph{[O_CONSTANT_NUL]} *)
+
+Definition constant_nul (i : nat) (h : list proposition) :=
+  match nth_hyps i h with
+  | NeqTerm (Tint Z0) (Tint Z0) => absurd
+  | _ => h
+  end.
+
+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.
+Qed.
+
+(* \paragraph{[O_STATE]} *)
+
+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))))
+      | _ => TrueTerm
+      end
+  | _ => TrueTerm
+  end.
+
+Theorem state_valid : forall (m : Z) (s : step), valid2 (state m s).
+
+unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify;
+ simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; 
+ intros H1 H2; elim H1;
+ rewrite (Zplus_comm (- interp_term e t5) (interp_term e t3)); 
+ elim H2; simpl in |- *; reflexivity.
+
+Qed.
+
+(* \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 : list proposition -> list (list proposition))
+  (l : list proposition) :=
+  match nth_hyps i l with
+  | NeqTerm (Tint Z0) b1 =>
+      f1 (LeqTerm (Tint 0) (add_norm t (Tplus b1 (Tint (-1)))) :: l) ++
+      f2
+        (LeqTerm (Tint 0)
+           (scalar_norm_add t (Tplus (Tmult b1 (Tint (-1))) (Tint (-1))))
+         :: l)
+  | _ => l :: nil
+  end.
+
+Theorem split_ineq_valid :
+ forall (i t : nat) (f1 f2 : list proposition -> list (list proposition)),
+ valid_list_hyps f1 ->
+ valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
+
+unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
+ generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); 
+ simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; 
+ auto; intros z; case z; simpl in |- *; auto; intro H3; 
+ apply append_valid; elim (OMEGA19 (interp_term e t2));
+ [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t);
+    simpl in |- *; auto
+ | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t);
+    simpl in |- *; auto
+ | generalize H3; unfold Zne, not in |- *; intros E1 E2; apply E1;
+    symmetry  in |- *; trivial ].
+Qed.
+
+
+(* \subsection{La fonction de rejeu de la trace} *)
+
+Fixpoint execute_omega (t : t_omega) (l : list proposition) {struct t} :
+ list (list proposition) :=
+  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_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)
+  | 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_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_NEGATE_CONTRADICT_INV t i j =>
+      (fun a : list proposition => a :: nil) (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 : forall t : t_omega, valid_list_hyps (execute_omega t).
+
+simple induction t; simpl in |- *;
+ [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+    apply (constant_not_nul_valid n ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+    apply (constant_neg_valid n ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+    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 in |- *; simpl in |- *; intros; left;
+    apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+    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 in |- *;
+    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 in |- *; simpl in |- *; intros; left;
+    apply (contradiction_valid n n0 n1 ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+    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 in |- *; simpl in |- *;
+    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 in |- *; simpl in |- *; intros i ep e lp H; left;
+    apply (constant_nul_valid i ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left;
+    apply (negate_contradict_valid i j ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; 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 in |- *;
+    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) ].
+Qed.
+
+
+(* \subsection{Les opérations globales sur le but} 
+   \subsubsection{Normalisation} *)
+
+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)))
+  | p => p
+  end.
+
+Theorem Zne_left_2 : forall x y : Z, Zne x y -> Zne 0 (x + - y).
+unfold Zne, not in |- *; intros x y H1 H2; apply H1;
+ apply (Zplus_reg_l (- y)); rewrite Zplus_comm; elim H2; 
+ rewrite Zplus_opp_l; trivial.
+Qed.
+
+Theorem move_right_valid : forall s : step, valid1 (move_right s).
+
+unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
+ elim (rewrite_stable s e); simpl in |- *;
+ [ symmetry  in |- *; 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 ].
+Qed.
+
+Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s).
+
+Theorem do_normalize_valid :
+ forall (i : nat) (s : step), valid_hyps (do_normalize i s).
+
+intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
+ apply move_right_valid.
+Qed.
+
+Fixpoint do_normalize_list (l : list step) (i : nat) 
+ (h : list proposition) {struct l} : list proposition :=
+  match l with
+  | s :: l' => do_normalize_list l' (S i) (do_normalize i s h)
+  | nil => h
+  end.
+
+Theorem do_normalize_list_valid :
+ forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
+
+simple induction l; simpl in |- *; unfold valid_hyps in |- *;
+ [ 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 ].
+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.
+
+intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
+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.
+
+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)),
+ interp_list_goal ep e l1 /\ interp_list_goal ep e l2 ->
+ interp_list_goal ep e (l1 ++ l2).
+
+intros ep e; simple induction l1;
+ [ simpl in |- *; intros l2 (H1, H2); assumption
+ | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ].
+
+Qed.
+
+Require Import 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 :=
+  match p with
+  | EqTerm _ _ => true
+  | LeqTerm _ _ => true
+  | GeqTerm _ _ => true
+  | GtTerm _ _ => true
+  | LtTerm _ _ => true
+  | NeqTerm _ _ => true
+  | FalseTerm => true
+  | TrueTerm => true
+  | Tnot t => decidability t
+  | Tand t1 t2 => decidability t1 && decidability t2
+  | Timp t1 t2 => decidability t1 && decidability t2
+  | Tor t1 t2 => decidability t1 && decidability t2
+  | Tprop _ => false
+  end.
+
+Theorem decidable_correct :
+ forall (ep : PropList) (e : list Z) (p : proposition),
+ decidability p = true -> decidable (interp_proposition ep e p).
+
+simple induction p; simpl in |- *; intros;
+ [ apply dec_eq
+ | apply dec_Zle
+ | left; auto
+ | right; unfold not in |- *; 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 ].
+
+Qed.
+
+(* 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 : list proposition) {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 :=
+  match lc with
+  | (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 :
+ forall (ep : PropList) (e : list Z) (l : list proposition) (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 |- *;
+ [ auto | intros a l1 H1 c H2 H3; apply H1; auto ].
+
+Qed.
+
+(* 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 : list proposition * proposition) :=
+  match lc with
+  | (l, c) => if decidability c then 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 :
+ 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.
+
+intros ep e lc; case lc; intros l c; simpl in |- *;
+ pattern (decidability c) in |- *; apply bool_ind2;
+ [ simpl in |- *; intros H H1; apply interp_full_false; intros H2;
+    apply not_not;
+    [ apply decidable_correct; assumption
+    | unfold not at 1 in |- *; 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 ].
+Qed.
+
+(* [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)) {struct l} :
+ list (list A) :=
+  match l with
+  | nil => nil
+  | l :: ll => (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) (ll : list proposition) {struct nn} :
+ list (list proposition) :=
+  match nn with
+  | O => ll :: nil
+  | S n =>
+      match ll with
+      | nil => nil :: nil
+      | Tor p1 p2 :: l =>
+          destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l)
+      | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l)
+      | Timp p1 p2 :: l =>
+          if decidability p1
+          then
+           destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l)
+          else map_cons _ (Timp p1 p2) (destructure_hyps n l)
+      | Tnot p :: l =>
+          match p with
+          | Tnot p1 =>
+              if decidability p1
+              then destructure_hyps n (p1 :: l)
+              else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l)
+          | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l)
+          | Tand p1 p2 =>
+              if decidability p1
+              then
+               destructure_hyps n (Tnot p1 :: l) ++
+               destructure_hyps n (Tnot p2 :: l)
+              else map_cons _ (Tnot p) (destructure_hyps n l)
+          | _ => map_cons _ (Tnot p) (destructure_hyps n l)
+          end
+      | x :: l => map_cons _ x (destructure_hyps n l)
+      end
+  end.
+
+Theorem map_cons_val :
+ forall (ep : PropList) (e : list Z) (p : proposition)
+   (l : list (list proposition)),
+ interp_proposition ep e p ->
+ interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l).
+
+simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
+Qed.
+
+Hint Resolve map_cons_val append_valid decidable_correct.
+
+Theorem destructure_hyps_valid :
+ forall n : nat, valid_list_hyps (destructure_hyps n).
+
+simple induction n;
+ [ unfold valid_list_hyps in |- *; simpl in |- *; auto
+ | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp;
+    [ simpl in |- *; auto
+    | intros p l; case p;
+       try
+        (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+          auto);
+       [ intro p'; case p';
+          try
+           (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+             auto);
+          [ simpl in |- *; intros p1 (H1, H2);
+             pattern (decidability p1) in |- *; apply bool_ind2; 
+             intro H3;
+             [ apply H; simpl in |- *; split;
+                [ apply not_not; auto | assumption ]
+             | auto ]
+          | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *;
+             elim not_or with (1 := H1); auto
+          | simpl in |- *; intros p1 p2 (H1, H2);
+             pattern (decidability p1) in |- *; apply bool_ind2; 
+             intro H3;
+             [ apply append_valid; elim not_and with (2 := H1);
+                [ intro; left; apply H; simpl in |- *; auto
+                | intro; right; apply H; simpl in |- *; auto
+                | auto ]
+             | auto ] ]
+       | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid;
+          (elim H1; intro H3; simpl in |- *; [ left | right ]); 
+          apply H; simpl in |- *; auto
+       | simpl in |- *; intros; apply H; simpl in |- *; tauto
+       | simpl in |- *; intros p1 p2 (H1, H2);
+          pattern (decidability p1) in |- *; apply bool_ind2; 
+          intro H3;
+          [ apply append_valid; elim imp_simp with (2 := H1);
+             [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto
+             | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto
+             | auto ]
+          | auto ] ] ] ].
+
+Qed.
+
+Definition prop_stable (f : proposition -> proposition) :=
+  forall (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) :=
+  match p with
+  | 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 :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_apply_left f).
+
+unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto).
+Qed.
+
+Definition p_apply_right (f : proposition -> proposition)
+  (p : proposition) :=
+  match p with
+  | 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 :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_apply_right f).
+
+unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; 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 ]).
+Qed.
+
+Definition p_invert (f : proposition -> proposition) 
+  (p : proposition) :=
+  match p with
+  | 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 :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_invert f).
+
+unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; auto;
+   [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *;
+      unfold Zne in |- *;
+      generalize (dec_eq (interp_term e t1) (interp_term e t2));
+      unfold decidable in |- *; tauto
+   | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *;
+      unfold Zgt in |- *;
+      generalize (dec_Zgt (interp_term e t1) (interp_term e t2));
+      unfold decidable, Zgt, Zle in |- *; tauto
+   | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *;
+      unfold Zlt in |- *;
+      generalize (dec_Zlt (interp_term e t1) (interp_term e t2));
+      unfold decidable, Zge in |- *; tauto
+   | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *;
+      generalize (dec_Zgt (interp_term e t1) (interp_term e t2));
+      unfold Zle, Zgt in |- *; unfold decidable in |- *; 
+      tauto
+   | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *;
+      generalize (dec_Zlt (interp_term e t1) (interp_term e t2));
+      unfold Zge, Zlt in |- *; unfold decidable in |- *; 
+      tauto
+   | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *;
+      generalize (dec_eq (interp_term e t1) (interp_term e t2));
+      unfold decidable, Zne in |- *; tauto ]).
+Qed.
+
+Theorem Zlt_left_inv : forall x y : Z, (0 <= y + -1 + - x)%Z -> (x < y)%Z.
+
+intros; apply Zsucc_lt_reg; apply Zle_lt_succ;
+ apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); 
+ rewrite Zplus_assoc; unfold Zsucc in |- *; rewrite (Zplus_assoc_reverse x);
+ rewrite (Zplus_assoc y); simpl in |- *; rewrite Zplus_0_r;
+ rewrite Zplus_opp_r; assumption.
+Qed.
+
+Theorem move_right_stable : forall s : step, prop_stable (move_right s).
+
+unfold move_right, prop_stable in |- *; intros s ep e p; split;
+ [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *;
+    [ symmetry  in |- *; 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 in |- *; intros; auto; generalize H; elim (rewrite_stable s);
+    simpl in |- *; intro H1;
+    [ rewrite (Zplus_0_r_reverse (interp_term e t0)); rewrite H1;
+       rewrite Zplus_permute; rewrite Zplus_opp_r; 
+       rewrite Zplus_0_r; trivial
+    | apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t));
+       rewrite Zplus_opp_r; assumption
+    | apply Zle_ge;
+       apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t0));
+       rewrite Zplus_opp_r; assumption
+    | apply Zlt_gt; apply Zlt_left_inv; assumption
+    | apply Zlt_left_inv; assumption
+    | unfold Zne, not in |- *; unfold Zne in H1; intro H2; apply H1;
+       rewrite H2; rewrite Zplus_opp_r; trivial ] ].
+Qed.
+
+
+Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
+  match s with
+  | 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 => fun p : proposition => p
+  end.
+
+Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
+
+
+simple induction s; simpl in |- *;
+ [ 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 in |- *; simpl in |- *; intros; split; auto ].
+Qed.
+
+Fixpoint normalize_hyps (l : list h_step) (lh : list proposition) {struct l}
+ : list proposition :=
+  match l with
+  | nil => lh
+  | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh)
+  end.
+
+Theorem normalize_hyps_valid :
+ forall l : list h_step, valid_hyps (normalize_hyps l).
+
+simple induction l; unfold valid_hyps in |- *; simpl in |- *;
+ [ 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 in |- *; intros ep1 e1 p1 H2;
+       elim (p_rewrite_stable s ep1 e1 p1); auto
+    | assumption ] ].
+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.
+
+intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
+Qed.
+
+Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
+ proposition :=
+  match s with
+  | D_left :: l =>
+      match p with
+      | Tand x y => extract_hyp_pos l x
+      | _ => p
+      end
+  | D_right :: l =>
+      match p with
+      | Tand x y => extract_hyp_pos l y
+      | _ => p
+      end
+  | D_mono :: l => match p with
+                   | Tnot x => extract_hyp_neg l x
+                   | _ => p
+                   end
+  | _ => p
+  end
+ 
+ with extract_hyp_neg (s : list direction) (p : proposition) {struct s} :
+ proposition :=
+  match s with
+  | D_left :: l =>
+      match p with
+      | 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
+  | D_right :: l =>
+      match p with
+      | Tor x y => extract_hyp_neg l y
+      | Timp x y => extract_hyp_neg l y
+      | _ => Tnot p
+      end
+  | D_mono :: l =>
+      match p with
+      | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p
+      | _ => Tnot p
+      end
+  | _ =>
+      match p with
+      | Tnot x => if decidability x then x else Tnot p
+      | _ => Tnot p
+      end
+  end.
+
+Definition co_valid1 (f : proposition -> proposition) :=
+  forall (ep : PropList) (e : list Z) (p1 : proposition),
+  interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1).
+
+Theorem extract_valid :
+ forall s : list direction,
+ valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s).
+
+unfold valid1, co_valid1 in |- *; simple induction s;
+ [ split;
+    [ simpl in |- *; auto
+    | intros ep e p1; case p1; simpl in |- *; auto; intro p;
+       pattern (decidability p) in |- *; apply bool_ind2;
+       [ intro H; generalize (decidable_correct ep e p H);
+          unfold decidable in |- *; tauto
+       | simpl in |- *; auto ] ]
+ | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto;
+    case p; auto; simpl in |- *; intros;
+    (apply H1; tauto) ||
+      (apply H2; tauto) ||
+        (pattern (decidability p0) in |- *; apply bool_ind2;
+          [ intro H3; generalize (decidable_correct ep e p0 H3);
+             unfold decidable in |- *; intro H4; apply H1; 
+             tauto
+          | intro; tauto ]) ].
+
+Qed.
+
+Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} :
+ list (list proposition) :=
+  match s with
+  | E_SPLIT i dl s1 s2 =>
+      match extract_hyp_pos dl (nth_hyps i h) with
+      | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h)
+      | Tnot (Tand x y) =>
+          if decidability x
+          then
+           decompose_solve s1 (Tnot x :: h) ++
+           decompose_solve s2 (Tnot y :: h)
+          else h :: nil
+      | _ => h :: nil
+      end
+  | E_EXTRACT i dl s1 =>
+      decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h)
+  | E_SOLVE t => execute_omega t h
+  end.
+
+Theorem decompose_solve_valid :
+ forall s : e_step, valid_list_goal (decompose_solve s).
+
+intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
+ simpl in |- *; intros;
+ [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp)));
+    [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto;
+       [ intro p; case p; 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 ]
+       | 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 ] ]
+    | 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)),
+  interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp).
+
+Fixpoint reduce_lhyps (lp : list (list proposition)) :
+ list (list proposition) :=
+  match lp with
+  | (FalseTerm :: nil) :: lp' => reduce_lhyps lp'
+  | x :: lp' => x :: reduce_lhyps lp'
+  | nil => nil (A:=list proposition)
+  end.
+
+Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
+
+unfold valid_lhyps in |- *; intros ep e lp; elim lp;
+ [ simpl in |- *; auto
+ | intros a l HR; elim a;
+    [ simpl in |- *; tauto
+    | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ].
+Qed.
+
+Theorem do_reduce_lhyps :
+ forall (envp : PropList) (env : list Z) (l : list (list proposition)),
+ 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.
+Qed.
+
+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.
+
+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);
+       unfold decidable in |- *; simpl in |- *; tauto
+    | simpl in |- *; intros H1 H2; elim H2; trivial ]
+ | simpl in |- *; tauto ].
+Qed.
+
+Definition omega_tactic (t1 : e_step) (t2 : list h_step) 
+  (c : proposition) (l : list proposition) :=
+  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),
+ interp_list_goal envp env (omega_tactic t1 t2 c l) ->
+ interp_goal_concl envp env c 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
diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml
new file mode 100644
index 00000000..3b2a7d31
--- /dev/null
+++ b/contrib/romega/const_omega.ml
@@ -0,0 +1,488 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+let module_refl_name = "ReflOmegaCore"
+let module_refl_path = ["Coq"; "romega"; module_refl_name]
+
+type result = 
+   Kvar of string
+ | Kapp of string * Term.constr list
+ | Kimp of Term.constr * Term.constr
+ | Kufo;;
+
+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
+		(Nametab.id_of_global (Libnames.ConstRef sp)),
+	      args)
+    | Term.Construct csp , args ->
+	Kapp (Names.string_of_id
+		(Nametab.id_of_global (Libnames.ConstructRef csp)),
+	      args)
+    | Term.Ind isp, args ->
+	Kapp (Names.string_of_id
+		(Nametab.id_of_global (Libnames.IndRef isp)),
+	      args)
+    | Term.Var id,[] -> Kvar(Names.string_of_id id)
+    | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
+    | Term.Prod (Names.Name _,_,_),[] ->
+	Util.error "Omega: Not a quantifier-free goal"
+    | _ -> Kufo
+
+exception Destruct
+
+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.Construct csp -> Libnames.ConstructRef csp
+    | Term.Ind isp       -> Libnames.IndRef isp
+    | _ -> raise Destruct
+  in  Nametab.id_of_global ref, args
+
+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
+     | _ -> 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";;
+
+
+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")]]
+    @ [module_refl_path]
+
+
+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_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_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_Zgt = lazy (constant "Zgt")
+let coq_Zle = lazy (constant "Zle")
+let coq_inject_nat = lazy (constant  "inject_nat")
+
+(* Peano *)
+let coq_le = lazy(constant "le")
+let coq_gt = lazy(constant "gt")
+
+(* Integers *)
+let coq_nat = lazy(constant "nat")
+let coq_S = lazy(constant "S")
+let coq_O = lazy(constant "O")
+let coq_minus = lazy(constant "minus")
+
+(* Logic *)
+let coq_eq = lazy(constant  "eq")
+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_ex = lazy(constant "ex")
+let coq_I = lazy(constant "I")
+
+(* Lists *)
+let coq_cons =  lazy (constant "cons")
+let coq_nil =  lazy (constant "nil")
+
+let coq_pcons = lazy (constant "Pcons")
+let coq_pnil = lazy (constant "Pnil")
+
+let coq_h_step = lazy (constant "h_step")
+let coq_pair_step = lazy (constant  "pair_step")
+let coq_p_left = lazy (constant  "P_LEFT")
+let coq_p_right = lazy (constant  "P_RIGHT")
+let coq_p_invert = lazy (constant  "P_INVERT")
+let coq_p_step = lazy (constant  "P_STEP")
+let coq_p_nop = lazy (constant  "P_NOP")
+
+
+let coq_t_int = lazy (constant  "Tint")
+let coq_t_plus = lazy (constant  "Tplus")
+let coq_t_mult = lazy (constant  "Tmult")
+let coq_t_opp = lazy (constant  "Topp")
+let coq_t_minus = lazy (constant  "Tminus")
+let coq_t_var = lazy (constant  "Tvar")
+
+let coq_p_eq = lazy (constant  "EqTerm")
+let coq_p_leq = lazy (constant  "LeqTerm")
+let coq_p_geq = lazy (constant  "GeqTerm")
+let coq_p_lt = lazy (constant  "LtTerm")
+let coq_p_gt = lazy (constant  "GtTerm")
+let coq_p_neq = lazy (constant  "NeqTerm")
+let coq_p_true = lazy (constant  "TrueTerm")
+let coq_p_false = lazy (constant  "FalseTerm")
+let coq_p_not = lazy (constant  "Tnot")
+let coq_p_or = lazy (constant  "Tor")
+let coq_p_and = lazy (constant  "Tand")
+let coq_p_imp = lazy (constant  "Timp")
+let coq_p_prop = lazy (constant  "Tprop")
+
+let coq_proposition = lazy (constant  "proposition")
+let coq_interp_sequent = lazy (constant  "interp_goal_concl")
+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")
+
+(* Constructors for shuffle tactic *)
+let coq_t_fusion =  lazy (constant  "t_fusion")
+let coq_f_equal =  lazy (constant  "F_equal")
+let coq_f_cancel =  lazy (constant  "F_cancel")
+let coq_f_left =  lazy (constant  "F_left")
+let coq_f_right =  lazy (constant  "F_right")
+
+(* Constructors for reordering tactics *)
+let coq_step = lazy (constant  "step")
+let coq_c_do_both = lazy (constant  "C_DO_BOTH")
+let coq_c_do_left = lazy (constant  "C_LEFT")
+let coq_c_do_right = lazy (constant  "C_RIGHT")
+let coq_c_do_seq = lazy (constant  "C_SEQ")
+let coq_c_nop = lazy (constant  "C_NOP")
+let coq_c_opp_plus = lazy (constant  "C_OPP_PLUS")
+let coq_c_opp_opp = lazy (constant  "C_OPP_OPP")
+let coq_c_opp_mult_r = lazy (constant  "C_OPP_MULT_R")
+let coq_c_opp_one = lazy (constant  "C_OPP_ONE")
+let coq_c_reduce = lazy (constant  "C_REDUCE")
+let coq_c_mult_plus_distr = lazy (constant  "C_MULT_PLUS_DISTR")
+let coq_c_opp_left = lazy (constant  "C_MULT_OPP_LEFT")
+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_red0 = lazy (constant  "C_RED0")
+let coq_c_red1 = lazy (constant  "C_RED1")
+let coq_c_red2 = lazy (constant  "C_RED2")
+let coq_c_red3 = lazy (constant  "C_RED3")
+let coq_c_red4 = lazy (constant  "C_RED4")
+let coq_c_red5 = lazy (constant  "C_RED5")
+let coq_c_red6 = lazy (constant  "C_RED6")
+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_s_constant_not_nul = lazy (constant  "O_CONSTANT_NOT_NUL")
+let coq_s_constant_neg = lazy (constant  "O_CONSTANT_NEG")
+let coq_s_div_approx = lazy (constant  "O_DIV_APPROX")
+let coq_s_not_exact_divide = lazy (constant  "O_NOT_EXACT_DIVIDE")
+let coq_s_exact_divide = lazy (constant  "O_EXACT_DIVIDE")
+let coq_s_sum = lazy (constant  "O_SUM")
+let coq_s_state = lazy (constant  "O_STATE")
+let coq_s_contradiction = lazy (constant  "O_CONTRADICTION")
+let coq_s_merge_eq = lazy (constant  "O_MERGE_EQ")
+let coq_s_split_ineq =lazy (constant  "O_SPLIT_INEQ")
+let coq_s_constant_nul =lazy (constant  "O_CONSTANT_NUL")
+let coq_s_negate_contradict =lazy (constant  "O_NEGATE_CONTRADICT")
+let coq_s_negate_contradict_inv =lazy (constant  "O_NEGATE_CONTRADICT_INV")
+
+(* construction for the [extract_hyp] tactic *)
+let coq_direction = lazy  (constant  "direction")
+let coq_d_left = lazy  (constant  "D_left")
+let coq_d_right = lazy  (constant  "D_right")
+let coq_d_mono = lazy  (constant  "D_mono")
+
+let coq_e_split = lazy  (constant  "E_SPLIT")
+let coq_e_extract = lazy  (constant  "E_EXTRACT")
+let coq_e_solve = lazy  (constant  "E_SOLVE")
+
+let coq_decompose_solve_valid = 
+  lazy (constant   "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} *)
+
+
+let mk_var v = Term.mkVar (Names.id_of_string v)
+let mk_plus t1 t2 = Term.mkApp (Lazy.force coq_Zplus,[|  t1; t2 |])
+let mk_times t1 t2 = Term.mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
+let mk_minus t1 t2 = Term.mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
+let mk_eq t1 t2 = Term.mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |])
+let mk_le t1 t2 = Term.mkApp (Lazy.force coq_Zle, [|t1; t2 |])
+let mk_gt t1 t2 = Term.mkApp (Lazy.force coq_Zgt, [|t1; t2 |])
+let mk_inv t = Term.mkApp (Lazy.force coq_Zopp, [|t |])
+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 |])
+
+
+let do_left t = 
+  if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
+  else Term.mkApp (Lazy.force coq_c_do_left, [|t |] )
+
+let do_right t = 
+  if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
+  else Term.mkApp (Lazy.force coq_c_do_right, [|t |])
+
+let do_both t1 t2 = 
+  if t1 = Lazy.force coq_c_nop then do_right t2
+  else if t2 = Lazy.force coq_c_nop then do_left t1
+  else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |])
+
+let do_seq t1 t2 =
+  if t1 = Lazy.force coq_c_nop then t2
+  else if t2 = Lazy.force coq_c_nop then t1
+  else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |])
+  
+let rec do_list = function
+  | [] -> Lazy.force coq_c_nop
+  | [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 = 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) |])
+
+let mk_Z = mk_integer
+
+let rec mk_nat = function
+  | 0 -> Lazy.force coq_O
+  | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |])
+
+let mk_list typ l =
+  let rec loop = function
+    | [] ->
+	Term.mkApp (Lazy.force coq_nil, [|typ|])
+    | (step :: l) -> 
+	Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
+  loop l
+
+let mk_plist l =
+  let rec loop = function
+    | [] ->
+	(Lazy.force coq_pnil)
+    | (step :: l) -> 
+	Term.mkApp (Lazy.force coq_pcons, [| step; loop l |]) in
+  loop l
+
+
+let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
+
diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4
new file mode 100644
index 00000000..386f7f28
--- /dev/null
+++ b/contrib/romega/g_romega.ml4
@@ -0,0 +1,15 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Refl_omega
+
+TACTIC EXTEND ROmega
+  [ "ROmega" ] -> [ total_reflexive_omega_tactic ]
+END
diff --git a/contrib/romega/omega2.ml b/contrib/romega/omega2.ml
new file mode 100644
index 00000000..91aefc60
--- /dev/null
+++ b/contrib/romega/omega2.ml
@@ -0,0 +1,675 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..ef68c587
--- /dev/null
+++ b/contrib/romega/refl_omega.ml
@@ -0,0 +1,1307 @@
+(*************************************************************************
+
+   PROJET RNRT Calife - 2001
+   Author: Pierre Crégut - France Télécom R&D
+   Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+open Const_omega
+
+
+(* \section{Useful functions and flags} *)
+(* Especially useful debugging functions *)
+let debug = ref false
+
+let show_goal gl =
+  if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl
+
+let pp i = print_int i; print_newline (); flush stdout
+
+(* More readable than the prefix notation *)
+let (>>) = Tacticals.tclTHEN
+
+(* [list_index t l = i] \eqv $nth l i = t \wedge \forall j < i nth l j != t$ *)
+
+let list_index t = 
+  let rec loop i = function
+    | (u::l) -> if u = t then i else loop (i+1) l
+    | [] -> raise Not_found in
+  loop 0
+
+(* [list_uniq l = filter_i (x i -> nth l (i-1) != x) l] *)
+let list_uniq l  = 
+  let rec uniq = function
+      x :: ((y :: _) as l) when x = y -> uniq l
+    | x :: l -> x :: uniq l
+    | [] -> [] in
+  uniq (List.sort compare l)
+
+(* $\forall x. mem x  (list\_union l1 l2) \eqv x \in \{l1\} \cup \{l2\}$ *)
+let list_union l1 l2 =
+  let rec loop buf = function
+      x :: r -> if List.mem x l2 then loop buf r else loop (x :: buf) r
+    | [] -> buf in
+  loop l2 l1
+
+(* $\forall x. 
+      mem \;\; x \;\; (list\_intersect\;\; l1\;\;l2) \eqv x \in \{l1\} 
+       \cap \{l2\}$ *)
+let list_intersect l1 l2 =
+  let rec loop buf = function
+      x :: r -> if List.mem x l2 then loop (x::buf) r else loop buf r
+    | [] -> buf in
+  loop [] l1
+
+(* cartesian product. Elements are lists and are concatenated.
+   $cartesian [x_1 ... x_n] [y_1 ... y_p] = [x_1 @ y_1, x_2 @ y_1 ... x_n @ y_1 , x_1 @ y_2 ... x_n @ y_p]$ *)
+
+let rec cartesien l1 l2 =
+  let rec loop = function
+      (x2 :: r2) -> List.map (fun x1 -> x1 @ x2) l1 @ loop r2
+    | [] -> [] in
+  loop l2
+
+(* remove element e from list l *)
+let list_remove e l =
+  let rec loop = function
+      x :: l -> if x = e then loop l else x :: loop l
+    | [] -> [] in
+  loop l
+
+(* equivalent of the map function but no element is added when the function
+   raises an exception (and the computation silently continues) *)
+let map_exc f = 
+  let rec loop = function 
+    (x::l) -> 
+      begin match try Some (f x) with exc -> None with
+        Some v -> v :: loop l | None -> loop l
+      end
+    | [] -> [] in
+  loop 
+
+let mkApp = Term.mkApp
+
+(* \section{Types}
+  \subsection{How to walk in a term}
+  To represent how to get to a proposition. Only choice points are
+  kept (branch to choose in a disjunction  and identifier of the disjunctive 
+  connector) *)
+type direction = Left of int | Right of int
+
+(* Step to find a proposition (operators are at most binary). A list is
+   a path *)
+type occ_step = O_left | O_right | O_mono
+type occ_path = occ_step list
+
+(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
+   d'une liste de pas à partir de la racine de l'hypothèse *)
+type occurence = {o_hyp : Names.identifier; o_path : occ_path}
+
+(* \subsection{refiable formulas} *)
+type oformula =
+    (* integer *)
+  | Oint of int
+    (* recognized binary and unary operations *)
+  | Oplus of oformula * oformula
+  | Omult of oformula * oformula
+  | Ominus of oformula * oformula
+  | Oopp of  oformula
+    (* an atome in the environment *)
+  | Oatom of int
+    (* weird expression that cannot be translated *)
+  | Oufo of oformula
+
+(* Operators for comparison recognized by Omega *)
+type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
+
+(* Type des prédicats réifiés (fragment de calcul propositionnel. Les 
+ * quantifications sont externes au langage) *)
+type oproposition = 
+    Pequa of Term.constr * oequation
+  | Ptrue 
+  | Pfalse
+  | Pnot of oproposition
+  | Por of int * oproposition * oproposition
+  | Pand of int * oproposition * oproposition
+  | Pimp of int * oproposition * oproposition
+  | Pprop of Term.constr
+
+(* Les équations ou proposiitions atomiques utiles du calcul *)
+and oequation = {
+    e_comp: comparaison;		(* comparaison *)
+    e_left: oformula;			(* formule brute gauche *)
+    e_right: oformula;			(* formule brute droite *)
+    e_trace: Term.constr;		(* tactique de normalisation *)
+    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
+    e_negated: bool;			(* vrai si apparait en position nié 
+					   après normalisation *)
+    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 *)
+  } 
+
+(* \subsection{Proof context} 
+  This environment codes 
+  \begin{itemize}
+  \item the terms and propositions that are given as
+  parameters of the reified proof (and are represented as variables in the
+  reified goals)
+  \item translation functions linking the decision procedure and the Coq proof
+  \end{itemize} *)
+
+type environment = {
+  (* La liste des termes non reifies constituant l'environnement global *)
+  mutable terms : Term.constr list;
+  (* La meme chose pour les propositions *)
+  mutable props : Term.constr list;
+  (* Les variables introduites par omega *)
+  mutable om_vars : (oformula * int) list;
+  (* Traduction des indices utilisés ici en les indices finaux utilisés par 
+   * la tactique Omega après dénombrement des variables utiles *)
+  real_indices : (int,int) Hashtbl.t;
+  mutable cnt_connectors : int;
+  equations : (int,oequation) Hashtbl.t;
+  constructors : (int, occurence) Hashtbl.t
+}
+
+(* \subsection{Solution tree}
+   Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
+   d'un ensemble d'équation dont dépend la solution et d'une trace *)
+type solution = {
+  s_index : int;
+  s_equa_deps : int list;
+  s_trace : Omega2.action list }
+
+(* Arbre de solution résolvant complètement un ensemble de systèmes *)
+type solution_tree = 
+    Leaf of solution
+    (* un noeud interne représente un point de branchement correspondant à
+       l'élimination d'un connecteur générant plusieurs buts
+       (typ. disjonction). Le premier argument
+       est l'identifiant du connecteur *)
+  | Tree of int * solution_tree * solution_tree
+
+(* Représentation de l'environnement extrait du but initial sous forme de
+   chemins pour extraire des equations ou d'hypothèses *)
+
+type context_content = 
+    CCHyp of occurence
+  | CCEqua of int
+
+(* \section{Specific utility functions to handle base types} *)
+(* Nom arbitraire de l'hypothèse codant la négation du but final *)  
+let id_concl = Names.id_of_string "__goal__"
+
+(* Initialisation de l'environnement de réification de la tactique *)
+let new_environment () = {
+  terms = []; props = []; om_vars = []; cnt_connectors = 0; 
+  real_indices = Hashtbl.create 7;
+  equations = Hashtbl.create 7;
+  constructors = Hashtbl.create 7;
+}
+
+(* Génération d'un nom d'équation *)
+let new_eq_id env =
+   env.cnt_connectors <- env.cnt_connectors + 1; env.cnt_connectors
+
+(* Calcul de la branche complémentaire *)
+let barre = function Left x -> Right x | Right x -> Left x
+
+(* Identifiant associé à une branche *)
+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"
+    | t :: l -> 
+	Printf.printf "(%c%02d) : " c i;
+	Pp.ppnl (Printer.prterm 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
+
+
+(* \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
+(* Affichage des variables d'un système *)
+let display_omega_id i = Printf.sprintf "O%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) *)
+
+let intern_omega env t =
+  begin try List.assoc t env.om_vars
+  with Not_found -> 
+    let v = new_omega_id () 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
+   réifié introduit de force *)
+let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
+
+(* Récupère le terme associé à une variable *)
+let unintern_omega env id =
+  let rec loop = function 
+	[] -> failwith "unintern" 
+      | ((t,j)::l) -> if id = j then t else loop l in
+  loop env.om_vars
+
+(* \subsection{Gestion des environnements de variable pour la réflexion} 
+   Gestion des environnements de traduction entre termes des constructions
+   non réifiés et variables des termes reifies. Attention il s'agit de 
+   l'environnement initial contenant tout. Il faudra le réduire après
+   calcul des variables utiles. *)
+
+let add_reified_atom t env =
+  try list_index t env.terms
+  with Not_found ->
+    let i = List.length env.terms in
+    env.terms <- env.terms @ [t]; i
+
+let get_reified_atom env = 
+  try List.nth env.terms with _ -> failwith "get_reified_atom"
+
+(* \subsection{Gestion de l'environnement de proposition pour Omega} *)
+(* ajout d'une proposition *)
+let add_prop env t =
+  try list_index t env.props
+  with Not_found ->
+    let i = List.length env.props in  env.props <- env.props @ [t]; i
+
+(* accès a une proposition *)
+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
+  try let _ = Hashtbl.find env.equations id in ()
+  with Not_found -> Hashtbl.add env.equations id e
+
+(* accès a une equation *)
+let get_equation env id = 
+  try Hashtbl.find env.equations id
+  with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e
+
+(* Affichage des termes réifiés *)
+let rec oprint ch = function 
+  | Oint n -> Printf.fprintf ch "%d" 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 
+  | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1
+  | Oatom n -> Printf.fprintf ch "V%02d" n
+  | Oufo x ->  Printf.fprintf ch "?"
+
+let rec pprint ch = function
+    Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 })  ->
+      let connector = 
+	match comp with 
+	  Eq -> "=" | Leq -> "=<" | Geq -> ">="
+	| Gt -> ">" | Lt -> "<" | Neq -> "!=" in
+      Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2  
+  | Ptrue -> Printf.fprintf ch "TT"
+  | Pfalse -> Printf.fprintf ch "FF"
+  | Pnot t -> Printf.fprintf ch "not(%a)" pprint t
+  | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2  
+  | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2  
+  | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2  
+  | Pprop c -> Printf.fprintf ch "Prop"
+
+let rec weight env = function
+  | Oint _ -> -1
+  | Oopp c -> weight env c
+  | Omult(c,_) -> weight env c
+  | Oplus _ -> failwith "weight"
+  | Ominus _ -> failwith "weight minus"
+  | Oufo _ -> -1
+  | Oatom _ as c -> (intern_omega env c)
+
+(* \section{Passage entre oformules et représentation interne de Omega} *)
+
+(* \subsection{Oformula vers Omega} *)
+
+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
+    | Oint n ->
+	let id = new_omega_id () in
+	(*i tag_equation name id; i*)
+	{Omega2.kind = kind; Omega2.body = List.rev accu; 
+	 Omega2.constant = n; Omega2.id = id}
+    | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in
+  loop []
+
+(* \subsection{Omega vers Oformula} *)
+
+let reified_of_atom env i =
+  try Hashtbl.find env.real_indices i
+  with Not_found -> 
+    Printf.printf "Atome %d non trouvé\n" i; 
+    Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
+    raise Not_found
+
+let rec oformula_of_omega env af = 
+  let rec loop = function
+    | ({Omega2.v=v; Omega2.c=n}::r) ->
+	Oplus(Omult(unintern_omega env v,Oint n),loop r)
+    | [] -> Oint af.Omega2.constant in
+  loop af.Omega2.body
+
+let app f v = mkApp(Lazy.force f,v)
+
+(* \subsection{Oformula vers COQ reel} *)
+
+let rec coq_of_formula env t =
+  let rec loop = function
+  | Oplus (t1,t2) -> app coq_Zplus [| loop t1; loop t2 |]
+  | Oopp t -> app coq_Zopp [| loop t |]
+  | Omult(t1,t2) -> app coq_Zmult [| loop t1; loop t2 |]
+  | Oint v ->   mk_Z v
+  | Oufo t -> loop t
+  | Oatom var ->
+      (* attention ne traite pas les nouvelles variables si on ne les
+       * met pas dans env.term *)
+      get_reified_atom env var
+  | Ominus(t1,t2) -> app coq_Zminus [| loop t1; loop t2 |] in
+  loop t
+
+(* \subsection{Oformula vers COQ reifié} *)
+
+let rec reified_of_formula env = function
+  | Oplus (t1,t2) ->
+      app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Oopp t ->
+      app coq_t_opp [| reified_of_formula env t |]
+  | Omult(t1,t2) ->
+      app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Oint v ->  app coq_t_int [| mk_Z v |]
+  | Oufo t -> reified_of_formula env t
+  | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |]
+  | Ominus(t1,t2) ->
+      app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |]
+
+let reified_of_formula env f =
+  begin try reified_of_formula env f with e -> oprint stderr f; raise e end
+
+let rec reified_of_proposition env = function
+    Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> 
+      app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> 
+      app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> 
+      app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> 
+      app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) ->  
+      app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> 
+      app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |]
+  | Ptrue -> Lazy.force coq_p_true
+  | Pfalse -> Lazy.force coq_p_false
+  | Pnot t -> 
+      app coq_p_not [| reified_of_proposition env t |]
+  | Por (_,t1,t2) -> 
+      app coq_p_or
+	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
+  | Pand(_,t1,t2) -> 
+      app coq_p_and
+	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
+  | Pimp(_,t1,t2) -> 
+      app coq_p_imp
+	[| reified_of_proposition env t1; reified_of_proposition env t2 |]
+  | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
+
+let reified_of_proposition env f =
+  begin try reified_of_proposition env f 
+  with e -> pprint stderr f; raise e end
+
+(* \subsection{Omega vers COQ réifié} *)
+
+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 coef = 
+      app coq_t_mult 
+	[| reified_of_formula env (unintern_omega env v); 
+	   app coq_t_int [| mk_Z c |] |] in
+    app coq_t_plus [|coef; t |] in
+  List.fold_right mk_coeff body coeff_constant
+
+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 
+  end
+
+(* \section{Opérations sur les équations}
+Ces fonctions préparent les traces utilisées par la tactique réfléchie
+pour faire des opérations de normalisation sur les équations.  *)
+
+(* \subsection{Extractions des variables d'une équation} *)
+(* Extraction des variables d'une équation *)
+
+let rec vars_of_formula = function
+  | Oint _ -> []
+  | Oplus (e1,e2)  -> (vars_of_formula e1) @ (vars_of_formula e2)
+  | Omult (e1,e2)  -> (vars_of_formula e1) @ (vars_of_formula e2)
+  | Ominus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2)
+  | Oopp e -> (vars_of_formula e)
+  | Oatom i -> [i]
+  | Oufo _ -> []
+
+let vars_of_equations l =
+  let rec loop = function
+      e :: l -> vars_of_formula e.e_left @ vars_of_formula e.e_right @ loop l
+    | [] -> [] in
+  list_uniq (List.sort compare (loop l))
+
+(* \subsection{Multiplication par un scalaire} *)
+
+let rec scalar n = function
+   Oplus(t1,t2) -> 
+     let tac1,t1' = scalar  n t1 and 
+         tac2,t2' = scalar  n t2 in
+     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))
+ | Omult(t1,Oint x) -> 
+     do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
+ | Omult(t1,t2) -> 
+     Util.error "Omega: Can't solve a goal with non-linear products"
+ | (Oatom _ as t) -> do_list [], Omult(t,Oint n)
+ | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
+ | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
+ | Ominus _ -> failwith "scalar minus"
+
+(* \subsection{Propagation de l'inversion} *)
+
+let rec negate = function
+   Oplus(t1,t2) -> 
+     let tac1,t1' = negate t1 and 
+         tac2,t2' = negate t2 in
+     do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)],
+     Oplus(t1',t2')
+ | 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))
+ | 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)
+ | Oufo c -> do_list [], Oufo (Oopp c)
+ | Ominus _ -> failwith "negate minus"
+
+let rec norm l = (List.length l)
+
+(* \subsection{Mélange (fusion) de deux équations} *)
+(* \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') ->
+	if v1 = v2 then
+          if k1*c1 + k2 * c2 = 0 then (
+            Lazy.force coq_f_cancel :: loop (l1,l2))
+          else (
+            Lazy.force coq_f_equal :: loop (l1,l2) )
+	else if v1 > v2 then (
+	  Lazy.force coq_f_left :: loop(l1,l2'))
+	else (
+	  Lazy.force coq_f_right :: loop(l1',l2))
+    | ({Omega2.c=c1;Omega2.v=v1}::l1), [] -> 
+	  Lazy.force coq_f_left :: loop(l1,[])
+    | [],({Omega2.c=c2;Omega2.v=v2}::l2) -> 
+	  Lazy.force coq_f_right :: loop([],l2)
+    | [],[] -> flush stdout; [] in
+  mk_shuffle_list (loop (e1,e2))
+
+(* \subsubsection{Version sans coefficients} *)
+let rec shuffle env (t1,t2) = 
+  match t1,t2 with
+    Oplus(l1,r1), Oplus(l2,r2) ->
+      if weight env l1 > weight env l2 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 
+	let l_action,t' = shuffle env (t1,r2) in
+	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
+  | Oplus(l1,r1), 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)
+  | t1,Oplus(l2,r2) -> 
+      if weight env l2 > weight env t1 then
+        let (l_action,t') = shuffle env (t1,r2) in
+	do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
+      else do_list [],Oplus(t1,t2)
+  | Oint t1,Oint 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)
+      else do_list [],Oplus(t1,t2)
+
+(* \subsection{Fusion avec réduction} *)
+
+let shrink_pair f1 f2 =
+  begin match f1,f2 with
+     Oatom v,Oatom _ -> 
+       Lazy.force coq_c_red1, Omult(Oatom v,Oint 2)
+   | Oatom v, Omult(_,c2) -> 
+       Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint 1))
+   | Omult (v1,c1),Oatom v -> 
+       Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint 1))
+   | Omult (Oatom v,c1),Omult (v2,c2) ->
+       Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
+   | t1,t2 -> 
+       oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); 
+       flush Pervasives.stdout; Util.error "shrink.1"
+  end
+
+(* \subsection{Calcul d'une sous formule constante} *)
+
+let reduce_factor = function
+   Oatom v ->
+     let r = Omult(Oatom v,Oint 1) in
+       [Lazy.force coq_c_red0],r
+  | Omult(Oatom v,Oint n) as f -> [],f
+  | Omult(Oatom v,c) ->
+      let rec compute = function
+          Oint n -> n
+	| Oplus(t1,t2) -> compute t1 + compute t2 
+	| _ -> Util.error "condense.1" in
+	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
+  | t -> Util.error "reduce_factor.1"
+
+(* \subsection{Réordonancement} *)
+
+let rec condense env = function
+    Oplus(f1,(Oplus(f2,r) as t)) ->
+      if weight env f1 = weight env f2 then begin
+	let shrink_tac,t = shrink_pair f1 f2 in
+	let assoc_tac = Lazy.force coq_c_plus_assoc_l in
+	let tac_list,t' = condense env (Oplus(t,r)) in
+	assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t'
+      end else begin
+	let tac,f = reduce_factor f1 in
+	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) -> 
+      let tac,f1' = reduce_factor f1 in 
+      [do_left (do_list tac)],Oplus(f1',Oint n)
+  | Oplus(f1,f2) -> 
+      if weight env f1 = weight env f2 then begin
+	let tac_shrink,t = shrink_pair f1 f2 in
+	let tac,t' = condense env t in
+	tac_shrink :: tac,t'
+      end else begin
+	let tac,f = reduce_factor f1 in
+	let tac',t' = condense env f2 in 
+	[do_both (do_list tac) (do_list tac')],Oplus(f,t') 
+      end
+  | (Oint _ as t)-> [],t
+  | t -> 
+      let tac,t' = reduce_factor t in
+      let final = Oplus(t',Oint 0) 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) ->
+     let tac',t = clear_zero r in
+     Lazy.force coq_c_red5 :: tac',t
+  | Oplus(f,r) -> 
+      let tac,t = clear_zero r in 
+      (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
+  | t -> [],t;;
+
+(* \subsection{Transformation des hypothèses} *)
+
+let rec reduce env = function
+    Oplus(t1,t2) ->
+      let t1', trace1 = reduce env t1 in
+      let t2', trace2 = reduce env t2 in
+      let trace3,t' = shuffle env (t1',t2') in
+      t', do_list [do_both trace1 trace2; trace3]
+  | Ominus(t1,t2) ->
+      let t,trace = reduce env (Oplus(t1, Oopp t2)) in
+      t, do_list [Lazy.force coq_c_minus; trace]
+  | Omult(t1,t2) as t ->
+      let t1', trace1 = reduce env t1 in
+      let t2', trace2 = reduce env t2 in
+      begin match t1',t2' with
+      | (_, Oint n) ->
+	  let tac,t' = scalar n t1' in
+	  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]
+      | _ -> Oufo t, Lazy.force coq_c_nop
+      end
+  | Oopp t ->
+      let t',trace = reduce env  t in
+      let trace',t'' = negate t' in
+      t'', do_list [do_left trace; trace']
+  | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop
+
+let normalize_linear_term env t =
+  let t1,trace1 = reduce env t in
+  let trace2,t2 = condense env t1 in
+  let trace3,t3 = clear_zero t2 in
+  do_list [trace1; do_list trace2; do_list trace3], t3
+
+(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
+let negate_oper = function
+    Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
+ 
+let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = 
+  let mk_step t1 t2 f kind =
+    let t = f t1 t2 in
+    let trace, oterm = normalize_linear_term env t in
+    let equa = omega_of_oformula env kind oterm in 
+    { e_comp = oper; e_left = t1; e_right = t2; 
+      e_negated = negated; e_depends = depends; 
+      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
+    | Lt  ->
+        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint (-1)),Oopp o1))
+	  Omega2.INEQ
+    | Gt ->
+        mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint (-1)),Oopp o2)) 
+	  Omega2.INEQ
+  with e when Logic.catchable_exception e -> raise e
+
+(* \section{Compilation des hypothèses} *)
+
+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(("Zpos"|"Zneg"|"Z0"),_) -> 
+      begin try Oint(recognize_number t)
+      with _ -> Oatom (add_reified_atom t env) end
+  | _ -> 
+      Oatom (add_reified_atom t env)
+  with e when Logic.catchable_exception e ->
+    Oatom (add_reified_atom t env)
+
+and  binop env c t1 t2 = 
+    let t1' = oformula_of_constr env t1 in
+    let t2' = oformula_of_constr env t2 in
+    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 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
+    Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path};
+  let t1' = 
+    oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
+  let t2' =
+    oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
+  (* On numérote le connecteur dans l'environnement. *)
+  c i t1' t2'
+
+and mk_equation env ctxt c connector t1 t2 =
+  let t1' = oformula_of_constr env t1 in
+  let t2' = oformula_of_constr env t2 in
+  (* On ajoute l'equation dans l'environnement. *)
+  let omega = normalize_equation env ctxt (connector,t1',t2') in
+  add_equation env omega;
+  Pequa (c,omega)
+
+and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = 
+  try match destructurate c with
+    | Kapp("eq",[typ;t1;t2]) 
+      when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) ->
+         mk_equation env ctxt c Eq t1 t2
+    | Kapp("Zne",[t1;t2]) -> 
+	mk_equation env ctxt c Neq t1 t2
+    | Kapp("Zle",[t1;t2]) -> 
+	mk_equation env ctxt c Leq t1 t2
+    | Kapp("Zlt",[t1;t2]) -> 
+	mk_equation env ctxt c Lt t1 t2
+    | Kapp("Zge",[t1;t2]) -> 
+	mk_equation env ctxt c Geq t1 t2
+    | Kapp("Zgt",[t1;t2]) -> 
+	mk_equation env ctxt c Gt t1 t2
+    | Kapp("True",[]) -> Ptrue
+    | Kapp("False",[]) -> Pfalse
+    | Kapp("not",[t]) ->
+       let t' = 
+	 oproposition_of_constr 
+	   env (not negated, depends, origin,(O_mono::path)) gl t in 
+       Pnot t'
+    | Kapp("or",[t1;t2]) ->  
+	binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2
+    | Kapp("and",[t1;t2]) ->
+	binprop env ctxt negated negated gl
+	  (fun i x y -> Pand(i,x,y)) t1 t2
+    | Kimp(t1,t2) ->
+	binprop env ctxt (not negated) (not negated) gl 
+	  (fun i x y -> Pimp(i,x,y)) t1 t2
+    | _ -> Pprop c
+  with e when Logic.catchable_exception e -> Pprop c
+
+(* Destructuration des hypothèses et de la conclusion *)
+
+let reify_gl env gl =
+  let concl = Tacmach.pf_concl gl in
+  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"
+  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);
+	  pprint stdout t';
+	  Printf.printf "\n"
+	end;
+	(i,t') :: loop lhyps
+    | [] -> 
+	if !debug then print_env_reification env; 
+	[] in
+  let t_lhyps = loop (Tacmach.pf_hyps_types gl) in
+  (id_concl,t_concl) :: t_lhyps 
+
+let rec destructurate_pos_hyp orig list_equations list_depends = function
+  | Pequa (_,e) -> [e :: list_equations]
+  | Ptrue | Pfalse | Pprop _ -> [list_equations]
+  | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t
+  | Por (i,t1,t2) -> 
+      let s1 = 
+	destructurate_pos_hyp orig list_equations (i::list_depends) t1 in
+      let s2 = 
+	destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
+      s1 @ s2
+  | Pand(i,t1,t2) -> 
+      let list_s1 =
+	destructurate_pos_hyp orig list_equations (list_depends) t1 in
+      let rec loop = function 
+	  le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll
+	| [] -> [] in
+      loop list_s1
+  | Pimp(i,t1,t2) -> 
+      let s1 =
+	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
+      let s2 =
+	destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
+      s1 @ s2
+
+and destructurate_neg_hyp orig list_equations list_depends = function
+  | Pequa (_,e) -> [e :: list_equations]
+  | Ptrue | Pfalse | Pprop _ -> [list_equations]
+  | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t
+  | Pand (i,t1,t2) -> 
+      let s1 =
+	destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
+      let s2 =
+	destructurate_neg_hyp orig list_equations (i::list_depends) t2 in
+      s1 @ s2
+  | Por(_,t1,t2) -> 
+      let list_s1 =
+	destructurate_neg_hyp orig list_equations list_depends t1 in
+      let rec loop = function 
+	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
+	| [] -> [] in
+      loop list_s1
+  | Pimp(_,t1,t2) -> 
+      let list_s1 =
+	destructurate_pos_hyp orig list_equations list_depends t1 in
+      let rec loop = function 
+	  le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
+	| [] -> [] in
+      loop list_s1
+
+let destructurate_hyps syst =
+  let rec loop = function
+      (i,t) :: l -> 
+	let l_syst1 = destructurate_pos_hyp i []  [] t in
+	let l_syst2 = loop l in
+	cartesien l_syst1 l_syst2
+    | [] -> [[]] in
+  loop syst
+
+(* \subsection{Affichage d'un système d'équation} *)
+
+(* Affichage des dépendances de système *)
+let display_depend = function
+    Left i -> Printf.printf " L%d" i 
+  | Right i -> Printf.printf " R%d" i
+
+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
+
+  let display_equation oformula_eq = 
+    pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline ();
+    display_omega oformula_eq.e_omega;
+    Printf.printf "  Depends on:"; 
+    List.iter display_depend oformula_eq.e_depends;
+    Printf.printf "\n  Path: %s" 
+      (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"
+      (Names.string_of_id oformula_eq.e_origin.o_hyp)
+      (if oformula_eq.e_negated then "yes" else "false") in
+
+  let display_system syst =
+    Printf.printf "=SYSTEME==================================\n";
+    List.iter display_equation syst in
+  List.iter display_system syst_list
+
+(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
+   calcul des hypothèses *)
+
+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)) -> 
+	    hyps_used_in_trace act1 @ hyps_used_in_trace act2
+	| _ -> hyps_used_in_trace l
+      end
+  | [] -> []
+
+(* Extraction des variables déclarées dans une équation. Permet ensuite
+   de les déclarer dans l'environnement de la procédure réflexive et
+   éviter les créations de variable au vol *)
+
+let rec variable_stated_in_trace = function
+  | act :: l -> 
+      begin match act with
+	| Omega2.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)) -> 
+	    variable_stated_in_trace act1 @ variable_stated_in_trace act2
+	| _ -> variable_stated_in_trace l
+      end
+  | [] -> []
+;;
+
+let add_stated_equations env tree = 
+  let rec loop = function
+      Tree(_,t1,t2) -> 
+	list_union (loop t1) (loop t2)
+    | Leaf s -> variable_stated_in_trace s.s_trace in
+  (* 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
+  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
+    (* 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
+    let v = add_reified_atom coq_v env in
+    (* Le terme qu'il va falloir introduire *)
+    let term_to_generalize = app coq_refl_equal [|Lazy.force coq_Z; coq_v|] in
+    (* sa représentation sous forme d'équation mais non réifié car on n'a pas
+     * 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
+ List.map add_env stated_equations
+
+(* Calcule la liste des éclatements à réaliser sur les hypothèses 
+   nécessaires pour extraire une liste d'équations donnée *)
+
+let rec get_eclatement env = function
+    i :: r -> 
+      let l = try (get_equation env i).e_depends with Not_found -> [] in
+      list_union l (get_eclatement env r)
+  | [] -> []
+
+let select_smaller l = 
+  let comp (_,x) (_,y) = 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 =
+  let rec select = function
+      (x::l) -> 
+	if List.mem x required then select l
+	else if List.mem (barre x) required then raise Exit 
+	else x :: select l
+    | [] -> [] in
+  map_exc (function (sol,splits) -> (sol,select splits)) systems
+
+let rec equas_of_solution_tree = function
+    Tree(_,t1,t2) -> 
+      list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2)
+  | Leaf s -> s.s_equa_deps
+
+
+let really_useful_prop l_equa c =
+  let rec real_of = function
+      Pequa(t,_) -> t
+    | 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|]
+    (* Attention : implications sur le lifting des variables à comprendre ! *)
+    | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
+    | Pprop t -> t in
+  let rec loop c = 
+    match c with 
+      Pequa(_,e) ->
+	if List.mem e.e_omega.Omega2.id l_equa then Some c else None
+    | Ptrue -> None
+    | Pfalse -> None
+    | Pnot t1 -> 
+	begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end
+    | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2
+    | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2
+    | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2
+    | Pprop t -> None
+  and binop f t1 t2 = 
+    begin match loop t1, loop t2 with
+      None, None -> None 
+    | Some t1',Some t2' -> Some (f(t1',t2'))
+    | Some t1',None -> Some (f(t1',Pprop (real_of t2)))
+    | None,Some t2' -> Some (f(Pprop (real_of t1),t2'))
+    end in
+  match loop c with
+    None -> Pprop (real_of c)
+  | Some t -> t
+
+let rec display_solution_tree ch = function
+    Leaf t -> 
+      output_string ch 
+       (Printf.sprintf "%d[%s]" 
+	 t.s_index
+         (String.concat " " (List.map string_of_int t.s_equa_deps)))
+  | Tree(i,t1,t2) -> 
+      Printf.fprintf ch "S%d(%a,%a)" i 
+	display_solution_tree t1 display_solution_tree t2
+
+let rec solve_with_constraints all_solutions path = 
+  let rec build_tree sol buf = function
+      [] -> Leaf sol
+    | (Left i :: remainder) -> 
+	Tree(i,
+	     build_tree sol (Left i :: buf) remainder, 
+	     solve_with_constraints all_solutions (List.rev(Right i :: buf)))
+    | (Right i :: remainder) -> 
+	 Tree(i,
+	      solve_with_constraints all_solutions (List.rev (Left i ::  buf)),
+	      build_tree sol (Right i :: buf) remainder) in
+  let weighted = filter_compatible_systems path all_solutions in
+  let (winner_sol,winner_deps) =
+    try select_smaller weighted 
+    with e ->  
+      Printf.printf "%d - %d\n" 
+	(List.length weighted) (List.length all_solutions);
+      List.iter display_depend path; raise e in
+  build_tree winner_sol (List.rev path) winner_deps 
+
+let find_path {o_hyp=id;o_path=p} env = 
+  let rec loop_path = function
+      ([],l) -> Some l
+    | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
+    | _ -> None in
+  let rec loop_id i = function
+      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
+	end
+    | _ :: l -> loop_id (i+1) l
+    | [] -> failwith "find_path" in
+  loop_id 0 env
+
+let mk_direction_list l = 
+  let trans = function 
+      O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in
+  mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l)
+
+
+(* \section{Rejouer l'historique} *)
+
+let get_hyp env_hyp i =
+  try list_index (CCEqua i) env_hyp
+  with Not_found -> failwith (Printf.sprintf "get_hyp %d" 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
+	  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 ->
+	  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
+          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 ->
+	  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
+          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
+          mkApp (Lazy.force coq_s_merge_eq,
+		 [| mk_nat (List.length e1.Omega2.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
+          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 -> 
+          mkApp (Lazy.force coq_s_constant_not_nul,
+		 [|  mk_nat (get_hyp env_hyp e) |])
+      | Omega2.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
+	  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
+	  let body =
+	     Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in
+          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 ->
+	  mkApp (Lazy.force coq_s_constant_nul, 
+		 [|  mk_nat (get_hyp env_hyp e) |])
+      |	Omega2.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
+	  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 ->
+	  loop env_hyp l
+      | (Omega2.WEAKEN  _ ) :: l -> failwith "not_treated"
+      |	[] -> failwith "no contradiction"
+  in loop env_hyp
+
+let rec decompose_tree env ctxt = function
+   Tree(i,left,right) ->
+     let org = 
+       try Hashtbl.find env.constructors i 
+       with Not_found ->
+	 failwith (Printf.sprintf "Cannot find constructor %d" i) in
+     let (index,path) = find_path org ctxt in
+     let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in
+     let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in
+     app coq_e_split 
+       [| mk_nat index;
+	  mk_direction_list path;
+	  decompose_tree env (left_hyp::ctxt) left;
+	  decompose_tree env (right_hyp::ctxt) right |]
+  | Leaf s ->
+      decompose_tree_hyps s.s_trace env ctxt  s.s_equa_deps
+and decompose_tree_hyps trace env ctxt = function
+    [] -> app coq_e_solve [| replay_history env ctxt trace |]
+  | (i::l) -> 
+      let equation =
+        try Hashtbl.find env.equations i 
+        with Not_found ->
+	  failwith (Printf.sprintf "Cannot find equation %d" i) in
+      let (index,path) = find_path equation.e_origin ctxt in
+      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
+      app coq_e_extract [|mk_nat index;
+			  mk_direction_list full_path;
+			  cont |]
+
+(* \section{La fonction principale} *)
+ (* Cette fonction construit la
+trace pour la procédure de décision réflexive.  A partir des résultats
+de l'extraction des systèmes, elle lance la résolution par Omega, puis
+l'extraction d'un ensemble minimal de solutions permettant la
+résolution globale du système et enfin construit la trace qui permet
+de faire rejouer cette solution par la tactique réflexive. *)
+
+let resolution env full_reified_goal systems_list =
+  let num = ref 0 in
+  let solve_system list_eq = 
+    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) 
+	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;
+      print_string "\n  Depend :";
+      List.iter (fun i -> Printf.printf " %d" i) vars;
+      print_string "\n  Split points :";
+      List.iter display_depend splits;
+      Printf.printf "\n------------------------------------\n"
+    end;
+    incr num;
+    {s_index = index; s_trace = trace; s_equa_deps = vars}, splits  in
+  if !debug then Printf.printf "\n====================================\n";
+  let all_solutions = List.map solve_system systems_list in
+  let solution_tree = solve_with_constraints all_solutions [] in
+  if !debug then  begin
+    display_solution_tree stdout solution_tree;
+    print_newline()
+  end;
+  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
+  let useful_equa_id = list_uniq (equas_of_solution_tree solution_tree) in
+  (* recupere explicitement ces equations *)
+  let equations = List.map (get_equation env) useful_equa_id in
+  let l_hyps' = list_uniq (List.map (fun e -> e.e_origin.o_hyp) equations) in
+  let l_hyps = id_concl :: list_remove id_concl l_hyps' in
+  let useful_hyps =
+    List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
+  let useful_vars = vars_of_equations equations in
+  (* variables a introduire *)
+  let to_introduce = add_stated_equations env solution_tree in
+  let stated_vars =  List.map (fun (v,_,_,_) -> v) to_introduce in
+  let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in
+  let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in
+  (* L'environnement de base se construit en deux morceaux :
+     - les variables des équations utiles
+     - les nouvelles variables declarées durant les preuves *)
+  let all_vars_env = useful_vars @ stated_vars in
+  let basic_env =
+    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
+      |	[] -> [] in
+    loop 0 all_vars_env in
+  let env_terms_reified = mk_list (Lazy.force coq_Z) basic_env in
+  (* On peut maintenant généraliser le but : env est a jour *)
+  let l_reified_stated =
+     List.map (fun (_,_,(l,r),_) -> 
+                 app coq_p_eq [| reified_of_formula env l; 
+                                 reified_of_formula env r |])
+              to_introduce in
+  let reified_concl = 
+    match useful_hyps with
+      (Pnot p) :: _ ->
+	reified_of_proposition env (really_useful_prop useful_equa_id p)
+    | _ ->  reified_of_proposition env Pfalse in
+  let l_reified_terms =
+    (List.map
+      (fun p ->
+         reified_of_proposition env (really_useful_prop useful_equa_id p))
+      (List.tl useful_hyps)) in
+  let env_props_reified = mk_plist env.props in
+  let reified_goal = 
+    mk_list (Lazy.force coq_proposition)
+            (l_reified_stated @ l_reified_terms) in
+  let reified = 
+    app coq_interp_sequent 
+       [| env_props_reified;env_terms_reified;reified_concl;reified_goal |] in
+  let normalize_equation e = 
+    let rec loop = function
+	[] -> app (if e.e_negated then coq_p_invert else coq_p_step)
+	          [| e.e_trace |]
+      |	((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
+      |	(O_right :: l) -> app coq_p_right [| loop l |] in
+    app coq_pair_step 
+        [| mk_nat (list_index e.e_origin.o_hyp l_hyps) ;
+	   loop e.e_origin.o_path |] in
+  let normalization_trace =
+    mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in
+
+  let initial_context =
+    List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in
+  let context = 
+    CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
+  let decompose_tactic = decompose_tree env context solution_tree in
+
+  Tactics.generalize 
+    (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
+  Tactics.change_in_concl None reified >> 
+  Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
+  show_goal >>
+  Tactics.normalise_in_concl >>
+  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";
+  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;
+  resolution env full_reified_goal systems_list gl
+  with Omega2.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/xml/COPYRIGHT b/contrib/xml/COPYRIGHT
new file mode 100644
index 00000000..c8d231fd
--- /dev/null
+++ b/contrib/xml/COPYRIGHT
@@ -0,0 +1,25 @@
+(******************************************************************************)
+(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
+(*                          Project Helm   (http://helm.cs.unibo.it)          *)
+(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
+(*                                                                            *)
+(*                     Coq Exportation to XML                                 *)
+(*                                                                            *)
+(******************************************************************************)
+
+This Coq module has been developed by Claudio Sacerdoti Coen
+<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI.
+
+Project HELM (for Hypertextual Electronic Library of Mathematics) is a
+project developed at the Department of Computer Science, University of Bologna;
+http://helm.cs.unibo.it
+
+Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces)
+is a UE IST project that generalizes and extends the HELM project;
+http://mowgli.cs.unibo.it
+
+The author is interested in any possible usage of the module.
+So, if you plan to use the module, please send him an e-mail.
+
+The licensing policy applied to the module is the same as for the whole Coq
+distribution.
diff --git a/contrib/xml/README b/contrib/xml/README
new file mode 100644
index 00000000..a45dd31a
--- /dev/null
+++ b/contrib/xml/README
@@ -0,0 +1,254 @@
+(******************************************************************************)
+(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
+(*                          Project Helm   (http://helm.cs.unibo.it)          *)
+(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
+(*                                                                            *)
+(*                     Coq Exportation to XML                                 *)
+(*                                                                            *)
+(******************************************************************************)
+
+This module provides commands to export a piece of Coq library in XML format.
+Only the information relevant to proof-checking and proof-rendering is exported,
+i.e. only the CIC proof objects (lambda-terms).
+
+This document is tructured in the following way:
+ 1. User documentation
+   1.1. New vernacular commands available
+   1.2. New coqc/coqtop flags and suggested usage
+   1.3. How to exploit the XML files
+ 2. Technical informations
+   2.1. Inner-types
+   2.2. CIC with Explicit Named Substitutions
+   2.3. The CIC with Explicit Named Substitutions XML DTD
+
+================================================================================
+                            USER DOCUMENTATION
+================================================================================
+
+=======================================
+1.1. New vernacular commands available:
+=======================================
+
+The new commands are:
+
+ Print XML qualid.                 It prints in XML (to standard output) the
+                                   object whose qualified name is qualid and
+                                   its inner-types (see Sect. 2.1).
+                                   The inner-types are always printed
+                                   in their own XML file. If the object is a
+                                   constant, its type and body are also printed
+                                   as two distinct XML files.
+                                   The object printed is always the most
+                                   discharged form of the object (see
+                                   the Section command of the Coq manual).
+
+ Print XML File "filename" qualid. Similar to "Print XML qualid". The generated
+                                   files are stored on the hard-disk using the
+                                   base file name "filename".
+
+ Show XML Proof.                   It prints in XML the current proof in
+                                   progress. Its inner-types are also printed.
+
+ Show XML File "filename" Proof.   Similar to "Show XML Proof". The generated
+                                   files are stored on the hard-disk using
+                                   the base file name "filename".
+
+ The verbosity of the previous commands is raised if the configuration
+ parameter verbose of xmlcommand.ml is set to true at compile time.
+
+==============================================
+1.2. New coqc/coqtop flags and suggested usage
+==============================================
+
+ The following flag has been added to coqc and coqtop:
+
+  -xml     export XML files either to the hierarchy rooted in
+           the directory $COQ_XML_LIBRARY_ROOT (if the environment
+           variable is set) or to stdout (if unset)
+
+ If the flag is set, every definition or declaration is immediately
+ exported to XML. The XML files describe the user-provided non-discharged
+ form of the definition or declaration. 
+
+
+ The coq_makefile utility has also been modified to easily allow XML
+ exportation:
+
+   make COQ_XML=-xml   (or, equivalently, setting the environment
+                        variable COQ_XML)
+
+
+ The suggested usage of the module is the following:
+
+   1. add to your own contribution a valid Make file and use coq_makefile
+      to generate the Makefile from the Make file.
+      *WARNING:* Since logical names are used to structure the XML hierarchy,
+      always add to the Make file at least one "-R" option to map physical
+      file names to logical module paths. See the Coq manual for further
+      informations on the -R flag.
+   2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy
+      must be physically rooted.
+   3. compile your contribution with "make COQ_XML=-xml"
+
+
+=================================
+1.3. How to exploit the XML files
+=================================
+
+ Once the information is exported to XML, it becomes possible to implement
+ services that are completely Coq-independent. Projects HELM and MoWGLI
+ already provide rendering, searching and data mining functionalities.
+
+ In particular, the standard library and contributions of Coq can be
+ browsed and searched on the HELM web site:
+
+                  http://helm.cs.unibo.it/library.html
+
+
+ If you want to publish your own contribution so that it is included in the
+ HELM library, use the MoWGLI prototype upload form:
+
+                  http://mowgli.cs.unibo.it
+
+
+================================================================================
+                            TECHNICAL INFORMATIONS
+================================================================================
+
+==========================
+2.1. Inner-types
+==========================
+
+In order to do proof-rendering (for example in natural language),
+some redundant typing information is required, i.e. the type of
+at least some of the subterms of the bodies and types. So, each
+new command described in section 1.1 print not only
+the object, but also another XML file in which you can find
+the type of all the subterms of the terms of the printed object
+which respect the following conditions:
+
+ 1. It's sort is Prop or CProp (the "sort"-like definition used in
+    CoRN to type computationally relevant predicative propositions).
+ 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL,
+    VAR, MUTCONSTR or CONST.
+ 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA,
+    i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is
+    printed.
+
+The rationale for the 3rd condition is that the type of the inner LAMBDAs
+could be easily computed starting from the type of the outer LAMBDA; moreover,
+the types of the inner LAMBDAs requires a lot of disk/memory space: removing
+the 3rd condition leads to XML file that are two times as big as the ones
+exported appling the 3rd condition.
+
+==========================================
+2.2. CIC with Explicit Named Substitutions
+==========================================
+
+The exported files are and XML encoding of the lambda-terms used by the
+Coq system. The implementative details of the Coq system are hidden as much
+as possible, so that the XML DTD is a straightforward encoding of the  
+Calculus of (Co)Inductive Constructions.
+
+Nevertheless, there is a feature of the Coq system that can not be
+hidden in a completely satisfactory way: discharging. In Coq it is possible
+to open a section, declare variables and use them in the rest of the section
+as if they were axiom declarations. Once the section is closed, every definition
+and theorem in the section is discharged by abstracting it over the section
+variables. Variable declarations as well as section declarations are entirely
+dropped. Since we are interested in an XML encoding of definitions and
+theorems as close as possible to those directly provided the user, we
+do not want to export discharged forms. Exporting non-discharged theorem
+and definitions together with theorems that rely on the discharged forms
+obliges the tools that work on the XML encoding to implement discharging to
+achieve logical consistency. Moreover, the rendering of the files can be
+misleading, since hyperlinks can be shown between occurrences of the discharge
+form of a definition and the non-discharged definition, that are different
+objects.
+
+To overcome the previous limitations, Claudio Sacerdoti Coen developed in his
+PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions
+with Explicit Named Substitutions, that is a slight extension of CIC where
+discharging is not necessary. The DTD of the exported XML files describes
+constants, inductive types and variables of the Calculus of (Co)Inductive
+Constructions with Explicit Named Substitions. The conversion to the new
+calculus is performed during the exportation phase.
+
+The following example shows a very small Coq development together with its
+version in CIC with Explicit Named Substitutions.
+
+# CIC version: #
+Section S.
+ Variable A : Prop.
+
+ Definition impl := A -> A.
+
+ Theorem t : impl.           (* uses the undischarged form of impl *)
+  Proof.
+   exact (fun (a:A) => a).
+  Qed.
+
+End S.
+
+Theorem t' : (impl False).   (* uses the discharged form of impl *) 
+ Proof.
+  exact (t False).           (* uses the discharged form of t *)
+ Qed.
+
+# Corresponding CIC with Explicit Named Substitutions version: #
+Section S.
+ Variable A : Prop.
+
+ Definition impl(A) := A -> A.   (* theorems and definitions are
+                                    explicitly abstracted over the
+                                    variables. The name is sufficient
+                                    to completely describe the abstraction *)
+
+ Theorem t(A) : impl.            (* impl where A is not instantiated *)
+  Proof.
+   exact (fun (a:A) => a).
+  Qed.
+
+End S.
+
+Theorem t'() : impl{False/A}.    (* impl where A is instantiated with False
+                                    Notice that t' does not depend on A     *) 
+ Proof.
+  exact t{False/A}.              (* t where A is instantiated with False *)
+ Qed.
+
+Further details on the typing and reduction rules of the calculus can be
+found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency
+of the calculus is also proved.
+
+======================================================
+2.3. The CIC with Explicit Named Substitutions XML DTD
+======================================================
+
+A copy of the DTD can be found in the file "cic.dtd".
+
+<ConstantType>     is the root element of the files that correspond to
+                   constant types.
+<ConstantBody>     is the root element of the files that correspond to
+                   constant bodies. It is used only for closed definitions and
+                   theorems (i.e. when no metavariable occurs in the body
+                   or type of the constant)
+<CurrentProof>     is the root element of the file that correspond to
+                   the body of a constant that depends on metavariables
+                   (e.g. unfinished proofs)
+<Variable>         is the root element of the files that correspond to variables
+<InductiveTypes>   is the root element of the files that correspond to blocks
+                   of mutually defined inductive definitions
+
+The elements
+ <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>,
+ <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX>
+are used to encode the constructors of CIC. The sort or type attribute of the
+element, if present, is respectively the sort or the type of the term, that
+is a sort because of the typing rules of CIC.
+
+The element <instantiate> correspond to the application of an explicit named
+substitution to its first argument, that is a reference to a definition
+or declaration in the environment.
+
+All the other elements are just syntactic sugar.
diff --git a/contrib/xml/acic.ml b/contrib/xml/acic.ml
new file mode 100644
index 00000000..032ddbeb
--- /dev/null
+++ b/contrib/xml/acic.ml
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+open Names
+open Term
+
+(* Maps fron \em{unshared} [constr] to ['a]. *)
+module CicHash =
+ Hashtbl.Make
+  (struct
+    type t = Term.constr
+    let equal = (==)
+    let hash = Hashtbl.hash
+   end)
+;;
+
+type id = string  (* the type of the (annotated) node identifiers *)
+type uri = string
+
+type 'constr context_entry =
+   Decl of 'constr             (* Declaration *)
+ | Def  of 'constr * 'constr   (* Definition; the second argument (the type) *)
+                               (* is not present in the DTD, but is needed   *)
+                               (* to use Coq functions during exportation.   *)
+
+type 'constr hypothesis = identifier * 'constr context_entry
+type context = constr hypothesis list
+
+type conjecture = existential_key * context * constr
+type metasenv = conjecture list
+
+(* list of couples section path -- variables defined in that section *)
+type params = (string * uri list) list
+
+type obj =
+   Constant of string *                            (* id,           *)
+    constr option * constr *                       (*  value, type, *)
+    params                                         (*  parameters   *)
+ | Variable of
+    string * constr option * constr *              (* name, body, type *)
+    params                                         (*  parameters   *)
+ | CurrentProof of
+    string * metasenv *                            (*  name, conjectures, *)
+    constr * constr                                (*  value, type        *)
+ | InductiveDefinition of
+    inductiveType list *                           (* inductive types ,      *)
+    params * int                                   (*  parameters,n ind. pars*)
+and inductiveType = 
+ identifier * bool * constr *                 (* typename, inductive, arity *)
+  constructor list                            (*  constructors              *)
+and constructor =
+ identifier * constr                          (* id, type *)
+
+type aconstr =
+  | ARel       of id * int * id * identifier
+  | AVar       of id * uri
+  | AEvar      of id * existential_key * aconstr list
+  | ASort      of id * sorts
+  | ACast      of id * aconstr * aconstr
+  | AProds     of (id * name * aconstr) list * aconstr
+  | ALambdas   of (id * name * aconstr) list * aconstr
+  | ALetIns    of (id * name * aconstr) list * aconstr
+  | AApp       of id * aconstr list
+  | AConst     of id * explicit_named_substitution * uri
+  | AInd       of id * explicit_named_substitution * uri * int
+  | AConstruct of id * explicit_named_substitution * uri * int * int
+  | ACase      of id * uri * int * aconstr * aconstr * aconstr list
+  | AFix       of id * int * ainductivefun list
+  | ACoFix     of id * int * acoinductivefun list
+and ainductivefun = 
+ id * identifier * int * aconstr * aconstr
+and acoinductivefun = 
+ id * identifier * aconstr * aconstr
+and explicit_named_substitution = id option * (uri * aconstr) list
+
+type acontext = (id * aconstr hypothesis) list
+type aconjecture = id * existential_key * acontext * aconstr
+type ametasenv = aconjecture list
+
+type aobj =
+   AConstant of id * string *                      (* id,           *)
+    aconstr option * aconstr *                     (*  value, type, *)
+    params                                         (*  parameters   *)
+ | AVariable of id *
+    string * aconstr option * aconstr *            (* name, body, type *)
+    params                                         (*  parameters   *)
+ | ACurrentProof of id *
+    string * ametasenv *                           (*  name, conjectures, *)
+    aconstr * aconstr                              (*  value, type        *)
+ | AInductiveDefinition of id *
+    anninductiveType list *                        (* inductive types ,      *)
+    params * int                                   (*  parameters,n ind. pars*)
+and anninductiveType = 
+ id * identifier * bool * aconstr *           (* typename, inductive, arity *)
+  annconstructor list                         (*  constructors              *)
+and annconstructor =
+ identifier * aconstr                         (* id, type *)
diff --git a/contrib/xml/acic2Xml.ml4 b/contrib/xml/acic2Xml.ml4
new file mode 100644
index 00000000..64dc8a05
--- /dev/null
+++ b/contrib/xml/acic2Xml.ml4
@@ -0,0 +1,363 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(*CSC codice cut & paste da cicPp e xmlcommand *)
+
+exception ImpossiblePossible;;
+exception NotImplemented;;
+let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";;
+let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";;
+
+let rec find_last_id =
+ function
+    [] -> Util.anomaly "find_last_id: empty list"
+  | [id,_,_] -> id
+  | _::tl -> find_last_id tl
+;;
+
+let export_existential = string_of_int
+
+let print_term ids_to_inner_sorts =
+ let rec aux =
+  let module A = Acic in
+  let module N = Names in
+  let module X = Xml in
+    function
+       A.ARel (id,n,idref,b) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_empty "REL"
+          ["value",(string_of_int n) ; "binder",(N.string_of_id b) ;
+           "id",id ; "idref",idref; "sort",sort]
+     | A.AVar (id,uri) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
+     | A.AEvar (id,n,l) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "META" 
+	   ["no",(export_existential n) ; "id",id ; "sort",sort]
+          (List.fold_left
+            (fun i t ->
+              [< i ; X.xml_nempty "substitution" [] (aux t) >]
+            ) [< >] (List.rev l))
+     | A.ASort (id,s) ->
+        let string_of_sort =
+         match Term.family_of_sort s with
+            Term.InProp -> "Prop"
+          | Term.InSet  -> "Set"
+          | Term.InType -> "Type"
+        in
+         X.xml_empty "SORT" ["value",string_of_sort ; "id",id]
+     | A.AProds (prods,t) ->
+        let last_id = find_last_id prods in
+        let sort = Hashtbl.find ids_to_inner_sorts last_id in
+         X.xml_nempty "PROD" ["type",sort]
+          [< List.fold_left
+              (fun i (id,binder,s) ->
+                let sort =
+                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+                in
+                 let attrs =
+                  ("id",id)::("type",sort)::
+                  match binder with
+                     Names.Anonymous -> []
+                   | Names.Name b -> ["binder",Names.string_of_id b]
+                 in
+                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
+              ) [< >] prods ;
+             X.xml_nempty "target" [] (aux t)
+          >]
+     | A.ACast (id,v,t) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "CAST" ["id",id ; "sort",sort]
+          [< X.xml_nempty "term" [] (aux v) ;
+             X.xml_nempty "type" [] (aux t)
+          >]
+     | A.ALambdas (lambdas,t) ->
+        let last_id = find_last_id lambdas in
+        let sort = Hashtbl.find ids_to_inner_sorts last_id in
+         X.xml_nempty "LAMBDA" ["sort",sort]
+          [< List.fold_left
+              (fun i (id,binder,s) ->
+                let sort =
+                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+                in
+                 let attrs =
+                  ("id",id)::("type",sort)::
+                  match binder with
+                     Names.Anonymous -> []
+                   | Names.Name b -> ["binder",Names.string_of_id b]
+                 in
+                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
+              ) [< >] lambdas ;
+             X.xml_nempty "target" [] (aux t)
+          >]
+     | A.ALetIns (letins,t) ->
+        let last_id = find_last_id letins in
+        let sort = Hashtbl.find ids_to_inner_sorts last_id in
+         X.xml_nempty "LETIN" ["sort",sort]
+          [< List.fold_left
+              (fun i (id,binder,s) ->
+                let sort =
+                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+                in
+                 let attrs =
+                  ("id",id)::("sort",sort)::
+                  match binder with
+                     Names.Anonymous -> assert false
+                   | Names.Name b -> ["binder",Names.string_of_id b]
+                 in
+                  [< X.xml_nempty "def" attrs (aux s) ; i >]
+              ) [< >] letins ;
+             X.xml_nempty "target" [] (aux t)
+          >]
+     | A.AApp (id,li) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "APPLY" ["id",id ; "sort",sort]
+          [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li)
+          >]
+     | A.AConst (id,subst,uri) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+        let attrs = ["uri", uri ; "id",id ; "sort",sort] in
+         aux_subst (X.xml_empty "CONST" attrs) subst
+     | A.AInd (id,subst,uri,i) ->
+        let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in
+         aux_subst (X.xml_empty "MUTIND" attrs) subst
+     | A.AConstruct (id,subst,uri,i,j) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+        let attrs =
+         ["uri", uri ;
+          "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
+          "id",id ; "sort",sort]
+        in
+         aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst
+     | A.ACase (id,uri,typeno,ty,te,patterns) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "MUTCASE"
+          ["uriType", uri ;
+           "noType", (string_of_int typeno) ;
+           "id", id ; "sort",sort]
+          [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
+             X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
+             List.fold_left
+              (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >])
+              [<>] patterns
+          >]
+     | A.AFix (id, no, funs) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "FIX"
+          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
+          [< List.fold_left
+              (fun i (id,fi,ai,ti,bi) ->
+                [< i ;
+                   X.xml_nempty "FixFunction"
+                    ["id",id ; "name", (Names.string_of_id fi) ;
+                     "recIndex", (string_of_int ai)]
+                    [< X.xml_nempty "type" [] [< aux ti >] ;
+                       X.xml_nempty "body" [] [< aux bi >]
+                    >]
+                >]
+              ) [<>] funs
+          >]
+     | A.ACoFix (id,no,funs) ->
+        let sort = Hashtbl.find ids_to_inner_sorts id in
+         X.xml_nempty "COFIX"
+          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
+          [< List.fold_left
+              (fun i (id,fi,ti,bi) ->
+                [< i ;
+                   X.xml_nempty "CofixFunction"
+                    ["id",id ; "name", Names.string_of_id fi]
+                    [< X.xml_nempty "type" [] [< aux ti >] ;
+                       X.xml_nempty "body" [] [< aux bi >]
+                    >]
+                >]
+              ) [<>] funs
+          >]
+ and aux_subst target (id,subst) =
+  if subst = [] then
+   target
+  else
+   Xml.xml_nempty "instantiate"
+    (match id with None -> [] | Some id -> ["id",id])
+    [< target ;
+       List.fold_left
+        (fun i (uri,arg) ->
+          [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >]
+        ) [<>] subst
+    >]
+ in
+  aux
+;;
+
+let param_attribute_of_params params =
+ List.fold_right
+  (fun (path,l) i ->
+    List.fold_right
+     (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i'
+     ) l "" ^ match i with "" -> "" | i' -> " " ^ i'
+  ) params ""
+;;
+
+let print_object uri ids_to_inner_sorts =
+ let rec aux =
+  let module A = Acic in
+  let module X = Xml in
+    function
+       A.ACurrentProof (id,n,conjectures,bo,ty) ->
+        let xml_for_current_proof_body =
+(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
+(*CSC: I think so. Not implemented yet.                                       *)
+         X.xml_nempty "CurrentProof" ["of",uri ; "id", id]
+          [< List.fold_left
+              (fun i (cid,n,canonical_context,t) ->
+                [< i ;
+                   X.xml_nempty "Conjecture"
+                    ["id", cid ; "no",export_existential n]
+                    [< List.fold_left
+                        (fun i (hid,t) ->
+                          [< (match t with
+                                n,A.Decl t ->
+                                 X.xml_nempty "Decl"
+                                  ["id",hid;"name",Names.string_of_id n]
+                                  (print_term ids_to_inner_sorts t)
+                              | n,A.Def (t,_) ->
+                                 X.xml_nempty "Def"
+                                  ["id",hid;"name",Names.string_of_id n]
+                                  (print_term ids_to_inner_sorts t)
+                             ) ;
+                             i
+                          >]
+                        ) [< >] canonical_context ;
+                       X.xml_nempty "Goal" []
+                        (print_term ids_to_inner_sorts t)
+                    >]
+                >])
+              [<>] (List.rev conjectures) ;
+             X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
+        in
+        let xml_for_current_proof_type =
+         X.xml_nempty "ConstantType" ["name",n ; "id", id]
+          (print_term ids_to_inner_sorts ty)
+        in
+        let xmlbo =
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n");
+            xml_for_current_proof_body
+         >] in
+        let xmlty =
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata
+             ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n");
+            xml_for_current_proof_type
+         >]
+        in
+         xmlty, Some xmlbo
+     | A.AConstant (id,n,bo,ty,params) ->
+        let params' = param_attribute_of_params params in
+        let xmlbo =
+         match bo with
+            None -> None
+          | Some bo ->
+             Some
+              [< X.xml_cdata
+                  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+                 X.xml_cdata
+                  ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
+                 X.xml_nempty "ConstantBody"
+                  ["for",uri ; "params",params' ; "id", id]
+                  [< print_term ids_to_inner_sorts bo >]
+              >]
+        in
+        let xmlty =
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n");
+             X.xml_nempty "ConstantType"
+              ["name",n ; "params",params' ; "id", id]
+              [< print_term ids_to_inner_sorts ty >]
+         >]
+        in
+         xmlty, xmlbo
+     | A.AVariable (id,n,bo,ty,params) ->
+        let params' = param_attribute_of_params params in
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ;
+            X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id]
+             [< (match bo with
+                    None -> [<>]
+                  | Some bo ->
+                     X.xml_nempty "body" []
+                      (print_term ids_to_inner_sorts bo)
+                ) ;
+                X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
+             >]
+         >], None
+     | A.AInductiveDefinition (id,tys,params,nparams) ->
+        let params' = param_attribute_of_params params in
+         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+            X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
+             dtdname ^ "\">\n") ;
+            X.xml_nempty "InductiveDefinition"
+             ["noParams",string_of_int nparams ;
+              "id",id ;
+              "params",params']
+             [< (List.fold_left
+                  (fun i (id,typename,finite,arity,cons) ->
+                    [< i ;
+                       X.xml_nempty "InductiveType"
+                        ["id",id ; "name",Names.string_of_id typename ;
+                         "inductive",(string_of_bool finite)
+                        ]
+                        [< X.xml_nempty "arity" []
+                            (print_term ids_to_inner_sorts arity) ;
+                           (List.fold_left
+                            (fun i (name,lc) ->
+                              [< i ;
+                                 X.xml_nempty "Constructor"
+                                  ["name",Names.string_of_id name]
+                                  (print_term ids_to_inner_sorts lc)
+                              >]) [<>] cons
+                           )
+                        >]
+                    >]
+                  ) [< >] tys
+                )
+             >]
+         >], None
+ in
+  aux
+;;
+
+let print_inner_types curi ids_to_inner_sorts ids_to_inner_types =
+ let module C2A = Cic2acic in
+ let module X = Xml in
+  [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+     X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n");
+      X.xml_nempty "InnerTypes" ["of",curi]
+       (Hashtbl.fold
+         (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
+           [< x ;
+              X.xml_nempty "TYPE" ["of",id]
+               [< X.xml_nempty "synthesized" []
+                   (print_term ids_to_inner_sorts synty) ;
+                  match expty with
+                     None -> [<>]
+                   | Some expty' ->
+                      X.xml_nempty "expected" []
+                       (print_term ids_to_inner_sorts expty')
+               >]
+           >]
+         ) ids_to_inner_types [<>]
+       )
+  >]
+;;
diff --git a/contrib/xml/cic.dtd b/contrib/xml/cic.dtd
new file mode 100644
index 00000000..c8035cab
--- /dev/null
+++ b/contrib/xml/cic.dtd
@@ -0,0 +1,259 @@
+<?xml encoding="ISO-8859-1"?>
+
+<!-- Copyright (C) 2000-2004, HELM Team                                -->
+<!--                                                                   -->
+<!-- This file is part of HELM, an Hypertextual, Electronic            -->
+<!-- Library of Mathematics, developed at the Computer Science         -->
+<!-- Department, University of Bologna, Italy.                         -->
+<!--                                                                   -->
+<!-- HELM 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 (at your option) any later version.            -->
+<!--                                                                   -->
+<!-- HELM 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 HELM; if not, write to the Free Software               -->
+<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
+<!-- MA  02111-1307, USA.                                              -->
+<!--                                                                   -->
+<!-- For details, see the HELM World-Wide-Web page,                    -->
+<!-- http://cs.unibo.it/helm/.                                         -->
+
+<!-- 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|CProp)'>
+
+<!-- CIC sequents -->
+
+<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
+
+<!-- CIC objects: -->
+
+<!ELEMENT ConstantType %term;>
+<!ATTLIST ConstantType
+          name       CDATA      #REQUIRED
+          params     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
+          params 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
+          id        ID           #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
+          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
+          uri  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
+          id       ID      #REQUIRED
+          recIndex NMTOKEN #REQUIRED>
+
+<!ELEMENT CofixFunction (type,body)>
+<!ATTLIST CofixFunction
+          id       ID      #REQUIRED
+          name     CDATA   #REQUIRED>
+
+<!ELEMENT substitution ((%term;)?)>
+
+<!-- Explicit named substitutions: -->
+
+<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),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/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
new file mode 100644
index 00000000..d820f9e5
--- /dev/null
+++ b/contrib/xml/cic2acic.ml
@@ -0,0 +1,946 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(* Utility Functions *)
+
+exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
+let get_module_path_of_section_path path =
+ let dirpath = fst (Libnames.repr_path path) in
+ let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
+  match
+   List.filter
+    (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
+  with
+     [modul] -> modul
+   | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
+;;
+
+(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *)
+(*CSC: not exist two modules whose dir_paths are one a prefix of the other *)
+let remove_module_dirpath_from_dirpath ~basedir dir =
+ let module Ln = Libnames in
+  if Ln.is_dirpath_prefix_of basedir dir then
+   let ids = Names.repr_dirpath dir in
+   let rec remove_firsts n l =
+    match n,l with
+       (0,l) -> l
+     | (n,he::tl) -> remove_firsts (n-1) tl
+     | _ -> assert false
+   in
+    let ids' =
+     List.rev
+      (remove_firsts
+        (List.length (Names.repr_dirpath basedir))
+        (List.rev ids))
+    in
+     ids'
+  else Names.repr_dirpath dir
+;;
+
+
+let get_uri_of_var v pvars =
+ let module D = Declare in
+ let module N = Names in
+  let rec search_in_pvars names =
+   function
+      [] -> None
+    | ((name,l)::tl) ->
+       let names' = name::names in
+        if List.mem v l then
+         Some names'
+        else
+         search_in_pvars names' tl
+  in
+  let rec search_in_open_sections =
+   function
+      [] -> Util.error "Variable 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
+         modules
+        else
+         search_in_open_sections tl
+  in
+   let path =
+    match search_in_pvars [] pvars with
+       None -> search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
+     | Some path -> path
+   in
+    "cic:" ^
+     List.fold_left
+      (fun i x -> "/" ^ N.string_of_id x ^ i) "" path
+;;
+
+type tag =
+   Constant
+ | Inductive
+ | Variable
+;;
+
+let ext_of_tag =
+ function
+    Constant  -> "con"
+  | Inductive -> "ind"
+  | Variable  -> "var"
+;;
+
+exception FunctorsXMLExportationNotImplementedYet;;
+
+let subtract l1 l2 =
+ let l1' = List.rev (Names.repr_dirpath l1) in
+ let l2' = List.rev (Names.repr_dirpath l2) in
+  let rec aux =
+   function
+      he::tl when tl = l2' -> [he]
+    | he::tl -> he::(aux tl)
+    | [] -> assert (l2' = []) ; []
+  in
+   Names.make_dirpath (List.rev (aux l1'))
+;;
+
+(*CSC: Dead code to be removed
+let token_list_of_kernel_name ~keep_sections kn tag =
+ let module N = Names in
+  let (modpath,dirpath,label) = Names.repr_kn kn in
+  let token_list_of_dirpath dirpath =
+   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
+  let rec token_list_of_modpath =
+   function
+      N.MPdot (path,label) ->
+       token_list_of_modpath path @ [N.string_of_label label]
+    | N.MPfile dirpath -> token_list_of_dirpath dirpath
+    | N.MPself self ->
+       if self = Names.initial_msid then
+        [ "Top" ]
+       else
+        let module_path =
+          let f = N.string_of_id (N.id_of_msid self) in
+          let _,longf = 
+            System.find_file_in_path (Library.get_load_path ()) (f^".v") in
+          let ldir0 = Library.find_logical_path (Filename.dirname longf) in
+          let id = Names.id_of_string (Filename.basename f) in
+           Libnames.extend_dirpath ldir0 id
+        in
+          token_list_of_dirpath module_path
+    | N.MPbound _ -> raise FunctorsXMLExportationNotImplementedYet
+  in
+   token_list_of_modpath modpath @
+    (if keep_sections then token_list_of_dirpath dirpath else []) @
+    [N.string_of_label label ^ "." ^ (ext_of_tag tag)]
+;;
+*)
+
+let token_list_of_path dir id tag =
+ let module N = Names in
+  let token_list_of_dirpath dirpath =
+   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 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))
+ in
+ let id = N.id_of_label (N.label kn) in
+ token_list_of_path dir id tag
+;;
+
+let uri_of_kernel_name kn tag =
+  let tokens = token_list_of_kernel_name kn tag in
+   "cic:/" ^ String.concat "/" tokens
+
+let uri_of_declaration id tag =
+ let module LN = Libnames in
+ let dir = LN.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) in
+ let tokens = token_list_of_path dir id tag in
+  "cic:/" ^ String.concat "/" tokens
+
+(* Special functions for handling of CCorn's CProp "sort" *)
+
+type sort =
+   Coq_sort of Term.sorts_family
+ | CProp
+;;
+
+let prerr_endline _ = ();;
+
+let family_of_term ty =
+ match Term.kind_of_term ty with
+    Term.Sort s -> Coq_sort (Term.family_of_sort s)
+  | Term.Const _ -> CProp  (* I could check that the constant is CProp *)
+  | _ -> Util.anomaly "family_of_term"
+;;
+
+module CPropRetyping =
+ struct
+  module T = Term
+
+  let outsort env sigma t =
+   family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t)
+
+  let rec subst_type env sigma typ = function
+  | [] -> typ
+  | h::rest ->
+      match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with
+        | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
+        | _ -> Util.anomaly "Non-functional construction"
+
+                                                                                
+  let sort_of_atomic_type env sigma ft args =
+  let rec concl_of_arity env ar =
+    match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
+      | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b
+      | T.Sort s -> Coq_sort (T.family_of_sort s)
+      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
+  in concl_of_arity env ft
+                                                                                
+let typeur sigma metamap =
+  let rec type_of env cstr=
+    match Term.kind_of_term cstr with
+    | T.Meta n ->
+          (try T.strip_outer_cast (List.assoc n metamap)
+           with Not_found -> Util.anomaly "type_of: this is not a well-typed term")
+    | T.Rel n ->
+        let (_,_,ty) = Environ.lookup_rel n env in
+        T.lift n ty
+    | T.Var id ->
+        (try
+          let (_,_,ty) = Environ.lookup_named id env in
+          T.body_of_type ty
+        with Not_found ->
+          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)
+    | T.Construct cstr ->
+       T.body_of_type (Inductive.type_of_constructor env cstr)
+    | T.Case (_,p,c,lf) ->
+        let Inductiveops.IndType(_,realargs) =
+          try Inductiveops.find_rectype env sigma (type_of env c)
+          with Not_found -> Util.anomaly "type_of: Bad recursive type" in
+        let t = Reductionops.whd_beta (T.applist (p, realargs)) in
+        (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with
+          | T.Prod _ -> Reductionops.whd_beta (T.applist (t, [c]))
+          | _ -> t)
+    | T.Lambda (name,c1,c2) ->
+          T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2)
+    | T.LetIn (name,b,c1,c2) ->
+         T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2)
+    | T.Fix ((_,i),(_,tys,_)) -> tys.(i)
+    | T.CoFix (i,(_,tys,_)) -> tys.(i)
+    | 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.Sort _ | T.Prod _ ->
+       match sort_of env cstr with
+          Coq_sort T.InProp -> T.mkProp
+        | Coq_sort T.InSet -> T.mkSet
+        | Coq_sort T.InType -> T.mkType Univ.prop_univ (* ERROR HERE *)
+        | CProp -> T.mkConst DoubleTypeInference.cprop
+                                                                                
+  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.Sort (T.Prop c) -> Coq_sort T.InType
+    | T.Sort (T.Type u) -> Coq_sort T.InType
+    | T.Prod (name,t,c2) ->
+       (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with
+          | _, (Coq_sort T.InProp as s) -> s
+          | Coq_sort T.InProp, (Coq_sort T.InSet as s)
+          | 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
+          | 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*)
+          | _, (CProp as s) -> s)
+    | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
+    | T.Lambda _ | T.Fix _ | T.Construct _ ->
+        Util.anomaly "sort_of: Not a type (1)"
+    | _ -> outsort env sigma (type_of env t)
+                                                                                
+  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.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
+    | T.App(f,args) ->
+       sort_of_atomic_type env sigma (type_of env f) args
+    | T.Lambda _ | T.Fix _ | T.Construct _ ->
+        Util.anomaly "sort_of: Not a type (1)"
+    | _ -> outsort env sigma (type_of env t)
+                                                                                
+  in type_of, sort_of, sort_family_of
+
+  let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
+  let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
+
+ end
+;;
+
+let get_sort_family_of env evar_map ty =
+ CPropRetyping.get_sort_family_of env evar_map ty
+;;
+
+let type_as_sort env evar_map ty =
+(* CCorn code *)
+ family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty)
+;;
+
+let is_a_Prop =
+ function
+    "Prop"
+  | "CProp" -> true
+  | _ -> false
+;;
+
+(* Main Functions *)
+
+type anntypes =
+ {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option}
+;;
+
+let gen_id seed =
+ let res = "i" ^ string_of_int !seed in
+  incr seed ;
+  res
+;;
+
+let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids =
+ fun father t ->
+  let res = gen_id seed in
+   Hashtbl.add ids_to_father_ids res father ;
+   Hashtbl.add ids_to_terms res t ;
+   Acic.CicHash.add constr_to_ids t res ;
+   res
+;;
+
+let source_id_of_id id = "#source#" ^ id;;
+
+let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
+ ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
+ pvars ?(fake_dependent_products=false) env idrefs evar_map t expectedty
+=
+ let module D = DoubleTypeInference in
+ let module E = Environ in
+ let module N = Names in
+ let module A = Acic in
+ let module T = Term in
+  let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in
+   (* CSC: do you have any reasonable substitute for 503? *)
+   let terms_to_types = Acic.CicHash.create 503 in
+    D.double_type_of env evar_map t expectedty terms_to_types ;
+    let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env
+     idrefs ?(subst=None,[]) tt
+    =
+     let fresh_id'' = fresh_id' father tt in
+     let aux' = aux computeinnertypes (Some fresh_id'') [] in
+      let string_of_sort_family =
+       function
+          Coq_sort T.InProp -> "Prop"
+        | Coq_sort T.InSet  -> "Set"
+        | Coq_sort T.InType -> "Type"
+        | CProp -> "CProp"
+      in
+      let string_of_sort t =
+       string_of_sort_family
+        (type_as_sort env evar_map t)
+      in
+       let ainnertypes,innertype,innersort,expected_available =
+        let {D.synthesized = synthesized; D.expected = expected} =
+         if computeinnertypes then
+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
+         else
+          (* We are already in an inner-type and Coscoy's double *)
+          (* type inference algorithm has not been applied.      *)
+          (* We need to refresh the universes because we are doing *)
+          (* type inference on an already inferred type.           *)
+          {D.synthesized =
+            Reductionops.nf_beta
+             (CPropRetyping.get_type_of env evar_map
+              (Evarutil.refresh_universes tt)) ;
+           D.expected = None}
+        in
+(* Debugging only:
+print_endline "TERMINE:" ; flush stdout ;
+Pp.ppnl (Printer.prterm tt) ; flush stdout ;
+print_endline "TIPO:" ; flush stdout ;
+Pp.ppnl (Printer.prterm 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
+(* Debugging only:
+print_endline "PASSATO" ; flush stdout ;
+*)
+          let ainnertypes,expected_available =
+           if computeinnertypes then
+            let annexpected,expected_available =
+               match expected with
+                  None -> None,false
+                | Some expectedty' ->
+                   Some (aux false (Some fresh_id'') [] env idrefs expectedty'),
+                    true
+            in
+             Some
+              {annsynthesized =
+                aux false (Some fresh_id'') [] env idrefs synthesized ;
+               annexpected = annexpected
+              }, expected_available
+           else
+            None,false
+          in
+           ainnertypes,synthesized, string_of_sort_family innersort,
+            expected_available
+       in
+        let add_inner_type id =
+         match ainnertypes with
+            None -> ()
+          | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes
+        in
+
+         (* explicit_substitute_and_eta_expand_if_required h t t'         *)
+         (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit   *)
+         (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = [])  *)
+         (* check if [h] is a term that requires an explicit named        *)
+         (* substitution and, in that case, uses the first arguments of   *)
+         (* [t] as the actual arguments of the substitution. If there     *)
+         (* are not enough parameters in the list [t], then eta-expansion *)
+         (* is performed.                                                 *)
+         let
+          explicit_substitute_and_eta_expand_if_required h t t'
+           compute_result_if_eta_expansion_not_required
+         =
+          let subst,residual_args,uninst_vars =
+           let variables,basedir =
+             try
+               let g = Libnames.reference_of_constr h in
+               let sp =
+                match g with
+                   Libnames.ConstructRef ((induri,_),_)
+                 | Libnames.IndRef (induri,_) ->
+                    Nametab.sp_of_global (Libnames.IndRef (induri,0))
+                 | Libnames.VarRef id ->
+                    (* Invariant: variables are never cooked in Coq *)
+                    raise Not_found
+                 | _ -> Nametab.sp_of_global g
+               in
+               Dischargedhypsmap.get_discharged_hyps sp,
+               get_module_path_of_section_path sp
+             with Not_found ->
+                (* no explicit substitution *)
+                [], Libnames.dirpath_of_string "dummy"
+           in
+           (* returns a triple whose first element is  *)
+           (* an explicit named substitution of "type" *)
+           (* (variable * argument) list, whose        *)
+           (* second element is the list of residual   *)
+           (* arguments and whose third argument is    *) 
+           (* the list of uninstantiated variables     *)
+           let rec get_explicit_subst variables arguments =
+            match variables,arguments with
+               [],_ -> [],arguments,[]
+             | _,[] -> [],[],variables
+             | he1::tl1,he2::tl2 ->
+                let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in
+                let (he1_sp, he1_id) = Libnames.repr_path he1 in
+                let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in
+                let he1'' =
+                 String.concat "/"
+                  (List.map Names.string_of_id (List.rev he1')) ^ "/"
+                 ^ (Names.string_of_id he1_id) ^ ".var" 
+                in
+                 (he1'',he2)::subst, extra_args, uninst
+           in
+            get_explicit_subst variables t'
+          in
+           let uninst_vars_length = List.length uninst_vars in
+            if uninst_vars_length > 0 then
+             (* Not enough arguments provided. We must eta-expand! *)
+             let un_args,_ =
+              T.decompose_prod_n uninst_vars_length
+               (CPropRetyping.get_type_of env evar_map tt)
+             in
+              let eta_expanded =
+               let arguments =
+                List.map (T.lift uninst_vars_length) t @
+                 Termops.rel_list 0 uninst_vars_length
+               in
+                Unshare.unshare
+                 (T.lamn uninst_vars_length un_args
+                  (T.applistc h arguments))
+              in
+               D.double_type_of env evar_map eta_expanded
+                None terms_to_types ;
+               Hashtbl.remove ids_to_inner_types fresh_id'' ;
+               aux' env idrefs eta_expanded
+            else
+             compute_result_if_eta_expansion_not_required subst residual_args
+         in
+
+          (* Now that we have all the auxiliary functions we  *)
+          (* can finally proceed with the main case analysis. *) 
+          match T.kind_of_term tt with
+             T.Rel n ->
+              let id =
+               match List.nth (E.rel_context env) (n - 1) with
+                  (N.Name id,_,_)   -> id
+                | (N.Anonymous,_,_) -> Nameops.make_ident "_" None
+              in
+               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+               if is_a_Prop innersort  && expected_available then
+                add_inner_type fresh_id'' ;
+               A.ARel (fresh_id'', n, List.nth idrefs (n-1), id)
+           | T.Var id ->
+              let path = get_uri_of_var (N.string_of_id id) pvars in
+               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+               if is_a_Prop innersort  && expected_available then
+                add_inner_type fresh_id'' ;
+               A.AVar
+                (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var")
+           | T.Evar (n,l) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort  && expected_available then
+               add_inner_type fresh_id'' ;
+              A.AEvar
+               (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) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort then
+               add_inner_type fresh_id'' ;
+              A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t)
+           | T.Prod (n,s,t) ->
+              let n' =
+               match n with
+                  N.Anonymous -> N.Anonymous
+                | _ ->
+                  if not fake_dependent_products && T.noccurn 1 t then
+                   N.Anonymous
+                  else
+                   N.Name
+                    (Nameops.next_name_away n (Termops.ids_of_context env))
+              in
+               Hashtbl.add ids_to_inner_sorts fresh_id''
+                (string_of_sort innertype) ;
+               let sourcetype = CPropRetyping.get_type_of env evar_map s in
+                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+                 (string_of_sort sourcetype) ;
+               let new_passed_prods =
+                let father_is_prod =
+                 match father with
+                    None -> false
+                  | Some father' ->
+                     match
+                      Term.kind_of_term (Hashtbl.find ids_to_terms father')
+                     with
+                        T.Prod _ -> true
+                      | _ -> false
+                in
+                 (fresh_id'', n', aux' env idrefs s)::
+                  (if father_is_prod then
+                    passed_lambdas_or_prods_or_letins
+                   else [])
+               in
+                let new_env = E.push_rel (n', None, s) env in
+                let new_idrefs = fresh_id''::idrefs in
+                 (match Term.kind_of_term t with
+                     T.Prod _ ->
+                      aux computeinnertypes (Some fresh_id'') new_passed_prods
+                       new_env new_idrefs t
+                   | _ ->
+                     A.AProds (new_passed_prods, aux' new_env new_idrefs t))
+           | T.Lambda (n,s,t) ->
+              let n' =
+               match n with
+                  N.Anonymous -> N.Anonymous
+                | _ ->
+                  N.Name (Nameops.next_name_away n (Termops.ids_of_context env))
+              in
+               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+               let sourcetype = CPropRetyping.get_type_of env evar_map s in
+                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+                 (string_of_sort sourcetype) ;
+               let father_is_lambda =
+                match father with
+                   None -> false
+                 | Some father' ->
+                    match
+                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
+                    with
+                       T.Lambda _ -> true
+                     | _ -> false
+               in
+                if is_a_Prop innersort &&
+                   ((not father_is_lambda) || expected_available)
+                then add_inner_type fresh_id'' ;
+                let new_passed_lambdas =
+                 (fresh_id'',n', aux' env idrefs s)::
+                  (if father_is_lambda then
+                    passed_lambdas_or_prods_or_letins
+                   else []) in
+                let new_env = E.push_rel (n', None, s) env in
+                let new_idrefs = fresh_id''::idrefs in
+                 (match Term.kind_of_term t with
+                     T.Lambda _ ->
+                      aux computeinnertypes (Some fresh_id'') new_passed_lambdas
+                       new_env new_idrefs t
+                   | _ ->
+                     let t' = aux' new_env new_idrefs t in
+                      (* eta-expansion for explicit named substitutions *)
+                      (* can create nested Lambdas. Here we perform the *)
+                      (* flattening.                                    *)
+                      match t' with
+                         A.ALambdas (lambdas, t'') ->
+                          A.ALambdas (lambdas@new_passed_lambdas, t'')
+                       | _ ->
+                         A.ALambdas (new_passed_lambdas, t')
+                 )
+           | T.LetIn (n,s,t,d) ->
+              let n' =
+               match n with
+                  N.Anonymous -> N.Anonymous
+                | _ ->
+                  N.Name (Nameops.next_name_away n (Termops.ids_of_context env))
+              in
+               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+               let sourcesort =
+                get_sort_family_of env evar_map
+                 (CPropRetyping.get_type_of env evar_map s)
+               in
+                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+                 (string_of_sort_family sourcesort) ;
+               let father_is_letin =
+                match father with
+                   None -> false
+                 | Some father' ->
+                    match
+                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
+                    with
+                       T.LetIn _ -> true
+                     | _ -> false
+               in
+                if is_a_Prop innersort then
+                 add_inner_type fresh_id'' ;
+                let new_passed_letins =
+                 (fresh_id'',n', aux' env idrefs s)::
+                  (if father_is_letin then
+                    passed_lambdas_or_prods_or_letins
+                   else []) in
+                let new_env = E.push_rel (n', Some s, t) env in
+                let new_idrefs = fresh_id''::idrefs in
+                 (match Term.kind_of_term d with
+                     T.LetIn _ ->
+                      aux computeinnertypes (Some fresh_id'') new_passed_letins
+                       new_env new_idrefs d
+                   | _ -> A.ALetIns
+                           (new_passed_letins, aux' new_env new_idrefs d))
+           | T.App (h,t) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort then
+               add_inner_type fresh_id'' ;
+              let
+               compute_result_if_eta_expansion_not_required subst residual_args
+              =
+               let residual_args_not_empty = List.length residual_args > 0 in
+               let h' =
+                if residual_args_not_empty then
+                 aux' env idrefs ~subst:(None,subst) h
+                else
+                 aux' env idrefs ~subst:(Some fresh_id'',subst) h
+               in
+                (* maybe all the arguments were used for the explicit *)
+                (* named substitution                                 *)
+                if residual_args_not_empty then
+                 A.AApp (fresh_id'', h'::residual_args)
+                else
+                 h'
+              in
+               let t' =
+                Array.fold_right (fun x i -> (aux' env idrefs x)::i) t []
+               in
+                explicit_substitute_and_eta_expand_if_required h
+                 (Array.to_list t) t'
+                 compute_result_if_eta_expansion_not_required
+           | T.Const kn ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              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))
+              in
+               let (_,subst') = subst in
+                explicit_substitute_and_eta_expand_if_required tt []
+                 (List.map snd subst')
+                 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)
+              in
+               let (_,subst') = subst in
+                explicit_substitute_and_eta_expand_if_required tt []
+                 (List.map snd subst')
+                 compute_result_if_eta_expansion_not_required
+           | T.Construct ((kn,i),j) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort  && expected_available then
+               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)
+              in
+               let (_,subst') = subst in
+                explicit_substitute_and_eta_expand_if_required tt []
+                 (List.map snd subst')
+                 compute_result_if_eta_expansion_not_required
+           | T.Case ({T.ci_ind=(kn,i)},ty,term,a) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort then
+               add_inner_type fresh_id'' ;
+              let a' =
+               Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
+              in
+               A.ACase
+                (fresh_id'', (uri_of_kernel_name kn Inductive), 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 ;
+              if is_a_Prop innersort then add_inner_type fresh_id'' ;
+              let fresh_idrefs =
+               Array.init (Array.length t) (function _ -> gen_id seed) in
+              let new_idrefs =
+               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
+              in
+               let f' =
+                let ids = ref (Termops.ids_of_context env) in
+                 Array.map
+                  (function
+                      N.Anonymous -> Util.error "Anonymous fix function met"
+                    | N.Name id as n ->
+                       let res = N.Name (Nameops.next_name_away n !ids) in
+                        ids := id::!ids ;
+                        res
+                 ) f
+               in
+                A.AFix (fresh_id'', i,
+                 Array.fold_right
+                  (fun (id,fi,ti,bi,ai) i ->
+                    let fi' =
+                     match fi with
+                        N.Name fi -> fi
+                      | N.Anonymous -> Util.error "Anonymous fix function met"
+                    in
+                     (id, fi', ai,
+                      aux' env idrefs ti,
+                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
+                  (Array.mapi
+                   (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f'
+                  ) []
+                 )
+           | T.CoFix (i,(f,t,b)) ->
+              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+              if is_a_Prop innersort then add_inner_type fresh_id'' ;
+              let fresh_idrefs =
+               Array.init (Array.length t) (function _ -> gen_id seed) in
+              let new_idrefs =
+               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
+              in
+               let f' =
+                let ids = ref (Termops.ids_of_context env) in
+                 Array.map
+                  (function
+                      N.Anonymous -> Util.error "Anonymous fix function met"
+                    | N.Name id as n ->
+                       let res = N.Name (Nameops.next_name_away n !ids) in
+                        ids := id::!ids ;
+                        res
+                 ) f
+               in
+                A.ACoFix (fresh_id'', i,
+                 Array.fold_right
+                  (fun (id,fi,ti,bi) i ->
+                    let fi' =
+                     match fi with
+                        N.Name fi -> fi
+                      | N.Anonymous -> Util.error "Anonymous fix function met"
+                    in
+                     (id, fi',
+                      aux' env idrefs ti,
+                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
+                  (Array.mapi
+                    (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f'
+                  ) []
+                 )
+    in
+     aux computeinnertypes None [] env idrefs t
+;;
+
+let acic_of_cic_context metasenv context t =
+ 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
+   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
+    ids_to_inner_sorts ids_to_inner_types metasenv context t,
+   ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
+;;
+
+let acic_object_of_cic_object pvars sigma obj =
+ let module A = Acic in
+  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 ids_to_conjectures = Hashtbl.create 11 in
+  let ids_to_hypotheses = Hashtbl.create 127 in
+  let hypotheses_seed = ref 0 in
+  let conjectures_seed = ref 0 in
+  let seed = ref 0 in
+  let acic_term_of_cic_term_context' =
+   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
+    ids_to_inner_sorts ids_to_inner_types pvars in
+(*CSC: is this the right env to use? Hhmmm. There is a problem: in    *)
+(*CSC: Global.env () the object we are exporting is already defined,  *)
+(*CSC: either in the environment or in the named context (in the case *)
+(*CSC: of variables. Is this a problem?                               *)
+  let env = Global.env () in
+  let acic_term_of_cic_term' ?fake_dependent_products =
+   acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in
+(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *)
+(*CSC: a modified version of the already existent fresh_id function    *)
+  let fresh_id () =
+   let res = "i" ^ string_of_int !seed in
+    incr seed ;
+    res
+  in
+   let aobj =
+    match obj with
+      A.Constant (id,bo,ty,params) ->
+       let abo =
+        match bo with
+           None -> None
+         | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty))
+       in
+       let aty = acic_term_of_cic_term' ty None in
+        A.AConstant (fresh_id (),id,abo,aty,params)
+    | A.Variable (id,bo,ty,params) ->
+       let abo =
+        match bo with
+           Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
+         | None -> None
+       in
+       let aty = acic_term_of_cic_term' ty None in
+        A.AVariable (fresh_id (),id,abo,aty,params)
+    | A.CurrentProof (id,conjectures,bo,ty) ->
+       let aconjectures =
+        List.map
+         (function (i,canonical_context,term) as conjecture ->
+           let cid = "c" ^ string_of_int !conjectures_seed in
+            Hashtbl.add ids_to_conjectures cid conjecture ;
+            incr conjectures_seed ;
+            let canonical_env,idrefs',acanonical_context =
+             let rec aux env idrefs =
+              function
+                 [] -> env,idrefs,[]
+               | ((n,decl_or_def) as hyp)::tl ->
+                  let hid = "h" ^ string_of_int !hypotheses_seed in
+                  let new_idrefs = hid::idrefs in
+                   Hashtbl.add ids_to_hypotheses hid hyp ;
+                   incr hypotheses_seed ;
+                   match decl_or_def with
+                       A.Decl t ->
+                        let final_env,final_idrefs,atl =
+                         aux (Environ.push_rel (Names.Name n,None,t) env)
+                          new_idrefs tl
+                        in
+                         let at =
+                          acic_term_of_cic_term_context' env idrefs sigma t None
+                         in
+                          final_env,final_idrefs,(hid,(n,A.Decl at))::atl
+                     | A.Def (t,ty) ->
+                        let final_env,final_idrefs,atl =
+                         aux
+                          (Environ.push_rel (Names.Name n,Some t,ty) env)
+                           new_idrefs tl
+                        in
+                         let at =
+                          acic_term_of_cic_term_context' env idrefs sigma t None
+                         in
+                         let dummy_never_used =
+                          let s = "dummy_never_used" in
+                           A.ARel (s,99,s,Names.id_of_string s)
+                         in
+                          final_env,final_idrefs,
+                           (hid,(n,A.Def (at,dummy_never_used)))::atl
+             in
+              aux env [] canonical_context
+            in
+             let aterm =
+              acic_term_of_cic_term_context' canonical_env idrefs' sigma term
+               None
+             in
+              (cid,i,List.rev acanonical_context,aterm)
+         ) conjectures in
+       let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in
+       let aty = acic_term_of_cic_term_context' env [] sigma ty None in
+        A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty)
+    | A.InductiveDefinition (tys,params,paramsno) ->
+       let env' =
+        List.fold_right
+         (fun (name,_,arity,_) env ->
+           Environ.push_rel (Names.Name name, None, arity) env
+         ) (List.rev tys) env in
+       let idrefs = List.map (function _ -> gen_id seed) tys in
+       let atys =
+        List.map2
+         (fun id (name,inductive,ty,cons) ->
+           let acons =
+            List.map
+             (function (name,ty) ->
+               (name,
+                 acic_term_of_cic_term_context' ~fake_dependent_products:true
+                  env' idrefs Evd.empty ty None)
+             ) cons
+           in
+            let aty =
+             acic_term_of_cic_term' ~fake_dependent_products:true ty None
+            in
+             (id,name,inductive,aty,acons)
+         ) (List.rev idrefs) tys
+       in
+       A.AInductiveDefinition (fresh_id (),atys,params,paramsno)
+   in
+    aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts,
+     ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses
+;;
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
new file mode 100644
index 00000000..f0e3f5e3
--- /dev/null
+++ b/contrib/xml/doubleTypeInference.ml
@@ -0,0 +1,288 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *)
+type types = {synthesized : Term.types ; expected : Term.types option};;
+
+let prerr_endline _ = ();;
+
+let cprop =
+ let module N = Names in
+  N.make_kn
+   (N.MPfile
+     (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
+   (N.make_dirpath [])
+   (N.mk_label "CProp")
+;;
+
+let whd_betadeltaiotacprop env evar_map ty =
+ let module R = Rawterm in
+  let red_exp =
+   R.Hnf  (*** Instead CProp is made Opaque ***)
+(*
+   R.Cbv
+    {R.rBeta = true ; R.rIota = true ; R.rDelta = true; R.rZeta=true ;
+     R.rConst = [Names.EvalConstRef cprop]
+    }
+*)
+  in
+Conv_oracle.set_opaque_const cprop;
+prerr_endline "###whd_betadeltaiotacprop:" ;
+let xxx =
+(*Pp.msgerr (Printer.prterm_env env ty);*)
+prerr_endline "";
+   Tacred.reduction_of_redexp red_exp env evar_map ty
+in
+prerr_endline "###FINE" ;
+(*
+Pp.msgerr (Printer.prterm_env env xxx);
+*)
+prerr_endline "";
+Conv_oracle.set_transparent_const cprop;
+xxx
+;;
+
+
+(* Code similar to the code in the Typing module, but:   *)
+(*  - the term is already assumed to be well typed       *)
+(*  - some checks have been removed                      *)
+(*  - both the synthesized and expected types of every   *)
+(*    node are computed (Coscoy's double type inference) *)
+
+let assumption_of_judgment env sigma j =
+  Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j)
+;;
+
+let type_judgment env sigma j =
+  Typeops.type_judgment env (Evarutil.j_nf_evar sigma j)
+;;
+
+let type_judgment_cprop env sigma j =
+  match Term.kind_of_term(whd_betadeltaiotacprop env sigma (Term.body_of_type j.Environ.uj_type)) with
+    | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s }
+    | _ -> None  (* None means the CProp constant *)
+;;
+
+let double_type_of env sigma cstr expectedty subterms_to_types =
+ (*CSC: the code is inefficient because judgments are created just to be   *)
+ (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *)
+ (*CSC: functions used do checks that we do not need                       *)
+ let rec execute env sigma cstr expectedty =
+  let module T = Term in
+  let module E = Environ in
+   (* the type part is the synthesized type *)
+   let judgement =
+    match T.kind_of_term cstr with
+       T.Meta n ->
+        Util.error
+         "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 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 rec iter actual_args evar_context =
+          match actual_args,evar_context with
+             [],[] -> ()
+           | he1::tl1,(n,_,ty)::tl2 ->
+              (* for side-effects *)
+              let _ = execute env sigma he1 (Some ty) in
+              let tl2' =
+               List.map
+                (function (m,bo,ty) ->
+                  (* Warning: the substitution should be performed also on bo *)
+                  (* This is not done since bo is not used later yet          *)
+                  (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty))
+                ) tl2
+              in
+               iter tl1 tl2'
+           | _,_ -> assert false
+         in
+          (* for side effects only *)
+          iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
+          E.make_judge cstr jty
+	
+     | T.Rel n -> 
+        Typeops.judge_of_relative env n
+
+     | T.Var id -> 
+        Typeops.judge_of_variable env id
+	  
+     | T.Const c ->
+        E.make_judge cstr (E.constant_type env c)
+	  
+     | T.Ind ind ->
+        E.make_judge cstr (Inductive.type_of_inductive env ind)
+	  
+     | T.Construct cstruct -> 
+        E.make_judge cstr (Inductive.type_of_constructor env cstruct)
+	  
+     | T.Case (ci,p,c,lf) ->
+        let expectedtype =
+         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in 
+        let cj = execute env sigma c (Some expectedtype) in
+        let pj = execute env sigma p None in
+        let (expectedtypes,_,_) =
+         let indspec = Inductive.find_rectype env cj.Environ.uj_type in
+          Inductive.type_case_branches env indspec pj cj.Environ.uj_val
+        in
+        let lfj =
+         execute_array env sigma lf
+          (Array.map (function x -> Some x) expectedtypes) in
+        let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
+         j
+  
+     | T.Fix ((vn,i as vni),recdef) ->
+        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
+        let fix = (vni,recdef') in
+        E.make_judge (T.mkFix fix) tys.(i)
+	  
+     | T.CoFix (i,recdef) ->
+        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
+        let cofix = (i,recdef') in
+        E.make_judge (T.mkCoFix cofix) tys.(i)
+	  
+     | T.Sort (T.Prop c) -> 
+        Typeops.judge_of_prop_contents c
+
+     | T.Sort (T.Type u) ->
+(*CSC: In case of need, I refresh the universe. But exportation of the   *)
+(*CSC: right universe level information is destroyed. It must be changed *)
+(*CSC: again once Judicael will introduce his non-bugged algebraic       *)
+(*CSC: universes.                                                        *)
+(try
+        Typeops.judge_of_type u
+ with _ -> (* Successor of a non universe-variable universe anomaly *)
+ (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
+  Typeops.judge_of_type (Termops.new_univ ())
+)
+
+     | T.App (f,args) ->
+        let expected_head = 
+         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in 
+        let j = execute env sigma f (Some expected_head) in
+        let expected_args =
+         let rec aux typ =
+          function
+             [] -> []
+           | hj::restjl ->
+              match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with
+                 T.Prod (_,c1,c2) ->
+                  (Some (Reductionops.nf_beta c1)) ::
+                   (aux (T.subst1 hj c2) restjl)
+               | _ -> assert false
+         in
+          Array.of_list (aux j.Environ.uj_type (Array.to_list args))
+        in
+        let jl = execute_array env sigma args expected_args in
+        let (j,_) = Typeops.judge_of_apply env j jl in
+         j
+	    
+     | T.Lambda (name,c1,c2) -> 
+        let j = execute env sigma c1 None in
+        let var = type_judgment env sigma j in
+        let env1 = E.push_rel (name,None,var.E.utj_val) env in
+        let expectedc2type =
+         match expectedty with
+            None -> None
+          | Some ety ->
+              match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with
+                 T.Prod (_,_,expected_target_type) ->
+                  Some (Reductionops.nf_beta expected_target_type)
+               | _ -> assert false
+        in
+        let j' = execute env1 sigma c2 expectedc2type in 
+         Typeops.judge_of_abstraction env1 name var j'
+	  
+     | T.Prod (name,c1,c2) ->
+        let j = execute env sigma c1 None in
+        let varj = type_judgment env sigma j in
+        let env1 = E.push_rel (name,None,varj.E.utj_val) env in
+        let j' = execute env1 sigma c2 None in
+        (match type_judgment_cprop env1 sigma j' with
+            Some varj' -> Typeops.judge_of_product env name varj varj'
+          | None ->
+             (* CProp found *)
+             { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val);
+               Environ.uj_type = T.mkConst cprop })
+
+     | T.LetIn (name,c1,c2,c3) ->
+(*CSC: What are the right expected types for the source and *)
+(*CSC: target of a LetIn? None used.                        *)
+        let j1 = execute env sigma c1 None in
+        let j2 = execute env sigma c2 None in
+        let j2 = type_judgment env sigma j2 in
+        let env1 =
+         E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env
+        in
+         let j3 = execute env1 sigma c3 None in
+          Typeops.judge_of_letin env name j1 j2 j3
+  
+     | T.Cast (c,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
+	 j
+    in
+     let synthesized = E.j_type judgement in
+     let synthesized' = Reductionops.nf_beta synthesized in
+      let types,res =
+       match expectedty with
+          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
+        | 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 ) ;
+       Acic.CicHash.add subterms_to_types cstr types ;
+       E.make_judge cstr res
+
+
+ and execute_recdef env sigma (names,lar,vdef) =
+   let length = Array.length lar in
+   let larj =
+    execute_array env sigma lar (Array.make length None) in
+   let lara = Array.map (assumption_of_judgment env sigma) larj in
+   let env1 = Environ.push_rec_types (names,lara,vdef) env in
+   let expectedtypes =
+    Array.map (function i -> Some (Term.lift length i)) lar
+   in
+   let vdefj = execute_array env1 sigma vdef expectedtypes in
+   let vdefv = Array.map Environ.j_val vdefj in
+   (names,lara,vdefv)
+
+ and execute_array env sigma v expectedtypes =
+   let jl =
+    execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes)
+   in
+    Array.of_list jl
+
+ and execute_list env sigma =
+  List.map2 (execute env sigma)
+
+in
+ ignore (execute env sigma cstr expectedty)
+;;
diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli
new file mode 100644
index 00000000..33d3e5cd
--- /dev/null
+++ b/contrib/xml/doubleTypeInference.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+type types = { synthesized : Term.types; expected : Term.types option; } 
+
+val cprop : Names.kernel_name
+
+val whd_betadeltaiotacprop :
+  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
+
+val double_type_of :
+  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option ->
+   types Acic.CicHash.t -> unit
diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml
new file mode 100644
index 00000000..165a456d
--- /dev/null
+++ b/contrib/xml/proof2aproof.ml
@@ -0,0 +1,169 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(* Note: we can not use the Set module here because we _need_ physical *)
+(* equality and there exists no comparison function compatible with    *)
+(* physical equality.                                                  *)
+
+module S =
+ struct
+  let empty = []
+  let mem = List.memq
+  let add x l = x::l
+ end
+;;
+
+(* evar reduction that preserves some terms *)
+let nf_evar sigma ~preserve =
+ let module T = Term in
+  let rec aux t =
+   if preserve t then t else
+    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.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)
+     | T.App (c,l) ->
+        let c' = aux c in
+        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,_) ->
+              (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) -> 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)) ->
+         T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
+     | T.CoFix(ln,(lna,tl,bl)) ->
+         T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
+   in
+    aux
+;;
+
+(* Unshares a proof-tree.                                                  *)
+(* 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} ->
+   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
+         Some (unshared_rule, List.map unshare_proof_tree pfs)
+   in
+    {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = unshared_ref}
+;;
+
+module ProofTreeHash =
+ Hashtbl.Make
+  (struct
+    type t = Proof_type.proof_tree
+    let equal = (==)
+    let hash = Hashtbl.hash
+   end)
+;;
+
+
+let extract_open_proof sigma pf =
+ let module PT = Proof_type in
+ let module L = Logic in
+  let sigma = ref 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
+  let rec proof_extractor vl node =
+   let constr =
+    match node with
+       {PT.ref=Some(PT.Prim _,_)} as pf ->
+        L.prim_extractor proof_extractor vl pf
+	  
+     | {PT.ref=Some(PT.Tactic (_,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)
+	        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
+	 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
+         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' ;
+         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
+     in
+      Unshare.unshare
+       ~already_unshared:(function e -> S.mem e !unshared_constrs)
+       evar_nf_constr
+    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)) ;
+     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,
+    unshared_pf)
+;;
+
+let extract_open_pftreestate pts =
+  extract_open_proof (Refiner.evc_of_pftreestate pts)
+   (Tacmach.proof_of_pftreestate pts)
+;;
diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4
new file mode 100644
index 00000000..b9b66774
--- /dev/null
+++ b/contrib/xml/proofTree2Xml.ml4
@@ -0,0 +1,211 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
+
+let std_ppcmds_to_string s =
+   Pp.msg_with Format.str_formatter s;
+   Format.flush_str_formatter ()
+;;
+
+let idref_of_id id = "v" ^ id;;
+
+(* Transform a constr to an Xml.token Stream.t *)
+(* env is a named context                      *)
+(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *)
+let constr_to_xml obj sigma env =
+  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 pvars = [] in
+  (* named_context holds section variables and local variables *)
+  let named_context = Environ.named_context env  in
+  (* real_named_context holds only the section variables *)
+  let real_named_context = Environ.named_context (Global.env ()) in
+  (* named_context' holds only the local variables *)
+  let named_context' =
+   List.filter (function n -> not (List.mem n real_named_context)) named_context
+  in
+  let idrefs =
+   List.map
+    (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in
+  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
+  let obj' =
+   Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
+  let seed = ref 0 in
+   try
+    let annobj =
+     Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids
+      ids_to_father_ids ids_to_inner_sorts ids_to_inner_types pvars rel_env
+      idrefs sigma (Unshare.unshare obj') None
+    in
+     Acic2Xml.print_term ids_to_inner_sorts annobj
+   with e ->
+    Util.anomaly
+     ("Problem during the conversion of constr into XML: " ^
+      Printexc.to_string e)
+(* CSC: debugging stuff
+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 (Pp.str "RAW-TERM:") ;
+Pp.ppnl (Printer.prterm obj') ;
+Xml.xml_empty "MISSING TERM" [] (*; raise e*)
+*)
+;;
+
+let first_word s =
+   try let i = String.index s ' ' in
+       String.sub s 0 i
+   with _ -> s
+;;
+
+let string_of_prim_rule x = match x with
+  | Proof_type.Intro _-> "Intro"
+  | Proof_type.Intro_replacing _-> "Intro_replacing"
+  | Proof_type.Cut (_,_,_) -> "Cut"
+  | Proof_type.FixRule (_,_,_) -> "FixRule"
+  | Proof_type.Cofix (_,_)-> "Cofix"
+  | Proof_type.Refine _ -> "Refine"
+  | Proof_type.Convert_concl _ -> "Convert_concl"
+  | Proof_type.Convert_hyp _->"Convert_hyp"
+  | Proof_type.Thin _ -> "Thin"
+  | Proof_type.ThinBody _-> "ThinBody"
+  | Proof_type.Move (_,_,_) -> "Move"
+  | Proof_type.Rename (_,_) -> "Rename"
+
+
+let
+ print_proof_tree curi sigma0 pf proof_tree_to_constr
+  proof_tree_to_flattened_proof_tree constr_to_ids
+=
+ let module PT = Proof_type in
+ let module L = Logic in
+ let module X = Xml in
+ let module T = Tacexpr in
+  let ids_of_node node =
+   let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in
+(*
+let constr =
+ try
+    Proof2aproof.ProofTreeHash.find proof_tree_to_constr node
+ with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated
+no lambda-term: ") (Refiner.print_script true (Evd.empty)
+(Global.named_context ()) node)) ; assert false (* Closed bug, should not
+happen any more *)
+in
+*)
+   try
+    Some (Acic.CicHash.find constr_to_ids constr)
+   with _ ->
+Pp.ppnl (Pp.(++) (Pp.str
+"The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
+(Printer.prterm constr)) ;
+    None
+  in
+  let rec aux node old_hyps =
+   let of_attribute =
+    match ids_of_node node with
+       None -> []
+     | Some id -> ["of",id]
+   in
+    match node with
+       {PT.ref=Some(PT.Prim tactic_expr,nodes)} ->
+         let tac = string_of_prim_rule tactic_expr in
+         let of_attribute = ("name",tac)::of_attribute in
+          if nodes = [] then
+           X.xml_empty "Prim" of_attribute
+          else
+           X.xml_nempty "Prim" of_attribute
+            (List.fold_left
+              (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
+
+     | {PT.goal=goal;
+        PT.ref=Some(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]   *)
+         (*  for the holes in [hidden_proof]                               *)
+        let flat_proof =
+         Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
+        in begin
+        match tactic_expr with
+        | T.TacArg (T.Tacexp _) -> 
+            (* We don't need to keep the level of abstraction introduced at *)
+            (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
+            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 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
+
+         (****** le but *)
+         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 xgoal =
+          X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
+
+         let rec build_hyps =
+          function
+           | [] -> xgoal
+           | (id,c,tid)::hyps1 ->
+              let id' = Names.string_of_id id in
+               [< build_hyps hyps1;
+                  (X.xml_nempty "Hypothesis"
+                    ["id",idref_of_id id' ; "name",id']
+                    (constr_to_xml tid sigma env))
+               >] in
+         let old_names = List.map (fun (id,c,tid)->id) old_hyps in
+         let new_hyps =
+          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) hyps in
+
+         X.xml_nempty "Tactic" of_attribute
+          [<(build_hyps new_hyps) ; (aux flat_proof hyps)>]
+        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=None;PT.goal=goal} ->
+         X.xml_empty "Open_goal" of_attribute
+  in
+   [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+      X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
+      X.xml_nempty "ProofTree" ["of",curi] (aux pf [])
+   >]
+;;
+
+
+(* Hook registration *)
+(* CSC: debranched since it is bugged
+Xmlcommand.set_print_proof_tree print_proof_tree;;
+*)
diff --git a/contrib/xml/theoryobject.dtd b/contrib/xml/theoryobject.dtd
new file mode 100644
index 00000000..953fe009
--- /dev/null
+++ b/contrib/xml/theoryobject.dtd
@@ -0,0 +1,62 @@
+<?xml encoding="ISO-8859-1"?>
+
+<!-- Copyright (C) 2000-2004, HELM Team                                -->
+<!--                                                                   -->
+<!-- This file is part of HELM, an Hypertextual, Electronic            -->
+<!-- Library of Mathematics, developed at the Computer Science         -->
+<!-- Department, University of Bologna, Italy.                         -->
+<!--                                                                   -->
+<!-- HELM 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 (at your option) any later version.            -->
+<!--                                                                   -->
+<!-- HELM 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 HELM; if not, write to the Free Software               -->
+<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
+<!-- MA  02111-1307, USA.                                              -->
+<!--                                                                   -->
+<!-- For details, see the HELM World-Wide-Web page,                    -->
+<!-- http://cs.unibo.it/helm/.                                         -->
+
+
+
+<!-- Notice: the markup described in this DTD is meant to be embedded -->
+<!-- in foreign markup (e.g. XHTML)                                   -->
+
+<!ENTITY % theorystructure
+  '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'>
+
+<!ELEMENT ht:SECTION (%theorystructure;)>
+<!ATTLIST ht:SECTION
+          uri CDATA #REQUIRED>
+
+<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)>
+
+<!-- Theory Items -->
+
+<!ELEMENT ht:AXIOM (Axiom)>
+<!ATTLIST ht:AXIOM
+          uri CDATA #REQUIRED
+          as (Axiom|Declaration) #REQUIRED>
+
+<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)>
+<!ATTLIST ht:DEFINITION
+          uri CDATA #REQUIRED
+          as (Definition|InteractiveDefinition|Inductive|CoInductive
+             |Record) #REQUIRED>
+
+<!ELEMENT ht:THEOREM (type)>
+<!ATTLIST ht:THEOREM
+          uri CDATA #REQUIRED
+          as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED>
+
+<!ELEMENT ht:VARIABLE (Variable)>
+<!ATTLIST ht:VARIABLE
+          uri CDATA #REQUIRED
+          as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED>
diff --git a/contrib/xml/unshare.ml b/contrib/xml/unshare.ml
new file mode 100644
index 00000000..f30f8230
--- /dev/null
+++ b/contrib/xml/unshare.ml
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+exception CanNotUnshare;;
+
+(* [unshare t] gives back a copy of t where all sharing has been removed   *)
+(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
+(* use physical equality can now be used to associate information to evey  *)
+(* node of the term.                                                       *)
+let unshare ?(already_unshared = function _ -> false) t =
+ let obj = Obj.repr t in
+  let rec aux obj =
+   if already_unshared (Obj.obj obj) then
+    obj
+   else
+    (if Obj.is_int obj then
+      obj
+     else if Obj.is_block obj then
+      begin
+       let tag = Obj.tag obj in
+        if tag < Obj.no_scan_tag then
+         begin
+          let size = Obj.size obj in
+           let new_obj = Obj.new_block 0 size in
+            Obj.set_tag new_obj tag ;
+            for i = 0 to size - 1 do
+             Obj.set_field new_obj i (aux (Obj.field obj i))
+            done ;
+            new_obj
+         end
+        else if tag = Obj.string_tag then
+         obj
+        else
+         raise CanNotUnshare
+      end
+     else
+      raise CanNotUnshare
+    )
+  in
+   Obj.obj (aux obj)
+;;
diff --git a/contrib/xml/unshare.mli b/contrib/xml/unshare.mli
new file mode 100644
index 00000000..31ba9037
--- /dev/null
+++ b/contrib/xml/unshare.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+exception CanNotUnshare;;
+
+(* [unshare t] gives back a copy of t where all sharing has been removed   *)
+(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
+(* use physical equality can now be used to associate information to evey  *)
+(* node of the term.                                                       *)
+val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a
diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4
new file mode 100644
index 00000000..d0c64f30
--- /dev/null
+++ b/contrib/xml/xml.ml4
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(* the type token for XML cdata, empty elements and not-empty elements *)
+(* Usage:                                                                *)
+(*  Str cdata                                                            *)
+(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
+(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(*          content                                                      *)
+type token = Str of string
+           | Empty of string * (string * string) list
+	   | NEmpty of string * (string * string) list * token Stream.t
+;;
+
+(* currified versions of the constructors make the code more readable *)
+let xml_empty name attrs = [< 'Empty(name,attrs) >]
+let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
+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 rec pp_r m =
+  parser
+    [< 'Str a ; s >] ->
+      print_spaces m ;
+      fprint_string (a ^ "\n") ;
+      pp_r m s
+  | [< 'Empty(n,l) ; s >] ->
+      print_spaces m ;
+      fprint_string ("<" ^ n) ;
+      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+      fprint_string "/>\n" ;
+      pp_r m s
+  | [< 'NEmpty(n,l,c) ; s >] ->
+      print_spaces m ;
+      fprint_string ("<" ^ n) ;
+      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+      fprint_string ">\n" ;
+      pp_r (m+1) c ;
+      print_spaces m ;
+      fprint_string ("</" ^ n ^ ">\n") ;
+      pp_r m s
+  | [< >] -> ()
+ and print_spaces m =
+  for i = 1 to m do fprint_string "  " done
+ and fprint_string str =
+  output_string !channel str
+ in
+  match fn with
+     Some filename ->
+      let filename = filename ^ ".xml" in
+       channel := open_out filename ;
+       pp_r 0 strm ;
+       close_out !channel ;
+       print_string ("\nWriting on file \"" ^ filename ^ "\" was succesful\n");
+       flush stdout
+   | None ->
+       pp_r 0 strm
+;;
diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli
new file mode 100644
index 00000000..e65e6c81
--- /dev/null
+++ b/contrib/xml/xml.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(*i $Id: xml.mli,v 1.5.2.2 2004/07/16 19:30:15 herbelin Exp $ i*)
+
+(* Tokens for XML cdata, empty elements and not-empty elements           *)
+(* Usage:                                                                *)
+(*  Str cdata                                                            *)
+(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
+(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(*          content                                                      *)
+type token =
+  | Str of string
+  | Empty of string * (string * string) list
+  | NEmpty of string * (string * string) list * token Stream.t
+
+(* currified versions of the token constructors make the code more readable *)
+val xml_empty : string -> (string * string) list -> token Stream.t
+val xml_nempty :
+  string -> (string * string) list -> token Stream.t -> token Stream.t
+val xml_cdata : string -> token Stream.t
+
+(* The pretty printer for streams of token                                  *)
+(* Usage:                                                                   *)
+(*  pp tokens None     pretty prints the output on stdout                   *)
+(*  pp tokens (Some filename) pretty prints the output on the file filename *)
+val pp : token Stream.t -> string option -> unit
diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
new file mode 100644
index 00000000..9fba5474
--- /dev/null
+++ b/contrib/xml/xmlcommand.ml
@@ -0,0 +1,706 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(* CONFIGURATION PARAMETERS *)
+
+let verbose = ref false;;
+
+(* HOOKS *)
+let print_proof_tree, set_print_proof_tree =
+ let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in
+  (fun () -> !print_proof_tree),
+   (fun f ->
+     print_proof_tree :=
+     fun
+      curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree
+      constr_to_ids
+     ->
+      Some
+       (f curi sigma0 pf proof_tree_to_constr
+        proof_tree_to_flattened_proof_tree constr_to_ids))
+;;
+
+(* UTILITY FUNCTIONS *)
+
+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;;
+
+(* 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    *)
+(* to be the same; the following function checks that the parameters    *)
+(* of each inductive of a same block are all the same, then returns     *)
+(* this number; it fails otherwise                                      *)
+let extract_nparams pack =
+ let module D = Declarations in
+ let module U = Util in
+ let module S = Sign in
+
+  let {D.mind_nparams=nparams0} = pack.(0) in
+  let arity0 = pack.(0).D.mind_user_arity in
+  let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in
+  for i = 1 to Array.length pack - 1 do
+    let {D.mind_nparams=nparamsi} = pack.(i) in
+    let arityi = pack.(i).D.mind_user_arity in
+    let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in
+    if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block"
+  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                                              *)
+let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
+ let module DK = Decl_kinds in
+ let module D = Declare in
+  let tag = Libobject.object_tag o in
+   print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
+   match tag with
+      "CONSTANT" ->
+        (match D.constant_strength sp with
+          | DK.Local  -> false (* a local definition *)
+          | DK.Global -> true  (* a non-local one    *)
+        )
+    | "INDUCTIVE"       -> true   (* mutual inductive types are never local   *)
+    | "VARIABLE"        -> false  (* variables are local, so no namesakes     *)
+    | _                 -> false  (* uninteresting thing that won't be printed*)
+;;
+
+
+(* A SIMPLE DATA STRUCTURE AND SOME FUNCTIONS TO MANAGE THE CURRENT *)
+(* ENVIRONMENT (= [(name1,l1); ...;(namen,ln)] WHERE li IS THE LIST *)
+(* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT   *)
+(* SECTION, WHOSE PATH IS namei                                     *)
+
+let pvars =
+ ref ([Names.id_of_string "",[]] : (Names.identifier * string list) list);;
+let cumenv = ref Environ.empty_env;;
+
+(* filter_params pvars hyps *)
+(* filters out from pvars (which is a list of lists) all the variables *)
+(* that does not belong to hyps (which is a simple list)               *)
+(* It returns a list of couples relative section path -- list of       *)
+(* variable names.                                                     *)
+let filter_params pvars hyps =
+ let rec aux ids =
+  function
+     [] -> []
+   | (id,he)::tl ->
+      let ids' = id::ids in
+      let ids'' =
+       "cic:/" ^
+        String.concat "/" (List.rev (List.map Names.string_of_id ids')) in
+      let he' =
+       ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in
+      let tl' = aux ids' tl in
+       match he' with
+          _,[] -> tl'
+        | _,_  -> he'::tl'
+ in
+  let cwd = Lib.cwd () in
+  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
+  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
+   aux (Names.repr_dirpath modulepath) (List.rev pvars)
+;;
+
+type variables_type = 
+   Definition of string * Term.constr * Term.types
+ | Assumption of string * Term.constr
+;;
+
+let add_to_pvars x =
+ let module E = Environ in
+  let v =
+   match x with
+      Definition (v, bod, typ) ->
+       cumenv :=
+         E.push_named (Names.id_of_string v, Some bod, typ) !cumenv ;
+       v
+    | Assumption (v, typ) ->
+       cumenv :=
+         E.push_named (Names.id_of_string v, None, typ) !cumenv ;
+       v
+  in
+   match !pvars with
+      []       -> assert false
+    | ((name,l)::tl) -> pvars := (name,v::l)::tl
+;;
+
+(* The computation is very inefficient, but we can't do anything *)
+(* better unless this function is reimplemented in the Declare   *)
+(* module.                                                       *)
+let search_variables () =
+ let module N = Names in
+  let cwd = Lib.cwd () in
+  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
+  let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in
+   let rec aux =
+    function
+       [] -> []
+     | he::tl as modules ->
+        let one_section_variables =
+         let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in
+          let t = List.map N.string_of_id (Declare.last_section_hyps dirpath) in
+           [he,t]
+        in
+         one_section_variables @ aux tl
+   in
+    aux
+     (Cic2acic.remove_module_dirpath_from_dirpath
+       ~basedir:modulepath cwd)
+;;
+
+(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *)
+
+let rec join_dirs cwd =
+ function
+    []  -> cwd
+  | he::tail ->
+      (try
+        Unix.mkdir cwd 0o775
+       with _ -> () (* Let's ignore the errors on mkdir *)
+      ) ;
+     let newcwd = cwd ^ "/" ^ he in
+      join_dirs newcwd tail
+;;
+
+let filename_of_path xml_library_root kn 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
+       Some (join_dirs xml_library_root' tokens)
+;;
+
+let body_filename_of_filename =
+ function
+    Some f -> Some (f ^ ".body")
+  | None   -> None
+;;
+
+let types_filename_of_filename =
+ function
+    Some f -> Some (f ^ ".types")
+  | None   -> None
+;;
+
+let prooftree_filename_of_filename =
+ function
+    Some f -> Some (f ^ ".proof_tree")
+  | None   -> None
+;;
+
+let theory_filename xml_library_root =
+ let module N = Names in
+  match xml_library_root with
+    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")
+
+let print_object uri obj sigma proof_tree_infos filename =
+ (* function to pretty print and compress an XML file *)
+(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *)
+ let pp xml filename =
+  Xml.pp xml filename ;
+  match filename with
+     None -> ()
+   | Some fn ->
+      let fn' =
+       let rec escape s n =
+        try
+         let p = String.index_from s n '\'' in
+          String.sub s n (p - n) ^ "\\'" ^ escape s (p+1)
+        with Not_found -> String.sub s n (String.length s - n)
+       in
+        escape fn 0
+      in
+       ignore (Unix.system ("gzip " ^ fn' ^ ".xml"))
+ in
+  let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) =
+   Cic2acic.acic_object_of_cic_object !pvars sigma obj in
+  let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in
+  let xmltypes =
+   Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in
+  pp xml filename ;
+  begin
+   match xml' with
+      None -> ()
+    | Some xml' -> pp xml' (body_filename_of_filename filename)
+  end ;
+  pp xmltypes (types_filename_of_filename filename) ;
+  match proof_tree_infos with
+     None -> ()
+   | Some (sigma0,proof_tree,proof_tree_to_constr,
+           proof_tree_to_flattened_proof_tree) ->
+      let xmlprooftree =
+       print_proof_tree ()
+        uri sigma0 proof_tree proof_tree_to_constr
+        proof_tree_to_flattened_proof_tree constr_to_ids
+      in
+       match xmlprooftree with
+          None -> ()
+        | Some xmlprooftree ->
+           pp xmlprooftree (prooftree_filename_of_filename filename)
+;;
+
+let string_list_of_named_context_list =
+ List.map
+  (function (n,_,_) -> Names.string_of_id n)
+;;
+
+(* Function to collect the variables that occur in a term. *)
+(* Used only for variables (since for constants and mutual *)
+(* inductive types this information is already available.  *)
+let find_hyps t =
+ let module T = Term in
+  let rec aux l t =
+   match T.kind_of_term t with
+      T.Var id when not (List.mem id l) ->
+       let (_,bo,ty) = Global.lookup_named id in
+        let boids = 
+         match bo with
+            Some bo' -> aux l bo'
+          | None -> l
+        in
+         id::(aux boids ty)
+    | T.Var _
+    | T.Rel _
+    | T.Meta _
+    | T.Evar _
+    | T.Sort _ -> l
+    | 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
+    | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl
+    | T.Const con ->
+       let hyps = (Global.lookup_constant con).Declarations.const_hyps in
+        map_and_filter l hyps @ l
+    | T.Ind ind
+    | T.Construct (ind,_) ->
+       let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in
+        map_and_filter l hyps @ l
+    | T.Case (_,t1,t2,b) ->
+       Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b
+    | T.Fix (_,(_,tys,bodies))
+    | T.CoFix (_,(_,tys,bodies)) ->
+       let r = Array.fold_left (fun i x -> aux i x) l tys in
+        Array.fold_left (fun i x -> aux i x) r bodies
+  and map_and_filter l =
+   function
+      [] -> []
+    | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl)
+    | _::tl -> map_and_filter l tl
+  in
+   aux [] t
+;;
+
+(* Functions to construct an object *)
+
+let mk_variable_obj id body typ =
+ let hyps,unsharedbody =
+  match body with
+     None -> [],None
+   | Some bo -> find_hyps bo, Some (Unshare.unshare bo)
+ in
+  let hyps' = find_hyps typ @ hyps in
+  let hyps'' = List.map Names.string_of_id hyps' in
+  let variables = search_variables () in
+  let params = filter_params variables hyps'' in
+   Acic.Variable
+    (Names.string_of_id id, unsharedbody,
+     (Unshare.unshare (Term.body_of_type typ)), params)
+;;
+
+(* Unsharing is not performed on the body, that must be already unshared. *)
+(* The evar map and the type, instead, are unshared by this function.     *)
+let mk_current_proof_obj is_a_variable id bo ty evar_map env =
+ let unshared_ty = Unshare.unshare (Term.body_of_type ty) in
+ let metasenv =
+  List.map
+   (function
+     (n, {Evd.evar_concl = evar_concl ;
+          Evd.evar_hyps = evar_hyps}
+      ) ->
+       (* We map the named context to a rel context and every Var to a Rel *)
+       let final_var_ids,context =
+        let rec aux var_ids =
+         function
+            [] -> var_ids,[]
+          | (n,None,t)::tl ->
+              let final_var_ids,tl' = aux (n::var_ids) tl in
+              let t' = Term.subst_vars var_ids t in
+               final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl'
+          | (n,Some b,t)::tl ->
+              let final_var_ids,tl' = aux (n::var_ids) tl in
+              let b' = Term.subst_vars var_ids b in
+               (* 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)
+       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)
+ in
+  let id' = Names.string_of_id id in
+   if metasenv = [] then
+    let ids =
+     Names.Idset.union
+      (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in
+    let hyps0 = Environ.keep_hyps env ids in
+    let hyps = string_list_of_named_context_list hyps0 in
+    (* Variables are the identifiers of the variables in scope *)
+    let variables = search_variables () in
+    let params = filter_params variables hyps in
+     if is_a_variable then
+      Acic.Variable (id',Some bo,unshared_ty,params)
+     else
+      Acic.Constant (id',Some bo,unshared_ty,params)
+   else
+    Acic.CurrentProof (id',metasenv,bo,unshared_ty)
+;;
+
+let mk_constant_obj id bo ty variables hyps =
+ let hyps = string_list_of_named_context_list hyps in
+ let ty = Unshare.unshare (Term.body_of_type ty) in
+ let params = filter_params variables hyps in
+  match bo with
+     None ->
+      Acic.Constant (Names.string_of_id id,None,ty,params)
+   | Some c ->
+      Acic.Constant
+       (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)),
+         ty,params)
+;;
+
+let mk_inductive_obj sp packs variables 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 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
+       in
+        let lc = Inductive.arities_of_constructors (Global.env ()) (sp,!tyno) in
+        let cons =
+         (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
+          (Array.mapi
+           (fun j x ->(x,Unshare.unshare (Term.body_of_type lc.(j)))) consnames)
+          []
+         )
+        in
+         (typename,finite,Unshare.unshare arity,cons)::i
+     ) packs []
+   in
+    Acic.InductiveDefinition (tys,params,nparams)
+;;
+
+(* The current channel for .theory files *)
+let theory_buffer = Buffer.create 4000;;
+
+let theory_output_string ?(do_not_quote = false) s = 
+  (* prepare for coqdoc post-processing *)
+  let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
+  print_if_verbose 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
+
+let kind_of_inductive isrecord kn =
+ "DEFINITION",
+ if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
+ then if isrecord then "Record" else "Inductive"
+ else "CoInductive"
+;;
+
+let kind_of_variable id =
+  let module DK = Decl_kinds in
+  match Declare.variable_kind id with
+    | 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"
+;;
+
+let kind_of_constant kn = 
+  let module DK = Decl_kinds in
+  match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with
+    | 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
+;;
+
+let kind_of_global r =
+  let module Ln = Libnames in
+  let module DK = Decl_kinds in
+  match r with
+  | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> 
+      let isrecord =
+	try let _ = Recordops.find_structure kn in true
+        with Not_found -> false in
+      kind_of_inductive isrecord (fst kn)
+  | Ln.VarRef id -> kind_of_variable id
+  | Ln.ConstRef kn -> kind_of_constant kn
+;;
+
+let print_object_kind uri (xmltag,variation) =
+  let s =
+    Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation
+  in
+  theory_output_string s
+;;
+
+(* print id dest                                                          *)
+(*  where sp   is the qualified identifier (section path) of a            *)
+(*             definition/theorem, variable or inductive definition       *)
+(*  and   dest is either None (for stdout) or (Some filename)             *)
+(* pretty prints via Xml.pp the object whose identifier is id on dest     *)
+(* Note: it is printed only (and directly) the most cooked available      *)
+(*       form of the definition (all the parameters are                   *)
+(*       lambda-abstracted, but the object can still refer to variables)  *)
+let print internal glob_ref kind xml_library_root =
+ let module D = Declarations in
+ let module De = Declare in
+ let module G = Global in
+ let module N = Names in
+ let module Nt = Nametab in
+ let module T = Term in
+ let module X = Xml in
+ let module Ln = Libnames in
+  (* Variables are the identifiers of the variables in scope *)
+  let variables = search_variables () in
+  let kn,tag,obj =
+   match glob_ref with
+      Ln.VarRef id ->
+       let sp = Declare.find_section_variable id in
+       (* this kn is fake since it is not provided by Coq *)
+       let kn = 
+        let (mod_path,dir_path) = Lib.current_prefix () in
+        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
+    | Ln.ConstRef kn ->
+       let id = N.id_of_label (N.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
+    | Ln.IndRef (kn,_) ->
+       let {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
+    | Ln.ConstructRef _ ->
+       Util.anomaly ("print: this should not happen")
+  in
+  let fn = filename_of_path xml_library_root kn tag in
+  let uri = Cic2acic.uri_of_kernel_name kn tag in
+   if not internal then print_object_kind uri kind;
+   print_object uri obj Evd.empty None fn
+;;
+
+let print_ref qid fn =
+  let ref = Nametab.global qid in
+  print false ref (kind_of_global ref) fn
+
+(* show dest                                                  *)
+(*  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
+ let uri =
+  match kind with
+     Decl_kinds.IsLocal ->
+      let uri =
+       "cic:/" ^ String.concat "/"
+        (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.Variable) 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
+       if not internal then print_object_kind uri (kind_of_global_goal kind);
+       uri
+ in
+  print_object uri obj evar_map
+   (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr,
+    proof_tree_to_flattened_proof_tree)) fn
+;;
+
+let show fn =
+ let pftst = Pfedit.get_pftreestate () in
+ let (id,kind,_,_) = Pfedit.current_proof_statement () in
+  show_pftreestate false fn (kind,pftst) id
+;;
+
+
+(* Let's register the callbacks *)
+let xml_library_root =
+  try
+   Some (Sys.getenv "COQ_XML_LIBRARY_ROOT")
+  with Not_found -> None
+;;
+
+let proof_to_export = ref None (* holds the proof-tree to export *)
+;;
+
+let _ =
+  Pfedit.set_xml_cook_proof
+   (function pftreestate -> proof_to_export := Some pftreestate)
+;;
+
+let _ =
+  Declare.set_xml_declare_variable
+   (function (sp,kn) ->
+     let id = Libnames.basename sp in
+     print false (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
+     proof_to_export := None)
+;;
+
+let _ =
+  Declare.set_xml_declare_constant
+   (function (internal,(sp,kn)) ->
+     match !proof_to_export with
+        None ->
+          print internal (Libnames.ConstRef kn) (kind_of_constant kn) 
+	    xml_library_root
+      | 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
+         show_pftreestate internal fn pftreestate 
+	  (Names.id_of_label (Names.label kn)) ;
+         proof_to_export := None)
+;;
+
+let _ =
+  Declare.set_xml_declare_inductive
+   (function (isrecord,(sp,kn)) ->
+      print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) 
+        xml_library_root)
+;;
+
+let _ =
+  Vernac.set_xml_start_library
+   (function () ->
+     Buffer.reset theory_buffer;
+     theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n";
+     theory_output_string ("<!DOCTYPE html [\n" ^
+      "<!ENTITY % xhtml-lat1.ent    SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^
+      "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^
+      "<!ENTITY % xhtml-symbol.ent  SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^
+      "%xhtml-lat1.ent;\n" ^
+      "%xhtml-special.ent;\n" ^
+      "%xhtml-symbol.ent;\n" ^
+      "]>\n\n");
+     theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n";
+     theory_output_string "<head></head>\n<body>\n")
+;;
+
+let _ =
+  Vernac.set_xml_end_library
+   (function () ->
+      theory_output_string "</body>\n</html>\n";
+      let ofn = theory_filename xml_library_root in
+       begin
+        match ofn with
+           None ->
+             Buffer.output_buffer stdout theory_buffer ;
+         | Some fn ->
+            let ch = open_out (fn ^ ".v") in
+             Buffer.output_buffer ch theory_buffer ;
+             close_out ch
+       end ;
+       Util.option_iter 
+	(fun fn ->
+	  let coqdoc = Coq_config.bindir^"/coqdoc" in
+	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
+	  let dir = Util.out_some xml_library_root in
+          let command cmd =
+           if Sys.command cmd <> 0 then
+            Util.anomaly ("Error executing \"" ^ cmd ^ "\"")
+          in
+           command (coqdoc^options^" -d "^dir^" "^fn^".v");
+           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"))
+       ofn)
+;;
+
+let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
+
+let uri_of_dirpath dir =
+  "/" ^ String.concat "/" 
+    (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
+;;
+
+let _ =
+  Lib.set_xml_open_section
+    (fun _ ->
+      let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in
+      theory_output_string ("<ht:SECTION uri=\""^s^"\">"))
+;;
+
+let _ =
+  Lib.set_xml_close_section
+    (fun _ -> theory_output_string "</ht:SECTION>")
+;;
+
+let _ =
+  Library.set_xml_require
+    (fun d -> theory_output_string 
+      (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
+       (uri_of_dirpath d) (Names.string_of_dirpath d)))
+;;
diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli
new file mode 100644
index 00000000..9a7464bd
--- /dev/null
+++ b/contrib/xml/xmlcommand.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(*i $Id: xmlcommand.mli,v 1.18.2.2 2004/07/16 19:30:15 herbelin Exp $ i*)
+
+(* print_global qid fn                                                    *)
+(*  where qid  is a long name denoting a definition/theorem or            *)
+(*             an inductive definition                                    *)
+(*  and   dest is either None (for stdout) or (Some filename)             *)
+(* pretty prints via Xml.pp the object whose name is ref on dest          *)
+(* Note: it is printed only (and directly) the most discharged available  *)
+(*       form of the definition (all the parameters are                   *)
+(*       lambda-abstracted, but the object can still refer to variables)  *)
+val print_ref : Libnames.reference -> string option -> unit
+
+(* show dest                                                  *)
+(*  where dest is either None (for stdout) or (Some filename) *)
+(* pretty prints via Xml.pp the proof in progress on dest     *)
+val show : string option -> unit
+
+(* set_print_proof_tree f                                      *)
+(*  sets a callback function f to export the proof_tree to XML *)
+val set_print_proof_tree :
+    (string ->
+     Evd.evar_map ->
+     Proof_type.proof_tree ->
+     Term.constr Proof2aproof.ProofTreeHash.t ->
+     Proof_type.proof_tree Proof2aproof.ProofTreeHash.t ->
+     string Acic.CicHash.t -> Xml.token Stream.t) ->
+    unit
diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4
new file mode 100644
index 00000000..2bc686f7
--- /dev/null
+++ b/contrib/xml/xmlentries.ml4
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
+(*         *   University of Bologna                                    *)
+(************************************************************************)
+(*          This file is distributed under the terms of the             *)
+(*           GNU Lesser General Public License Version 2.1              *)
+(*                                                                      *)
+(*                 Copyright (C) 2000-2004, HELM Team.                  *)
+(*                       http://helm.cs.unibo.it                        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: xmlentries.ml4,v 1.12.2.2 2004/07/16 19:30:15 herbelin Exp $ *)
+
+open Util;;
+open Vernacinterp;;
+
+open Extend;;
+open Genarg;;
+open Pp;;
+open Pcoq;;
+
+(* File name *)
+
+VERNAC ARGUMENT EXTEND filename
+| [ "File" string(fn) ] -> [ Some fn ]
+| [ ] -> [ None ]
+END
+
+(* Print XML and Show XML *)
+
+VERNAC COMMAND EXTEND Xml
+| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ]
+
+| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ]
+END
diff --git a/contrib7/cc/CCSolve.v b/contrib7/cc/CCSolve.v
new file mode 100644
index 00000000..388763ed
--- /dev/null
+++ b/contrib7/cc/CCSolve.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: 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
new file mode 100644
index 00000000..4a0025ca
--- /dev/null
+++ b/contrib7/correctness/ArrayPermut.v
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..3fdc78c1
--- /dev/null
+++ b/contrib7/correctness/Arrays.v
@@ -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        *)
+(************************************************************************)
+
+(* 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/Arrays_stuff.v b/contrib7/correctness/Arrays_stuff.v
new file mode 100644
index 00000000..448b0ab6
--- /dev/null
+++ b/contrib7/correctness/Arrays_stuff.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+
+Require Export Exchange.
+Require Export ArrayPermut.
+Require Export Sorted.
+
diff --git a/contrib7/correctness/Correctness.v b/contrib7/correctness/Correctness.v
new file mode 100644
index 00000000..b0fde165
--- /dev/null
+++ b/contrib7/correctness/Correctness.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: Correctness.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+
+(* 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 "'".
+*)
diff --git a/contrib7/correctness/Exchange.v b/contrib7/correctness/Exchange.v
new file mode 100644
index 00000000..12c8c9de
--- /dev/null
+++ b/contrib7/correctness/Exchange.v
@@ -0,0 +1,94 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c7a7687d
--- /dev/null
+++ b/contrib7/correctness/ProgBool.v
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/ProgInt.v b/contrib7/correctness/ProgInt.v
new file mode 100644
index 00000000..0ca830c2
--- /dev/null
+++ b/contrib7/correctness/ProgInt.v
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
+
+(* $Id: ProgInt.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+
+Require Export ZArith.
+Require Export ZArith_dec.
+
+Theorem Znotzero : (x:Z){`x<>0`}+{`x=0`}.
+Proof.
+Intro x. Elim (Z_eq_dec x `0`) ; Auto.
+Save.
diff --git a/contrib7/correctness/ProgramsExtraction.v b/contrib7/correctness/ProgramsExtraction.v
new file mode 100644
index 00000000..20f82ce4
--- /dev/null
+++ b/contrib7/correctness/ProgramsExtraction.v
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/Programs_stuff.v b/contrib7/correctness/Programs_stuff.v
new file mode 100644
index 00000000..00beeaeb
--- /dev/null
+++ b/contrib7/correctness/Programs_stuff.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Programs_stuff.v,v 1.1.2.1 2004/07/16 19:30:16 herbelin Exp $ *)
+
+Require Export Arrays_stuff.
diff --git a/contrib7/correctness/Sorted.v b/contrib7/correctness/Sorted.v
new file mode 100644
index 00000000..f476142e
--- /dev/null
+++ b/contrib7/correctness/Sorted.v
@@ -0,0 +1,198 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..6e1eb03a
--- /dev/null
+++ b/contrib7/correctness/Tuples.v
@@ -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        *)
+(************************************************************************)
+
+(* 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
new file mode 100644
index 00000000..33659b43
--- /dev/null
+++ b/contrib7/correctness/preuves.v
@@ -0,0 +1,128 @@
+
+(* 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
new file mode 100644
index 00000000..e76b1c69
--- /dev/null
+++ b/contrib7/extraction/test_extraction.v
@@ -0,0 +1,533 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.v b/contrib7/field/Field.v
new file mode 100644
index 00000000..f282e246
--- /dev/null
+++ b/contrib7/field/Field.v
@@ -0,0 +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        *)
+(************************************************************************)
+
+(* $Id: Field.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
+
+Require Export Field_Compl.
+Require Export Field_Theory.
+Require Export Field_Tactic.
+
+(* Command declarations are moved to the ML side *)
diff --git a/contrib7/field/Field_Compl.v b/contrib7/field/Field_Compl.v
new file mode 100644
index 00000000..2cc01038
--- /dev/null
+++ b/contrib7/field/Field_Compl.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        *)
+(************************************************************************)
+
+(* $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
new file mode 100644
index 00000000..ffd2aad4
--- /dev/null
+++ b/contrib7/field/Field_Tactic.v
@@ -0,0 +1,397 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..3ba2fbc0
--- /dev/null
+++ b/contrib7/field/Field_Theory.v
@@ -0,0 +1,612 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.v b/contrib7/fourier/Fourier.v
new file mode 100644
index 00000000..740bbef6
--- /dev/null
+++ b/contrib7/fourier/Fourier.v
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: Fourier.v,v 1.1.2.1 2004/07/16 19:30:17 herbelin Exp $ *)
+
+(* "Fourier's method to solve linear inequations/equations systems.".*)
+
+Declare ML Module "quote".
+Declare ML Module "ring".
+Declare ML Module "fourier".
+Declare ML Module "fourierR".
+Declare ML Module "field".
+
+Require Export Fourier_util.
+Require Export Field.
+Require Export DiscrR.
+
+Tactic Definition Fourier  :=
+  Abstract (FourierZ;Field;DiscrR).
+
+Tactic Definition FourierEq  :=
+  Apply Rge_ge_eq ; Fourier.
+
diff --git a/contrib7/fourier/Fourier_util.v b/contrib7/fourier/Fourier_util.v
new file mode 100644
index 00000000..be22e2ff
--- /dev/null
+++ b/contrib7/fourier/Fourier_util.v
@@ -0,0 +1,236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d22b7ed1
--- /dev/null
+++ b/contrib7/interface/AddDad.v
@@ -0,0 +1,19 @@
+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
new file mode 100644
index 00000000..d27929f8
--- /dev/null
+++ b/contrib7/interface/Centaur.v
@@ -0,0 +1,88 @@
+(*
+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
new file mode 100644
index 00000000..f95c4212
--- /dev/null
+++ b/contrib7/interface/vernacrc
@@ -0,0 +1,17 @@
+# $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
new file mode 100644
index 00000000..76e37519
--- /dev/null
+++ b/contrib7/omega/Omega.v
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..0d05fc3e
--- /dev/null
+++ b/contrib7/omega/OmegaLemmas.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c2abc4d1
--- /dev/null
+++ b/contrib7/ring/ArithRing.v
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..f4548bbb
--- /dev/null
+++ b/contrib7/ring/NArithRing.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        *)
+(************************************************************************)
+
+(* $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
new file mode 100644
index 00000000..12a51c9f
--- /dev/null
+++ b/contrib7/ring/Quote.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..860dda13
--- /dev/null
+++ b/contrib7/ring/Ring.v
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..55bb31da
--- /dev/null
+++ b/contrib7/ring/Ring_abstract.v
@@ -0,0 +1,699 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..1dbd9d56
--- /dev/null
+++ b/contrib7/ring/Ring_normalize.v
@@ -0,0 +1,893 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..85fb7f6c
--- /dev/null
+++ b/contrib7/ring/Ring_theory.v
@@ -0,0 +1,384 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.v b/contrib7/ring/Setoid_ring.v
new file mode 100644
index 00000000..222104e5
--- /dev/null
+++ b/contrib7/ring/Setoid_ring.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.v,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+
+Require Export Setoid_ring_theory.
+Require Export Quote.
+Require Export Setoid_ring_normalize.
diff --git a/contrib7/ring/Setoid_ring_normalize.v b/contrib7/ring/Setoid_ring_normalize.v
new file mode 100644
index 00000000..b6b79dae
--- /dev/null
+++ b/contrib7/ring/Setoid_ring_normalize.v
@@ -0,0 +1,1141 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..13afc5ee
--- /dev/null
+++ b/contrib7/ring/Setoid_ring_theory.v
@@ -0,0 +1,429 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..fc7ef29f
--- /dev/null
+++ b/contrib7/ring/ZArithRing.v
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..7ee246c7
--- /dev/null
+++ b/contrib7/romega/ROmega.v
@@ -0,0 +1,12 @@
+(*************************************************************************
+
+   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
new file mode 100644
index 00000000..81baa8d9
--- /dev/null
+++ b/contrib7/romega/ReflOmegaCore.v
@@ -0,0 +1,2602 @@
+(*************************************************************************
+
+   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/dev/Makefile.common b/dev/Makefile.common
new file mode 100644
index 00000000..1ff5cf79
--- /dev/null
+++ b/dev/Makefile.common
@@ -0,0 +1,52 @@
+# 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.devel b/dev/Makefile.devel
new file mode 100644
index 00000000..f3abb62d
--- /dev/null
+++ b/dev/Makefile.devel
@@ -0,0 +1,74 @@
+# to be linked to makefile (lowercase - takes precedence over Makefile)
+# in main directory
+# make devel in main directory should do this for you.
+
+TOPDIR=.
+BASEDIR=
+
+SOURCEDIRS=lib kernel library pretyping parsing proofs tactics toplevel
+
+default:	usage noargument
+
+usage::
+	@echo Usage: make \<target\>
+	@echo Targets are:
+
+usage::
+	@echo "  setup-devel	-- set the devel makefile"
+setup-devel:
+	@ln -sfv dev/Makefile.devel makefile
+	@(for i in $(SOURCEDIRS); do \
+	    (cd $(TOPDIR)/$$i; ln -sfv ../dev/Makefile.dir Makefile) \
+	done)
+
+
+usage::
+	@echo "  clean-devel	-- clear all devel files"
+clean-devel:
+	echo rm -f makefile .depend.devel
+	echo rm -f $(foreach dir,$(SOURCEDIRS), $(TOPDIR)/$(dir)/Makefile)
+
+
+usage::
+	@echo "  coqtop	-- make until the bytecode executable, make the link"
+coqtop:	bin/coqtop.byte
+	ln -sf bin/coqtop.byte coqtop
+
+
+usage::
+	@echo "  quick		-- make bytecode executable and states"
+quick: 
+	$(MAKE) states BEST=byte
+
+include Makefile
+
+include $(TOPDIR)/dev/Makefile.common
+
+# this file is better described in dev/Makefile.dir
+include .depend.devel
+
+#if dev/Makefile.local exists, it is included
+ifneq ($(wildcard $(TOPDIR)/dev/Makefile.local),)
+include $(TOPDIR)/dev/Makefile.local
+endif
+
+
+usage::
+	@echo "  total		-- runs coqtop with all theories required"
+total:
+	ledit ./bin/coqtop.byte $(foreach th,$(THEORIESVO),-require $(notdir $(basename $(th))))
+
+
+usage::
+	@echo "  run		-- makes and runs bytecode coqtop using ledit and the history file"
+	@echo "		   if you want to pass arguments to coqtop, use make run ARG=<args>"
+run:	$(TOPDIR)/coqtop
+	ledit -h $(TOPDIR)/dev/debug_history -x $(TOPDIR)/coqtop $(ARG) $(ARGS)
+
+
+usage::
+	@echo "  vars		-- echos commands to set COQTOP and COQBIN variables"
+vars:
+	@(cd $(TOPDIR); \
+	echo export COQTOP=`pwd`/ ; \
+	echo export COQBIN=`pwd`/bin/ )
\ No newline at end of file
diff --git a/dev/Makefile.dir b/dev/Makefile.dir
new file mode 100644
index 00000000..54f7bfe9
--- /dev/null
+++ b/dev/Makefile.dir
@@ -0,0 +1,131 @@
+# 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
+# this Makefile provides many useful facilities to develop Coq
+# it is not completely compatible with .ml4 files unfortunately
+
+ifndef TOPDIR
+TOPDIR=..
+endif
+
+# this complicated thing should work for subsubdirs as well
+BASEDIR=$(shell (dir=`pwd`; cd $(TOPDIR); top=`pwd`; echo $$dir | sed -e "s|$$top/||"))
+
+noargs:	dir
+
+test-dir:
+	@echo TOPDIR=$(TOPDIR)
+	@echo BASEDIR=$(BASEDIR)
+
+include $(TOPDIR)/dev/Makefile.common
+
+# make this directory
+dir:
+	$(MAKE) -C $(TOPDIR) $(notdir $(BASEDIR))
+
+# make all cmo's in this directory. Useful in case the main Makefile is not
+# up-to-date
+all:	
+	@( ( for i in *.ml; do \
+	       echo -n $(BASEDIR)/`basename $$i .ml`.cmo "" ; \
+	     done; \
+	     for i in *.ml4; do \
+	       echo -n $(BASEDIR)/`basename $$i .ml4`.cmo "" ; \
+	     done ) \
+	  | xargs $(MAKE) -C $(TOPDIR) )
+
+# lists all files that should be compiled in this directory
+list:
+	@(for i in *.mli; do \
+	   ls -l `basename $$i .mli`.cmi; \
+	done)
+	@(for i in *.ml; do \
+	   ls -l `basename $$i .ml`.cmo; \
+	done)
+	@(for i in *.ml4; do \
+	   ls -l `basename $$i .ml4`.cmo; \
+	done)
+
+
+clean::  
+	rm -f *.cmi *.cmo *.cmx *.o
+
+
+# if grammar.cmo files cannot be compiled and main .depend cannot be
+# rebuilt, this is quite useful
+depend:
+	(cd $(TOPDIR); ocamldep -I $(BASEDIR) $(BASEDIR)/*.ml $(BASEDIR)/*.mli > .depend.devel)
+
+
+# displays the dependency graph of the current directory (vertically,
+# unlike in doc/)
+graph:
+	(ocamldep *.ml *.mli | ocamldot | dot -Tps | gv -) &
+
+
+# the pretty entry draws a dependency graph marking red those nodes
+# which do not have their .cmo files 
+
+.INTERMEDIATE: depend.dot depend.2.dot
+.PHONY: depend.ps
+
+depend.dot:
+	ocamldep *.ml *.mli | ocamldot > $@
+
+depend.2.dot:	depend.dot
+	(i=`cat $< | wc -l`; i=`expr $$i - 1`; head -n $$i $<) > $@
+	(for ml in *.ml; do \
+	   base=`basename $$ml .ml`; \
+	   fst=`echo $$base | cut -c1 | tr [:lower:] [:upper:]`; \
+	   rest=`echo $$base | cut -c2-`; \
+	   name=`echo $$fst $$rest | tr -d " "`; \
+	   cmo=$$base.cmo; \
+	   if [ ! -e $$cmo ]; then \
+	     echo \"$$name\" [color=red]\; >> $@;\
+	   fi;\
+         done;\
+	 echo } >> $@)
+
+depend.ps:	depend.2.dot
+	dot -Tps $< > $@
+
+clean::
+	rm -f depend.ps
+
+pretty:	depend.ps
+	(gv -spartan $<; rm $<) &
+#	gv -spartan $< &
+
+
+
+# generating file.ml.mli by tricking make to pass -i to ocamlc 
+
+%.ml.mli:	FORCE
+	@(cmo=`basename $@ .ml.mli`.cmo ; \
+	mv -f $$cmo $$cmo.tmp ; \
+	$(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-i > $@ ; \
+	echo Generated interface file $@ ; \
+	mv -f $$cmo.tmp $$cmo)
+
+%.annot:	FORCE
+	@(cmo=`basename $@ .annot`.cmo ; \
+	mv -f $$cmo $$cmo.tmp ; \
+	$(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-dtypes ; \
+	echo Generated annotation file $@ ; \
+	mv -f $$cmo.tmp $$cmo)
+
+FORCE:
+
+clean::
+	rm -f *.ml.mli
+
+# this is not perfect but mostly WORKS! It just calls the main makefile
+
+%.cmi:	FORCE
+	$(MAKE) -C $(TOPDIR) $(BASEDIR)/$@
+
+%.cmo:	FORCE
+	$(MAKE) -C $(TOPDIR) $(BASEDIR)/$@
+
+coqtop:	
+	$(MAKE) -C $(TOPDIR) bin/coqtop.byte
diff --git a/dev/Makefile.subdir b/dev/Makefile.subdir
new file mode 100644
index 00000000..45358c42
--- /dev/null
+++ b/dev/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/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
new file mode 100644
index 00000000..a8811bea
--- /dev/null
+++ b/dev/README
@@ -0,0 +1,21 @@
+This directory contains informations and tools to help developping the
+Coq system
+
+
+TODO
+changements.txt
+header
+lisezmoi.txt			   
+style.txt			   
+
+Debugging and profiling
+=======================
+
+debugging.txt: help for debugging or profiling
+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
+base_include: to install raw pretty-printers from ocaml toplevel
+universes.txt: help to debug universes
+univdot: produces a graph of CIC universes
diff --git a/dev/TODO b/dev/TODO
new file mode 100644
index 00000000..926861c9
--- /dev/null
+++ b/dev/TODO
@@ -0,0 +1,22 @@
+
+ o options de la ligne de commande
+     - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml
+
+ o arguments implicites
+     - les calculer une fois pour toutes à la déclaration (dans Declare)
+       et stocker cette information dans le in_variable, in_constant, etc.
+
+ o Environnements compilés (type Environ.compiled_env)
+     - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?)
+
+ o Efficacité
+     - utiliser DOPL plutôt que DOPN (sauf pour Case)
+     - batch mode => pas de undo, ni de reset
+     - conversion : déplier la constante la plus récente
+     - un cache pour type_of_const, type_of_inductive, type_of_constructor,
+       lookup_mind_specif
+
+ o Toplevel
+     - parsing de la ligne de commande : utiliser Arg ???
+
+
diff --git a/dev/base_db b/dev/base_db
new file mode 100644
index 00000000..b540aed6
--- /dev/null
+++ b/dev/base_db
@@ -0,0 +1,6 @@
+load_printer "gramlib.cma"
+load_printer "top_printers.cmo"
+install_printer Top_printers.prid
+install_printer Top_printers.prsp
+install_printer Top_printers.print_pure_constr
+
diff --git a/dev/base_include b/dev/base_include
new file mode 100644
index 00000000..17293776
--- /dev/null
+++ b/dev/base_include
@@ -0,0 +1,76 @@
+
+(* File to include to get some Coq facilities under the ocaml toplevel.
+   This file is loaded by include *)
+
+#cd".";;
+#directory "parsing";;
+#directory "interp";;
+#directory "toplevel";;
+#directory "library";;
+#directory "kernel";;
+#directory "pretyping";;
+#directory "lib";;
+#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;;
+
+(* parsing of names *)
+
+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_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;;
+
+(* 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);;
+
+(* get the body of a constant *)
+
+open Declarations;;
+
+let constbody_of_string s =
+  let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_sp (path_of_string s))) in
+  Util.out_some b.const_body;;
+
+(* Get the current goal *)
+
+let getgoal x = top_goal_of_pftreestate (Pfedit.get_pftreestate x);;
+
+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);;
+
+open Toplevel
+let go = loop
+
diff --git a/dev/changements.txt b/dev/changements.txt
new file mode 100644
index 00000000..d1df2a81
--- /dev/null
+++ b/dev/changements.txt
@@ -0,0 +1,455 @@
+CHANGES DUE TO INTRODUCTION OF MODULES
+======================================
+
+1.Kernel
+--------
+
+  The module level has no effect on constr except for the structure of
+section_path. The type of unique names for constructions (what
+section_path served) is now called a kernel name and is defined by
+ 
+type uniq_ident = int * string * dir_path (* int may be enough *)
+type module_path =
+  | MPfile of dir_path    (* reference to physical module, e.g. file *)
+  | MPbound of uniq_ident (* reference to a module parameter in a functor *)
+  | MPself of uniq_ident  (* reference to one of the containing module *)
+  | MPdot of module_path * label
+type label = identifier
+type kernel_name = module_path * dir_path * label
+                   ^^^^^^^^^^^   ^^^^^^^^   ^^^^^
+                        |           |         \
+                        |           |          the base name
+                        |           \
+                       /             the (true) section path
+   example:                          (non empty only inside open sections)
+   L = (* i.e. some file of logical name L *)
+   struct
+     module A = struct Def a = ... end
+   end
+   M = (* i.e. some file of logical name M *)
+   struct
+     Def t = ...
+     N = functor (X : sig module T = struct Def b = ... end end) -> struct
+       module O = struct
+         Def u = ...
+       end
+       Def x := ... <M>.t ... <N>.O.u ... X.T.b ... L.A.a
+ 
+   <M> and <N> are self-references, X is a bound reference and L is a
+reference to a physical module.
+ 
+  Notice that functor application is not part of a path: it must be
+named by a "module M = F(A)" declaration to be used in a kernel
+name.
+ 
+  Notice that Jacek chose a practical approach, making directories not
+modules. Another approach could have been to replace the constructor
+MPfile by a constant constructor MProot representing the root of the
+world.
+ 
+  Other relevant informations are in kernel/entries.ml (type
+module_expr) and kernel/declarations.ml (type module_body and
+module_type_body).                                                              
+
+2. Library
+----------
+
+i) tables 
+[Summaries] - the only change is the special treatment of the
+global environmet.
+
+ii) objects 
+[Libobject] declares persistent objects, given with methods:
+
+   * cache_function specifying how to add the object in the current
+       scope;
+   * load_function, specifying what to do when the module 
+       containing the object is loaded; 
+   * open_function, specifying what to do when the module 
+       containing the object is opened (imported);
+   * classify_function, specyfying what to do with the object,
+       when the current module (containing the object) is ended. 
+   * subst_function
+   * export_function, to signal end_section survival
+
+(Almost) Each of these methods is called with a parameter of type
+object_name = section_path * kernel_name
+where section_path is the full user name of the object (such as
+Coq.Init.Datatypes.Fst) and kernel_name is its substitutive internal
+version such as (MPself<Datatypes#1>,[],"Fst") (see above)
+
+
+What happens at the end of an interactive module ?
+==================================================
+(or when a file is stored and reloaded from disk)
+
+All summaries (except Global environment) are reverted to the state
+from before the beginning of the module, and:
+
+a) the objects (again, since last Declaremods.start_module or
+   Library.start_library) are classified using the classify_function.
+   To simplify consider only those who returned Substitute _ or Keep _.
+
+b) If the module is not a functor, the subst_function for each object of
+   the first group is called with the substitution 
+   [MPself "<Datatypes#1>" |-> MPfile "Coq.Init.Datatypes"].
+   Then the load_function is called for substituted objects and the
+   "keep" object. 
+   (If the module is a library the substitution is done at reloading).
+
+c) The objects which returned substitute are stored in the modtab
+   together with the self ident of the module, and functor argument
+   names if the module was a functor.
+
+   They will be used (substituted and loaded) when a command like 
+     Module M := F(N)    or
+     Module Z := N 
+   is evaluated
+
+
+The difference between "substitute" and "keep" objects
+========================================================
+i) The "keep" objects can _only_ reference other objects by section_paths
+and qualids. They do not need the substitution function.
+
+They will work after end_module (or reloading a compiled library),
+because these operations do not change section_path's
+
+They will obviously not work after Module Z:=N.
+ 
+These would typically be grammar rules, pretty printing rules etc.
+
+
+
+ii) The "substitute" objects can _only_ reference objects by
+kernel_names. They must have a valid subst_function. 
+
+They will work after end_module _and_ after Module Z:=N or 
+Module Z:=F(M).
+
+
+
+Other kinds of objects:
+iii) "Dispose" - objects which do not survive end_module
+     As a consequence, objects which reference other objects sometimes
+     by kernel_names and sometimes by section_path must be of this kind...
+
+iv) "Anticipate" - objects which must be treated individually by
+    end_module (typically "REQUIRE" objects)
+
+
+
+Writing subst_thing functions
+=============================
+The subst_thing shoud not copy the thing if it hasn't actually
+changed. There are some cool emacs macros in dev/objects.el 
+to help writing subst functions this way quickly and without errors.
+Also there are *_smartmap functions in Util.
+
+The subst_thing functions are already written for many types,
+including constr (Term.subst_mps), 
+global_reference (Libnames.subst_global),
+rawconstr (Rawterm.subst_raw) etc
+
+They are all (apart from constr, for now) written in the non-copying
+way.
+
+
+Nametab
+=======
+
+Nametab has been made more uniform. For every kind of thing there is
+only one "push" function and one "locate" function. 
+
+
+Lib
+===
+
+library_segment is now a list of object_name * library_item, where
+object_name = section_path * kernel_name (see above)
+
+New items have been added for open modules and module types
+
+
+Declaremods
+==========
+Functions to declare interactive and noninteractive modules and module
+types.
+
+
+Library
+=======
+Uses Declaremods to actually communicate with Global and to register
+objects.
+
+
+MAIN CHANGES FROM COQ V7.3
+==========================
+
+Internal representation of tactics bindings has changed (see type
+Rawterm.substitution).
+
+New parsing model for tactics and vernacular commands
+
+  - Introduction of a dedicated type for tactic expressions
+    (Tacexpr.raw_tactic_expr)
+  - Introduction of a dedicated type for vernac expressions
+    (Vernacexpr.vernac_expr)
+  - Declaration of new vernacular parsing rules by a new camlp4 macro
+    GRAMMAR COMMAND EXTEND ... END  to be used in ML files
+  - Declaration of new tactics parsing/printing rules by a new camlp4 macro
+    TACTIC EXTEND ... END  to be used in ML files
+
+New organisation of THENS:
+tclTHENS tac tacs : tacs is now an array
+tclTHENSFIRSTn tac1 tacs tac2 :
+  apply tac1 then, apply the array tacs on the first n subgoals and
+  tac2 on the remaining subgoals (previously tclTHENST)
+tclTHENSLASTn tac1 tac2 tacs :
+  apply tac1 then, apply tac2 on the first subgoals and apply the array
+  tacs on the last n subgoals
+tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI)
+tclTHENLASTn tac1 tacs  = tclTHENSLASTn tac1 tclIDTAC tacs
+tclTHENFIRST tac1 tac2  = tclTHENFIRSTn tac1 [|tac2|]
+tclTHENLAST tac1 tac2   = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL)
+tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number")
+tclTHENSV same as tclTHENS but with an array
+tclTHENSi : no longer available
+
+Proof_type: subproof field in type proof_tree glued with the ref field
+
+Tacmach: no more echo from functions of module Refiner
+
+Files contrib/*/g_*.ml4 take the place of files contrib/*/*.v.
+Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd
+  VERNAC COMMAND EXTEND macros
+File syntax/PPTactic.v moved to parsing/pptactic.ml
+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
+======================================
+
+The core of Coq (kernel) has meen minimized with the following effects:
+
+kernel/term.ml      split into kernel/term.ml,      pretyping/termops.ml
+kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml
+kernel/names.ml     split into kernel/names.ml,     library/nameops.ml
+kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml
+
+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
+===================================================
+
+Changements d'organisation / modules :
+--------------------------------------
+
+  Std, More_util		-> lib/util.ml
+
+  Names				-> kernel/names.ml et kernel/sign.ml
+    (les parties noms et signatures ont été séparées)
+
+  Avm,Mavm,Fmavm,Mhm  ->  utiliser plutôt Map (et freeze alors gratuit)
+  Mhb                 ->  Bij
+
+  Generic est intégré à Term (et un petit peu à Closure)
+
+Changements dans les types de données :
+---------------------------------------
+  dans Generic: free_rels : constr -> int Listset.t
+                  devient : constr -> Intset.t
+
+  type_judgement ->  typed_type
+  environment    ->  context
+  context        ->  typed_type signature
+
+
+ATTENTION:
+----------
+
+  Il y a maintenant d'autres exceptions que UserError (TypeError,
+  RefinerError, etc.)
+
+  Il ne faut donc plus se contenter (pour rattraper) de faire
+  
+		try . .. with UserError _ -> ...
+
+  mais écrire à la place
+ 
+                try ... with e when Logic.catchable_exception e -> ...
+
+
+Changements dans les fonctions :
+--------------------------------
+
+	Vectops.
+	  it_vect          ->  Array.fold_left
+	  vect_it          ->  Array.fold_right
+	  exists_vect      ->  Util.array_exists
+	  for_all2eq_vect  ->  Util.array_for_all2
+	  tabulate_vect    ->  Array.init
+	  hd_vect          ->  Util.array_hd
+	  tl_vect          ->  Util.array_tl
+	  last_vect        ->  Util.array_last
+	  it_vect_from     ->  array_fold_left_from
+	  vect_it_from     ->  array_fold_right_from
+	  app_tl_vect	   ->  array_app_tl
+	  cons_vect	   ->  array_cons
+	  map_i_vect	   ->  Array.mapi
+	  map2_vect	   ->  array_map2
+	  list_of_tl_vect  ->  array_list_of_tl
+
+        Names
+          sign_it        -> fold_var_context (se fait sur env maintenant)
+	  it_sign        -> fold_var_context_reverse (sur env maintenant)
+
+        Generic
+	  noccur_bet     -> noccur_between
+          substn_many    -> substnl
+
+	Std 
+	  comp           ->  Util.compose
+	  rev_append	 ->  List.rev_append
+
+	Termenv
+	  mind_specif_of_mind  -> Global.lookup_mind_specif
+                ou Environ.lookup_mind_specif si on a un env sous la main
+	  mis_arity      ->  instantiate_arity
+	  mis_lc	 ->  instantiate_lc	
+
+	Ex-Environ	 
+	  mind_of_path      -> Global.lookup_mind
+
+	Printer
+	  gentermpr	->   gen_pr_term
+          term0	        ->   prterm_env	
+          pr_sign       ->   pr_var_context
+	  pr_context_opt -> pr_context_of
+          pr_ne_env      -> pr_ne_context_of
+
+	Typing, Machops
+	  type_of_type     ->  judge_of_type
+	  fcn_proposition  ->  judge_of_prop_contents
+	  safe_fmachine    ->  safe_infer
+
+	Reduction, Clenv
+          whd_betadeltat      -> whd_betaevar
+          whd_betadeltatiota  -> whd_betaiotaevar
+          find_mrectype       -> Inductive.find_mrectype
+          find_minductype     -> Inductive.find_inductive
+          find_mcoinductype   -> Inductive.find_coinductive
+
+        Astterm
+          constr_of_com_casted -> interp_casted_constr
+          constr_of_com_sort   -> interp_type
+          constr_of_com        -> interp_constr
+          rawconstr_of_com     -> interp_rawconstr
+          type_of_com          -> type_judgement_of_rawconstr
+	  judgement_of_com     -> judgement_of_rawconstr
+
+        Termast
+          bdize                -> ast_of_constr
+
+        Tacmach
+          pf_constr_of_com_sort -> pf_interp_type
+          pf_constr_of_com      -> pf_interp_constr
+	  pf_get_hyp            -> pf_get_hyp_typ
+          pf_hyps, pf_untyped_hyps -> pf_env (tout se fait sur env maintenant)
+
+        Pattern
+	  raw_sopattern_of_compattern -> Astterm.interp_constrpattern
+	  somatch               -> is_matching
+          dest_somatch          -> matches
+
+        Tacticals
+	  matches               -> gl_is_matching
+          dest_match            -> gl_matches
+	  suff                  -> utiliser sort_of_goal
+          lookup_eliminator     -> utiliser sort_of_goal pour le dernier arg
+
+        Divers
+          initial_sign     -> var_context
+
+        Sign
+          ids_of_sign      -> ids_of_var_context (or Environ.ids_of_context)
+          empty_sign       -> empty_var_context
+
+        Pfedit
+	  list_proofs      -> get_all_proof_names
+          get_proof        -> get_current_proof_name
+          abort_goal       -> abort_proof
+          abort_goals      -> abort_all_proofs
+          abort_cur_goal   -> abort_current_proof
+          get_evmap_sign   -> get_goal_context/get_current_goal_context
+          unset_undo       -> reset_undo
+
+        Proof_trees
+          mkGOAL           -> mk_goal
+
+        Declare
+  	  machine_constant ->   declare_constant (+ modifs)
+
+	ex-Trad, maintenant Pretyping
+          inh_cast_rel        -> Coercion.inh_conv_coerce_to
+          inh_conv_coerce_to  -> Coercion.inh_conv_coerce_to_fail
+	  ise_resolve1        -> understand, understand_type
+	  ise_resolve         -> understand_judgment, understand_type_judgment
+
+        ex-Tradevar, maintenant Evarutil
+          mt_tycon            -> empty_tycon
+
+        Recordops
+          struc_info          -> find_structure
+
+Changements dans les inductifs
+------------------------------
+Nouveaux types "constructor" et "inductive" dans Term
+La plupart des fonctions de typage des inductives prennent maintenant
+un inductive au lieu d'un oonstr comme argument. Les seules fonctions
+à traduire un constr en inductive sont les find_rectype and co.
+
+Changements dans les grammaires
+-------------------------------
+
+ . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex
+
+ . attention : LIDENT -> IDENT  (les identificateurs n'ont pas de
+                                 casse particulière dans Coq)
+
+ . Le mot "command" est remplacé par "constr" dans les noms de
+ fichiers, noms de modules et non-terminaux relatifs au parsing des
+ termes; aussi les changements suivants "COMMAND"/"CONSTR" dans
+ g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml*
+
+ . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n
+   passent en minuscule Identifier, Constr, ...
+ 
+ . Plusieurs parsers ont changé de format (ex: sortarg)
+
+Changements dans le pretty-printing
+-----------------------------------
+
+ . Découplage de la traduction de constr -> rawconstr (dans detyping)
+    et de rawconstr -> ast (dans termast)
+ . Déplacement des options d'affichage de printer vers termast
+ . Déplacement des réaiguillage d'univers du pp de printer vers esyntax
+
+	
+Changements divers
+------------------
+
+ . il n'y a plus de script coqtop => coqtop et coqtop.byte sont
+   directement le résultat du link du code
+   => debuggage et profiling directs
+
+ . il n'y a plus d'installation locale dans bin/$ARCH
+ 
+ . #use "include.ml"  =>  #use "include"
+   go()               =>  loop()
+
+ . il y a "make depend" et "make dependcamlp4" car ce dernier prend beaucoup
+   de temps
diff --git a/dev/db b/dev/db
new file mode 100644
index 00000000..44effd77
--- /dev/null
+++ b/dev/db
@@ -0,0 +1,35 @@
+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
+
+install_printer Top_printers.pppattern
+install_printer Top_printers.pprawterm
+
+install_printer Top_printers.ppterm
+install_printer Top_printers.print_uni
+install_printer Top_printers.pp_universes
+install_printer Top_printers.pptype
+install_printer Top_printers.prj
+
+install_printer Top_printers.prgoal
+install_printer Top_printers.prsigmagoal
+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.pptac
+install_printer Top_printers.pr_obj                                                     
+
diff --git a/dev/db_printers.ml b/dev/db_printers.ml
new file mode 100644
index 00000000..cee94d47
--- /dev/null
+++ b/dev/db_printers.ml
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Pp
+open Names
+
+let pp s = pp (hov 0 s)
+
+let prid id = Format.print_string (string_of_id id)
+let prsp sp = Format.print_string (string_of_path sp)
+
+
diff --git a/dev/deboguage.txt b/dev/deboguage.txt
new file mode 100644
index 00000000..eea7a0bc
--- /dev/null
+++ b/dev/deboguage.txt
@@ -0,0 +1,30 @@
+
+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/debugging.txt b/dev/debugging.txt
new file mode 100644
index 00000000..d3fbf48a
--- /dev/null
+++ b/dev/debugging.txt
@@ -0,0 +1,50 @@
+
+Debugging from Coq toplevel using Caml trace mechanism
+======================================================
+
+  1. Launch bytecode version of Coq (coqtop.byte or coqtop -byte)
+  2. Access Ocaml toplevel using vernacular command 'Drop.'
+  3. Install load paths and pretty printers for terms, idents, ... using
+     Ocaml command '#use "base_include";;' (use '#use "include";;' for a rawer
+     term pretty printer)
+  4. Use #trace to tell which function(s) to trace
+  5. Go back to Coq toplevel with 'go();;'
+  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();;'
+
+Debugging from Caml debugger
+============================
+
+   Needs tuareg mode in Emacs
+   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
+   4. source db  (to get pretty-printers)
+   5. add breakpoints with C-x C-a C-b from the buffer displaying the ocaml
+      source
+   6. get more help from ocamldebug manual
+         run
+	 step
+         back
+         start
+	 next
+	 last
+	 print x (abbreviated into p x)
+	 ...
+   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"
+
+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
diff --git a/dev/header b/dev/header
new file mode 100644
index 00000000..57945e47
--- /dev/null
+++ b/dev/header
@@ -0,0 +1,7 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
diff --git a/dev/include b/dev/include
new file mode 100644
index 00000000..eb370a5d
--- /dev/null
+++ b/dev/include
@@ -0,0 +1,35 @@
+
+(* File to include to install the pretty-printers in the ocaml toplevel *)
+
+#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  (* 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  (* goal *)  prgoal;;
+#install_printer  (* sigma goal *)  prsigmagoal;;
+#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  (* env *) ppenv;;
+
+#install_printer  (* tactic *) pptac;;
+#install_printer  (* object *) pr_obj;;
+#install_printer  (* global_reference *) prglobal;;
+
+#install_printer  (* fconstr *) ppfconstr;;
+
diff --git a/dev/objects.el b/dev/objects.el
new file mode 100644
index 00000000..b3a2694d
--- /dev/null
+++ b/dev/objects.el
@@ -0,0 +1,153 @@
+(defun add-survive-module nil
+  (interactive)
+  (query-replace-regexp 
+   "
+\\([ 	]*\\)\\(Summary\.\\)?survive_section"
+   "
+\\1\\2survive_module = false;
+\\1\\2survive_section")
+  )
+
+(global-set-key [f2] 'add-survive-module)
+
+; functions to change old style object declaration to new style
+
+(defun repl-open nil
+  (interactive)
+  (query-replace-regexp 
+   "open_function\\([ 	]*\\)=\\([ 	]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" 
+   "open_function\\1=\\2(fun i o -> if i=1 then cache_\\3 o)\\4;") 
+  )
+
+(global-set-key [f6] 'repl-open)
+
+(defun repl-load nil
+  (interactive)
+  (query-replace-regexp 
+   "load_function\\([ 	]*\\)=\\([ 	]*\\)cache_\\([a-zA-Z0-9'_]*\\)\\( *\\);" 
+   "load_function\\1=\\2(fun _ -> cache_\\3)\\4;") 
+  )
+
+(global-set-key [f7] 'repl-load)
+
+(defun repl-decl nil
+  (interactive)
+  (query-replace-regexp
+   "\\(Libobject\.\\)?declare_object[ 
+	]*([ 	]*\\(.*\\)[ 
+	]*,[ 	]*
+\\([ 	]*\\){\\([ 	]*\\)\\([^ ][^}]*\\)}[ 	]*)"
+
+   "\\1declare_object {(\\1default_object \\2) with
+\\3 \\4\\5}")
+;   "|$1=\\1|$2=\\2|$3=\\3|$4=\\4|")
+)
+
+(global-set-key [f9] 'repl-decl)
+
+; eval the above and try f9 f6 f7 on the following:
+
+let (inThing,outThing) =
+  declare_object
+    ("THING", 
+     { load_function = cache_thing;
+       cache_function = cache_thing;
+       open_function = cache_thing;
+       export_function = (function x -> Some x)
+     })
+
+
+;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+; functions helping writing non-copying substitutions
+
+(defun make-subst (name)
+  (interactive "s")
+  (defun f (l)
+    (save-excursion
+      (query-replace-regexp
+       (concat "\\([a-zA-z_0-9]*\\)[ 	]*:[ 	]*" 
+	       (car l) 
+	       "\\([ 	]*;\\|[ 	
+]*\}\\)")
+       (concat "let \\1\' = " (cdr l) " " name "\\1 in"))
+      )
+    )
+  (mapcar 'f '(("constr"."subst_mps subst") 
+	       ("Coqast.t"."subst_ast subst") 
+	       ("Coqast.t list"."list_smartmap (subst_ast subst)") 
+	       ("'pat"."subst_pat subst") 
+	       ("'pat unparsing_hunk"."subst_hunk subst_pat subst")
+	       ("'pat unparsing_hunk list"."list_smartmap (subst_hunk subst_pat subst)") 
+	       ("'pat syntax_entry"."subst_syntax_entry subst_pat subst")
+	       ("'pat syntax_entry list"."list_smartmap (subst_syntax_entry subst_pat subst)") 
+	       ("constr option"."option_smartmap (subst_mps subst)")
+	       ("constr list"."list_smartmap (subst_mps subst)")
+	       ("constr array"."array_smartmap (subst_mps subst)")
+	       ("constr_pattern"."subst_pattern subst")
+	       ("constr_pattern option"."option_smartmap (subst_pattern subst)")
+	       ("constr_pattern array"."array_smartmap (subst_pattern subst)")
+	       ("constr_pattern list"."list_smartmap (subst_pattern subst)")
+	       ("global_reference"."subst_global subst")
+	       ("extended_global_reference"."subst_ext subst")
+	       ("obj_typ"."subst_obj subst")
+	       )
+	  )
+  )
+
+
+(global-set-key [f2] 'make-subst)
+
+(defun make-if (name)
+  (interactive "s")
+  (save-excursion
+    (query-replace-regexp
+     "\\([a-zA-z_0-9]*\\)[ 	]*:[ 	]*['a-zA-z_. ]*\\(;\\|[ 	
+]*\}\\)"
+     (concat "&& \\1\' == " name "\\1")
+     )
+    )
+  )
+
+(global-set-key [f4] 'make-if)
+
+(defun make-record nil
+  (interactive)
+  (save-excursion 
+    (query-replace-regexp
+     "\\([a-zA-z_0-9]*\\)[ 	]*:[ 	]*['a-zA-z_. ]*\\(;\\|[ 	
+]*\}\\)"
+     (concat "\\1 = \\1\' ;")
+     )
+    )
+  )
+
+(global-set-key [f5] 'make-record)
+
+(defun make-prim nil
+  (interactive)
+  (save-excursion (query-replace-regexp "\\<[a-zA-Z'_0-9]*\\>" "\\&'"))
+  )
+
+(global-set-key [f6] 'make-prim)
+
+
+; eval the above, yank the text below and do 
+; paste f2 morph.
+; paste f4 morph.
+; paste f5
+
+      lem : constr;
+      profil : bool list;
+      arg_types : constr list;
+      lem2 : constr option                                                      }
+
+
+; and you almost get   Setoid_replace.subst_morph  :)
+
+; and now f5 on this:
+
+   (ref,(c1,c2))
+
+
+
diff --git a/dev/ocamldebug-v7.template b/dev/ocamldebug-v7.template
new file mode 100644
index 00000000..96c53192
--- /dev/null
+++ b/dev/ocamldebug-v7.template
@@ -0,0 +1,41 @@
+#!/bin/sh
+
+# wrap around ocamldebug for Coq
+
+export COQTOP=COQTOPDIRECTORY
+export COQLIB=COQLIBDIRECTORY
+export COQTH=$COQLIB/theories
+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 \
+	-I $CAMLP4LIB \
+	-I $COQTOP/config \
+	-I $COQTOP/lib -I $COQTOP/kernel \
+	-I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \
+        -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/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
diff --git a/dev/style.txt b/dev/style.txt
new file mode 100644
index 00000000..2e597dc4
--- /dev/null
+++ b/dev/style.txt
@@ -0,0 +1,49 @@
+
+<< L'uniformité du style est plus importante que le style lui-même. >>
+(Kernigan & Pike, The Practice of Programming)
+
+Mode Emacs
+==========
+   Tuareg, que l'on trouve ici :  http://www.prism.uvsq.fr/~acohen/tuareg/
+
+   avec le réglage suivant :     (setq tuareg-in-indent 2)
+
+Types récursifs et filtrages
+============================
+   Une barre de séparation y compris sur le premier constructeur
+
+type t =
+  | A 
+  | B of machin
+
+match expr with
+  | A -> ...
+  | B x -> ...
+
+
+Conditionnelles
+===============
+  if condition then
+    premier-cas
+  else
+    deuxieme-cas
+
+  Si effets de bord dans les branches, utilisez begin ... end et non des
+  parenthèses i.e.
+
+  if condition then begin
+    instr1;
+    instr2
+  end else begin
+    instr3;
+    instr4
+  end
+    
+  Si la première branche lève une exception, évitez le else i.e.
+
+    if condition then                     if condition then error "machin";
+      error "machin"          ----->      suite
+    else
+      suite
+
+  
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
new file mode 100644
index 00000000..7f92d64c
--- /dev/null
+++ b/dev/top_printers.ml
@@ -0,0 +1,303 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Printers for the ocaml toplevel. *)
+
+open System
+open Pp
+open Ast
+open Names
+open Libnames
+open Nameops
+open Sign
+open Univ
+open Proof_trees
+open Environ
+open Printer
+open Refiner
+open Tacmach
+open Term
+open Termops
+open Clenv
+open Cerrors
+
+let _ = Constrextern.print_evar_arguments := true
+
+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 ")")
+  | 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 prqualid qid = pp(pr_qualid qid)
+
+let prconst (sp,j) =
+    pp (str"#" ++ pr_kn sp ++ str"=" ++ prterm j.uj_val)
+
+let prvar ((id,a)) =
+    pp (str"#" ++ pr_id id ++ str":" ++ prterm a)
+
+let genprj f j = let (c,t) = f j in (c ++ str " : " ++ t)
+
+let prj j = pp (genprj prjudge j)
+
+let prgoal g = pp(prgl g)
+
+let prsigmagoal g = pp(prgl (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 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 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 pr_obj obj = Format.print_string (Libobject.object_tag obj)
+
+let cnt = ref 0
+
+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)^")"
+  | Prod (na,t,c) ->
+      "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n"
+  | Lambda (na,t,c) ->
+      "Lambda("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n"
+  | LetIn (na,b,t,c) ->
+      "LetIn("^(name_display na)^","^(term_display b)^","
+      ^(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)^")"
+  | Ind (sp,i) ->
+      "MutInd("^(string_of_kn sp)^","^(string_of_int i)^")"
+  | Construct ((sp,i),j) ->
+      "MutConstruct(("^(string_of_kn sp)^","^(string_of_int i)^"),"
+      ^(string_of_int j)^")"
+  | Case (ci,p,c,bl) ->
+      "MutCase(<abs>,"^(term_display p)^","^(term_display c)^","
+      ^(array_display bl)^")"
+  | 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.fold_right (fun x i -> (name_display x)^(if not(i="")
+        then (";"^i) else "")) lna "")^","
+      ^(array_display bl)^")"
+  | CoFix(i,(lna,tl,bl)) ->
+      "CoFix("^(string_of_int i)^"),"
+      ^(array_display tl)^","
+      ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="")
+        then (";"^i) else "")) lna "")^","
+      ^(array_display bl)^")"
+
+  and array_display v =
+    "[|"^
+    (Array.fold_right
+       (fun x i -> (term_display x)^(if not(i="") then (";"^i) else ""))
+       v "")^"|]"
+
+  and sort_display = function
+    | Prop(Pos) -> "Prop(Pos)"
+    | Prop(Null) -> "Prop(Null)"
+    | Type u ->
+	incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ());
+	"Type("^(string_of_int !cnt)^")"
+
+  and name_display = function
+    | Name id -> "Name("^(string_of_id id)^")"
+    | Anonymous -> "Anonymous"
+
+  in
+    msg (str (term_display csr) ++fnl ())
+
+open Format;;
+
+let print_pure_constr csr =
+  let rec term_display c = match kind_of_term c with
+  | Rel n -> print_string "#"; print_int n
+  | 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;
+      print_string "("; (term_display c); print_cut();
+      print_string "::"; (term_display t); print_string ")"; close_box()
+  | Prod (Name(id),t,c) ->
+      open_hovbox 1;
+      print_string"("; print_string (string_of_id id); 
+      print_string ":"; box_display t; 
+      print_string ")"; print_cut(); 
+      box_display c; close_box()
+  | Prod (Anonymous,t,c) ->
+      print_string"("; box_display t; print_cut(); print_string "->";
+      box_display c; print_string ")"; 
+  | Lambda (na,t,c) ->
+      print_string "["; name_display na;
+      print_string ":"; box_display t; print_string "]";
+      print_cut(); box_display c; 
+  | LetIn (na,b,t,c) ->
+      print_string "["; name_display na; print_string "="; 
+      box_display b; print_cut();
+      print_string ":"; box_display t; print_string "]";
+      print_cut(); box_display c; 
+  | App (c,l) -> 
+      print_string "("; 
+      box_display c; 
+      Array.iter (fun x -> print_space (); box_display x) l;
+      print_string ")"
+  | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{";
+      Array.iter (fun x -> print_space (); box_display x) l;
+      print_string"}"
+  | Const c -> print_string "Cons(";
+      sp_display c;
+      print_string ")"
+  | Ind (sp,i) ->
+      print_string "Ind(";
+      sp_display sp;
+      print_string ","; print_int i;
+      print_string ")"
+  | Construct ((sp,i),j) ->
+      print_string "Constr(";
+      sp_display sp;
+      print_string ",";
+      print_int i; print_string ","; print_int j; print_string ")"
+  | Case (ci,p,c,bl) ->
+      open_vbox 0;
+      print_string "<"; box_display p; print_string ">";
+      print_cut(); print_string "Case";
+      print_space(); box_display c; print_space (); print_string "of";
+      open_vbox 0;
+      Array.iter (fun x ->  print_cut();  box_display x) bl;
+      close_box();
+      print_cut(); 
+      print_string "end"; 
+      close_box()
+  | Fix ((t,i),(lna,tl,bl)) ->
+      print_string "Fix("; print_int i; print_string ")"; 
+      print_cut();
+      open_vbox 0;
+      let rec print_fix () =
+        for k = 0 to Array.length tl do
+	  open_vbox 0;
+	  name_display lna.(k); print_string "/"; 
+	  print_int t.(k); print_cut(); print_string ":";
+	  box_display tl.(k) ; print_cut(); print_string ":=";
+	  box_display bl.(k); close_box ();
+	  print_cut()
+        done
+      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 do
+          open_vbox 1;
+	  name_display lna.(k);  print_cut(); print_string ":";
+	  box_display tl.(k) ; print_cut(); print_string ":=";
+	  box_display bl.(k); close_box ();
+	  print_cut();
+        done
+      in print_string"{"; print_fix (); print_string"}"
+
+  and box_display c = open_hovbox 1; term_display c; close_box()
+
+  and sort_display = function
+    | Prop(Pos) -> print_string "Set"
+    | Prop(Null) -> print_string "Prop"
+    | Type u -> open_hbox();
+	print_string "Type("; pp (pr_uni u); print_string ")"; close_box()
+
+  and name_display = function
+    | Name id -> print_string (string_of_id id)
+    | Anonymous -> print_string "_"
+(* Remove the top names for library and Scratch to avoid long names *)
+  and sp_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_kn sp)
+
+  in
+     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")
+
+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")
+*)
+
+let ppfconstr c = ppterm (Closure.term_of_fconstr c)
diff --git a/dev/translate.txt b/dev/translate.txt
new file mode 100644
index 00000000..5b372c96
--- /dev/null
+++ b/dev/translate.txt
@@ -0,0 +1,495 @@
+
+                 How to use the translator
+                 =========================
+
+       (temporary version to be included in the official
+           TeX document describing the translator)
+
+The translator is a smart, robust and powerful tool to improve the
+readibility of your script. The current document describes the
+possibilities of the translator.
+
+In case of problem recompiling the translated files, don't waste time
+to modify the translated file by hand, read first the following
+document telling on how to modify the original files to get a smooth
+uniform safe translation. All 60000 lines of Coq lines on our
+user-contributions server have been translated without any change
+afterwards, and 0,5 % of the lines of the original files (mainly
+notations) had to be modified beforehand to get this result.
+
+Table of contents
+-----------------
+
+I) Implicit Arguments
+ 1) Strict Implicit Arguments 
+ 2) Implicit Arguments in standard library
+
+II) Notations
+ 1) Translating a V7 notation as it was
+ 2) Translating a V7 notation which conflicts with the new syntax
+  a) Associativity conflicts
+  b) Conflicts with other notations
+   b1) A notation hides another notation 
+   b2) A notation conflicts with the V8 grammar
+   b3) My notation is already defined at another level
+  c) How to use V8only with Distfix ?
+  d) Can I overload a notation in V8, e.g. use "*" and "+" ?
+ 3) Using the translator to have simplest notations
+ 4) Setting the translator to automatically use new notations that
+    wasn't used in old syntax
+ 5) Defining a construction and its notation simultaneously
+
+III) Various pitfalls
+ 1) New keywords
+ 2) Old "Case" and "Match"
+ 3) Change of definition or theorem names
+ 4) Change of tactic names
+
+---------------------------------------------------------------------
+
+I) Implicit Arguments
+   ------------------
+
+1) Strict Implicit Arguments 
+
+  "Set Implicit Arguments" changes its meaning in V8: the default is
+to turn implicit only the arguments that are _strictly_ implicit (or
+rigid), i.e. that remains inferable whatever the other arguments
+are. E.g "x" inferable from "P x" is not strictly inferable since it
+can disappears if "P" is instanciated by a term which erase "x".
+
+  To respect the old semantics, the default behaviour of the
+translator is to replace each occurrence "Set Implicit Arguments" by
+
+  Set Implicit Arguments.
+  Unset Strict Implicits.
+
+  However, you may wish to adopt the new semantics of "Set Implicit
+Arguments" (for instance because you think that the choice of
+arguments it setsimplicit is more "natural" for you). In this case,
+add the option -strict-implicit to the translator.
+
+  Warning: Changing the number of implicit arguments can break the
+notations.  Then use the V8only modifier of Notations.
+
+2) Implicit Arguments in standard library
+
+  Main definitions of standard library have now implicit
+arguments. These arguments are dropped in the translated files. This
+can exceptionally be a source of incompatibilities which has to be
+solved by hand (it typically happens for polymorphic functions applied
+to "nil" or "None").
+
+II) Notations
+    ---------
+
+  Grammar (on constr) and Syntax are no longer supported. Replace them by
+Notation before translation.
+
+  Precedence levels are now from 0 to 200. In V8, the precedence and
+associativity of an operator cannot be redefined. Typical level are
+(refer to the chapter on notations in the Reference Manual for the
+full list):
+
+  <-> : 95                    (no associativity)
+  -> : 90                     (right associativity)
+  \/ : 85                     (right associativity)
+  /\ : 80                     (right associativity)
+  ~ : 75                      (right associativity)
+  =, <, >, <=, >=, <> : 70    (no associativity)
+  +, - : 50                   (left associativity)
+  *, / : 40                   (left associativity)
+  ^ : 30                      (right associativity)
+
+1) Translating a V7 notation as it was
+
+  By default, the translator keeps the associativity given in V7 while
+the levels are mapped according to the following table:
+ 
+  the V7 levels             [  0;  1;  2;  3;  4;  5;  6;  7;  8;  9;  10]
+  are resp. mapped in V8 to [  0; 20; 30; 40; 50; 70; 80; 85; 90; 95; 100]
+  with predefined assoc     [ No;  L;  R;  L;  L; No;  R;  R;  R; No;   L]
+
+  If this is OK for you, just simply apply the translator.
+
+2) Translating a V7 notation which conflicts with the new syntax
+
+a) Associativity conflict
+
+  Since the associativity of the levels obtained by translating a V7
+level (as shown on table above) cannot be changed, you have to choose
+another level with a compatible associativity.
+
+  You can choose any level between 0 and 200, knowing that the
+standard operators are already set at the levels shown on the list
+above. 
+
+Example 1: Assume you have a notation
+
+Infix NONA 2 "=_S" my_setoid_eq.
+
+By default, the translator moves it to level 30 which is right
+associative, hence a conflict with the expected no associativity.
+
+To solve the problem, just add the "V8only" modifier to reset the
+level and enforce the associativity as follows:
+
+Infix NONA 2 "=_S" my_setoid_eq V8only (at level 70, no associativity).
+
+The translator now knows that it has to translate "=_S" at level 70
+with no associativity.
+
+Rem: 70 is the "natural" level for relations, hence the choice of 70
+here, but any other level accepting a no-associativity would have been
+OK.
+
+Example 2: Assume you have a notation
+
+Infix RIGHTA 1 "o" my_comp.
+
+By default, the translator moves it to level 20 which is left
+associative, hence a conflict with the expected right associativity.
+
+To solve the problem, just add the "V8only" modifier to reset the
+level and enforce the associativity as follows:
+
+Infix RIGHTA 1 "o" my_comp V8only (at level 20, right associativity).
+
+The translator now knows that it has to translate "o" at level 20
+which has the correct "right associativity".
+
+Rem: We assumed here that the user wants a strong precedence for
+composition, in such a way, say, that "f o g + h" is parsed as
+"(f o g) + h". To get "o" binding less than the arithmetical operators,
+an appropriated level would have been close of 70, and below, e.g. 65.
+
+b) Conflicts with other notations
+
+Since the new syntax comes with new keywords and new predefined
+symbols, new conflicts can occur. Again, you can use the option V8only
+to inform the translator of the new syntax to use.
+
+b1) A notation hides another notation 
+
+Rem: use Print Grammar constr in V8 to diagnose the overlap and see the
+section on factorization in the chapter on notations of the Reference
+Manual for hints on how to factorize.
+
+Example:
+
+Notation "{ x }" := (my_embedding x) (at level 1).
+
+overlaps in V8 with notation "{ x : A & P }" at level 0 and with x at
+level 99. The conflicts can be solved by left-factorizing the notation
+as follows:
+
+Notation "{ x }" := (my_embedding x) (at level 1)
+  V8only (at level 0, x at level 99).
+
+b2) A notation conflicts with the V8 grammar.
+
+Again, use the V8only modifier to tell the translator to automatically
+take in charge the new syntax.
+
+Example:
+
+Infix 3 "@" app.
+
+Since "@" is used in the new syntax for deactivating the implicit
+arguments, another symbol has to be used, e.g. "@@". This is done via
+the V8only option as follows:
+
+Infix 3 "@" app V8only "@@" (at level 40, left associativity).
+
+or, alternatively by
+
+Notation "x @ y" := (app x y) (at level 3, left associativity)
+  V8only "x @@ y" (at level 40, left associativity).
+
+b3) My notation is already defined at another level (or with another
+associativity)
+
+In V8, the level and associativity of a given notation can no longer
+be changed. Then, either you adopt the standard reserved levels and
+associativity for this notation (as given on the list above) or you
+change your notation.
+
+- To change the notation, follow the directions in section b2.
+
+- To adopt the standard level, just use V8only without any argument.
+
+Example.
+
+Infix 6 "*" my_mult.
+
+is not accepted as such in V8. Write
+
+Infix 6 "*" my_mult V8only.
+
+to tell the translator to use "*" at the reserved level (i.e. 40 with
+left associativity). Even better, use interpretation scopes (look at
+the Reference Manual).
+
+c) How to use V8only with Distfix ?
+
+You can't, use Notation instead of Distfix.
+
+d) Can I overload a notation in V8, e.g. use "*" and "+" for my own
+algebraic operations ?
+
+Yes, using interpretation scopes (see the corresponding chapter in the
+Reference Manual).
+
+3) Using the translator to have simplest notations
+
+Thanks to the new syntax, * has now the expected left associativity,
+and the symbols <, >, <= and >= are now available.
+
+Thanks to the interpretation scopes, you can overload the
+interpretation of these operators with the default interpretation
+provided in Coq.
+
+This may be a motivation to use the translator to automatically change
+the notations while switching to the new syntax.
+
+See sections b) and d) above for examples.
+
+4) Setting the translator to automatically use new notations that
+wasn't used in old syntax
+
+Thanks to the "Notation" mechanism, defining symbolic notations is
+simpler than in the previous versions of Coq.
+
+Thanks to the new syntax and interpretation scopes, new symbols and
+overloading is available.
+
+This may be a motivation for using the translator to automatically change
+the notations while switching to the new syntax.
+
+Use for that the commands V8Notation and V8Infix.
+
+Examples:
+
+V8Infix "==>" my_relation (at level 65, right associativity).
+
+tells the translator to write an infix "==>" instead of my_relation in
+the translated files.
+
+V8Infix ">=" my_ge.
+
+tells the translator to write an infix ">=" instead of my_ge in the
+translated files and that the level and associativity are the standard
+one (as defined in the chart above).
+
+V8Infix ">=" my_ge : my_scope.
+
+tells the translator to write an infix ">=" instead of my_ge in the
+translated files, that the level and associativity are the standard
+one (as defined in the chart above), but only if scope my_scope is
+open or if a delimiting key is available for "my_scope" (see the
+Reference Manual).
+
+5) Defining a construction and its notation simultaneously
+
+This is permitted by the new syntax. Look at the Reference Manual for
+explanation. The translator is not fully able to take this in charge...
+
+III) Various pitfalls
+    ----------------
+
+1) New keywords
+
+  The following identifiers are new keywords
+
+  "forall"; "fun"; "match"; "fix"; "cofix"; "for"; "if"; "then";
+  "else"; "return"; "mod"; "at"; "let"; "_"; ".("
+
+  The translator automatically add a "_" to names clashing with a
+keyword, except for files. Hence users may need to rename the files
+whose name clashes with a keyword.
+
+  Remark: "in"; "with"; "end"; "as"; "Prop"; "Set"; "Type"
+  were already keywords
+
+2) Old "Case" and "Match"
+
+  "Case" and "Match" are normally automatically translated into
+  "match" or "match" and "fix", but sometimes it fails to do so. It
+  typically fails when the Case or Match is argument of a tactic whose
+  typing context is unknown because of a preceding Intro/Intros, as e.g. in 
+
+     Intros; Exists [m:nat](<quasiterm>Case m of t [p:nat](f m) end)
+
+  The solution is then to replace the invocation of the sequence of
+  tactics into several invocation of the elementary tactics as follows
+
+     Intros. Exists [m:nat](<quasiterm>Case m of t [p:nat](f m) end)
+          ^^^
+
+3) Change of definition or theorem names
+
+  Type "entier" from fast_integer.v is renamed into "N" by the
+translator. As a consequence, user-defined objects of same name "N"
+are systematically qualified even tough it may not be necessary.  The
+same apply for names "GREATER", "EQUAL", "LESS", etc... [COMPLETE LIST
+TO GIVE].
+
+4) Change of tactics names
+
+  Since tactics names are now lowercase, this can clash with
+user-defined tactic definitions. To pally this, clashing names are
+renamed by adding an extra "_" to their name.
+
+======================================================================
+Main examples for new syntax
+----------------------------
+
+1) Constructions
+
+  Applicative terms don't any longer require to be surrounded by parentheses as
+e.g in
+
+  "x = f y -> S x = S (f y)"
+
+
+  Product is written
+
+     "forall x y : T, U"
+     "forall x y, U"
+     "forall (x y : T) z (v w : V), U"
+     etc.
+
+  Abstraction is written
+
+     "fun x y : T, U"
+     "fun x y, U"
+     "fun (x y : T) z (v w : V), U"
+     etc.
+
+  Pattern-matching is written
+
+     "match x with c1 x1 x2 => t | c2 y as z => u end"
+     "match v1, v2 with c1 x1 x2, _ => t | c2 y, d z => u end"
+     "match v1 as y in le _ n, v2 as z in I p q return P n y p q z with
+         c1 x1 x2, _ => t | c2 y, d z => u end"
+
+     The last example is the new form of what was written
+
+    "<[n;y:(le ? n);p;q;z:(I p q)](P n y p q z)>Cases v1 v2 of
+         (c1 x1 x2) _ => t | (c2 y) (d z) => u end"
+
+  Pattern-matching of type with one constructors and no dependencies
+of the arguments in the resulting type can be written
+
+    "let (x,y,z) as u return P u := t in v"
+     
+  Local fixpoints are written
+
+    "fix f (n m:nat) z (x : X) {struct m} : nat := ...
+     with ..."
+
+    and "struct" tells which argument is structurally decreasing.
+
+  Explicitation of implicit arguments is written
+
+     "f @1:=u v @3:=w t"
+     "@f u v w t"
+
+2) Tactics
+
+  The main change is that tactics names are now lowercase. Besides
+this, the following renaming are applied:
+
+  "NewDestruct" -> "destruct"
+  "NewInduction" -> "induction"
+  "Induction" -> "simple induction"
+  "Destruct" -> "simple destruct"
+
+  For tactics with occurrences, the occurrences now comes after and
+  repeated use is separated by comma as in
+
+  "Pattern 1 3 c d 4 e" -> "pattern c at 3 1, d, e at 4"
+  "Unfold 1 3 f 4 g" -> "unfold f at 1 3, g at 4"
+  "Simpl 1 3 e" -> "simpl e at 1 3"
+
+3) Tactic language
+
+  Definitions are now introduced with keyword "Ltac" (instead of
+"Tactic"/"Meta" "Definition") and are implicitly recursive
+("Recursive" is no longer used).
+
+  The new rule for distinguishing terms from ltac expressions is:
+
+  Write "ltac:" in front of any tactic in argument position and
+  "constr:" in front of any construction in head position
+
+4) Vernacular language
+
+a) Assumptions
+
+  The syntax for commands is mainly unchanged. Declaration of
+assumptions is now done as follows
+
+  Variable m : t.
+  Variables m n p : t.
+  Variables (m n : t) (u v : s) (w : r).
+  
+b) Definitions
+
+  Definitions are done as follows
+
+  Definition f m n : t := ... .
+  Definition f m n := ... .
+  Definition f m n := ... : t.
+  Definition f (m n : u) : t := ... .
+  Definition f (m n : u) := ... : t.
+  Definition f (m n : u) := ... .
+  Definition f a b (p q : v) r s (m n : t) : t := ... .
+  Definition f a b (p q : v) r s (m n : t) := ... .
+  Definition f a b (p q : v) r s (m n : t) := ... : t.
+
+c) Fixpoints
+
+  Fixpoints are done this way
+  
+  Fixpoint f x (y : t) z a (b c : u) {struct z} : v := ... with ... .
+  Fixpoint f x : v := ... .
+  Fixpoint f (x : t) : v := ... .
+
+  It is possible to give a concrete notation to a fixpoint as follows
+
+  Fixpoint plus (n m:nat) {struct n} : nat as "n + m" :=
+    match n with
+    | O => m
+    | S p => S (p + m)
+    end.
+
+d) Inductive types
+
+  The syntax for inductive types is as follows
+
+  Inductive t (a b : u) (d : e) : v :=
+     c1 : w1 | c2 : w2 | ... .
+
+  Inductive t (a b : u) (d : e) : v :=
+     c1 : w1 | c2 : w2 | ... .
+
+  Inductive t (a b : u) (d : e) : v :=
+     c1 (x y : t) : w1 | c2 (z : r) : w2 | ... .
+
+  As seen in the last example, arguments of the constructors can be
+given before the colon. If the type itself is omitted (allowed only in
+case the inductive type has no real arguments), this yields an
+ML-style notation as follows
+
+  Inductive nat : Set := O | S (n:nat).
+  Inductive bool : Set := true | false.
+
+  It is even possible to define a syntax at the same time, as follows:
+
+  Inductive or (A B:Prop) : Prop as "A \/ B":=
+    | or_introl (a:A) : A \/ B 
+    | or_intror (b:B) : A \/ B.
+
+  Inductive and (A B:Prop) : Prop as "A /\ B" := conj (a:A) (b:B).
+  
diff --git a/dev/univdot b/dev/univdot
new file mode 100755
index 00000000..bb0dd2c8
--- /dev/null
+++ b/dev/univdot
@@ -0,0 +1,49 @@
+#!/bin/sh
+
+usage() {
+    echo ""
+    echo "usage: univdot [INPUT] [OUTPUT]"
+    echo ""
+    echo "takes the output of Dump Universes \"file\" command"
+    echo "and transforms it to the dot format"
+    echo ""
+    echo "Coq> Dump Universes \"univ.raw\"."
+    echo ""
+    echo "user@host> univdot univ.raw | dot -Tps > univ.ps" 
+    echo ""
+}
+    
+
+# these are dot edge attributes to draw arrows corresponding 
+# to > >= and = edges of the universe graph
+
+GT="[color=red]"
+GE="[color=blue]"
+EQ="[color=black]"
+
+
+# input/output redirection
+case $# in
+  0) ;;
+  1) case $1 in
+       -h|-help|--help) usage
+               exit 0 ;;
+       *) exec < $1 ;;
+     esac ;;
+  2) exec < $1 > $2 ;;
+  *) usage
+     exit 0;;
+esac
+
+
+# dot header
+echo 'digraph G {\
+  size="7.5,10" ;\
+  rankdir = TB ;'
+
+sed -e "s/^\([^ =>]\+\) > \([^ =>]\+\)/\1 -> \2 $GT/" \
+      -e "s/^\([^ =>]\+\) >= \([^ =>]\+\)/\1 -> \2 $GE/" \
+      -e "s/^\([^ =>]\+\) = \([^ =>]\+\)/\1 -> \2 $EQ/" \
+| sed -e "s/\./_/g" 
+
+echo "}"
\ No newline at end of file
diff --git a/dev/universes.txt b/dev/universes.txt
new file mode 100644
index 00000000..65c1e522
--- /dev/null
+++ b/dev/universes.txt
@@ -0,0 +1,32 @@
+How to debug universes?
+
+1. There is a command Dump Universes in Coq toplevel
+
+   Dump Universes.
+     prints the graph of universes in the form of constraints
+
+   Dump Universes "file".
+     produces the "file" containing universe constraints in the form
+       univ1 # univ2 ;
+     where # can be either > >= or =
+     
+   The file produced by the latter command can be transformed using
+   the script univdot to dot format.
+   For example
+
+   univdot file | dot -Tps > file.ps
+
+   produces a graph of universes in ps format. 
+   > arrows are red, >= blue, and = black.
+
+
+   *) for dot see http://www.research.att.com/sw/tools/graphviz/
+
+
+2. There is a printing option
+  
+   Termast.print_universes : bool ref
+
+   which, when set (in ocaml after Drop), makes all pretty-printed
+   Type's annotated with the name of the universe.
+
diff --git a/ide/.coqide-gtk2rc b/ide/.coqide-gtk2rc
new file mode 100644
index 00000000..11c53dad
--- /dev/null
+++ b/ide/.coqide-gtk2rc
@@ -0,0 +1,49 @@
+# Some default functions for CoqIde. You may copy the file in your HOME and
+# edit as you want. See 
+# http://developer.gnome.org/doc/API/2.0/gtk/gtk-Resource-Files.html
+# for a complete set of options
+# To set the font of the text windows, edit the .coqiderc file through the menus.
+
+gtk-key-theme-name = "Emacs"
+
+#pixmap_path "/home/"
+
+binding "text" {
+  bind "<ctrl>k" { "set-anchor" ()
+		   "move-cursor" (display-line-ends,1,0)
+		   "move-cursor" (visual-positions,1,0)
+		   "cut-clipboard" ()	
+		}
+  bind "<ctrl>w" { "cut-clipboard" () }
+
+# For UTF-8 inputs !
+#  bind "F11" {"insert-at-cursor" ("∀")}
+#  bind "F12" {"insert-at-cursor" ("∃")}
+}
+class "GtkTextView" binding "text"
+
+
+style "views" {
+base[NORMAL] = "CornSilk"
+# bg_pixmap[NORMAL] = "background.jpg"
+}
+class "GtkTextView" style "views"
+
+widget "*.*.*.*.*.ScriptWindow" style "views"
+widget "*.*.*.*.GoalWindow" style "views"
+widget "*.*.*.*.MessageWindow" style "views"
+
+gtk-font-name = "Sans 12"
+
+style "location" {
+font_name = "Sans 10"
+}
+widget "*location*" style "location"
+
+
+gtk-can-change-accels = 1
+
+style "men" {
+# 
+}
+widget "GtkMenu" style "men"
diff --git a/ide/FAQ b/ide/FAQ
new file mode 100644
index 00000000..2079ef6c
--- /dev/null
+++ b/ide/FAQ
@@ -0,0 +1,73 @@
+			CoqIde FAQ
+
+Q0) What is CoqIde?
+R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations.
+
+Q1) How to enable Emacs keybindings?
+R1: Insert 
+	gtk-key-theme-name = "Emacs"
+    in your ".coqide-gtk2rc" file. It may be in the current dir
+    or in $HOME dir. This is done by default.
+
+Q2) How to enable antialiased fonts?
+R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2.
+    If some of your fonts are not available, set GDK_USE_XFT to 0.
+
+Q4) How to use those Forall and Exists pretty symbols?
+R4) Thanks to the Notation features in Coq, you just need to insert these
+	lines in your Coq Buffer :
+======================================================================
+Notation "∀ x : t, P" := (forall x:t, P) (at level 200, x ident).
+Notation "∃ x : t, P" := (exists x:t, P) (at level 200, x ident).
+======================================================================
+Copy/Paste of these lines from this file will not work outside of CoqIde.
+You need to load a file containing these lines or to enter the "∀" 
+using an input method (see Q5). To try it just use "Require utf8" from inside
+CoqIde. 
+To enable these notations automatically start coqide with
+	coqide -l utf8
+In the ide subdir of Coq library, you will find a sample utf8.v with some 
+pretty simple notations.
+
+Q5) How to define an input method for non ASCII symbols?
+R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script widow. 
+	2200 is the hexadecimal code for forall in unicode charts and is encoded as "∀"	
+	in UTF-8.
+	2203 is for exists. See http://www.unicode.org for more codes.
+-Second solution : rebind "<AltGr>a" to forall and "<AltGr>e" to exists. 
+	Under X11, you need to use something like
+		xmodmap -e "keycode  24 = a A F13 F13" 
+		xmodmap -e "keycode  26 = e E F14 F14" 
+	and then to add   
+		bind "F13" {"insert-at-cursor" ("∀")}
+		bind "F14" {"insert-at-cursor" ("∃")}
+	to your "binding "text"" section in .coqiderc-gtk2rc.
+	The strange ("∀") argument is the UTF-8 encoding for
+	0x2200. 
+	You can compute these encodings using the lablgtk2 toplevel with 
+		Glib.Utf8.from_unichar 0x2200;;
+	Further symbols can be bound on higher Fxx keys or on even on other keys you
+	do not need .
+
+Q6) How to build a custom CoqIde with user ml code?
+R6) Use 
+	coqmktop -ide -byte m1.cmo...mi.cmo
+    or 
+	coqmktop -ide -opt m1.cmx...mi.cmx
+
+Q7) How to customize the shortcuts for menus?
+R7) Two solutions are offered:
+  - Edit $HOME/.coqide.keys by hand or
+  - Add "gtk-can-change-accels = 1" in your .coqide-gtk2rc file. Then
+    from CoqIde, you may select a menu entry and press the desired 
+    shortcut. 
+
+Q8) What encoding should I use? What is this \x{iiii} in my file?
+R8) The encoding option is related to the way files are saved. 
+ Keep it as UTF-8 until it becomes important for you to exchange files 
+ with non UTF-8 aware applications.
+ If you choose something else than UTF-8, then missing characters will 
+ be encoded by \x{....} or \x{........} where each dot is an hex. digit. 
+ The number between braces is the hexadecimal UNICODE index for the
+  missing character.
+    
diff --git a/ide/blaster_window.ml b/ide/blaster_window.ml
new file mode 100644
index 00000000..cca788c2
--- /dev/null
+++ b/ide/blaster_window.ml
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: blaster_window.ml,v 1.5.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+
+open Gobject.Data
+open Ideutils
+
+exception Stop
+exception Done
+
+module MyMap = Map.Make (struct type t = string let compare = compare end)
+
+class blaster_window (n:int) = 
+  let window = GWindow.window 
+		 ~allow_grow:true ~allow_shrink:true 
+		 ~width:320 ~height:200
+		 ~title:"Blaster Window" ~show:false ()
+  in
+  let box1 = GPack.vbox ~packing:window#add () in
+  let sw = GBin.scrolled_window ~packing:(box1#pack ~expand:true ~fill:true) () in
+
+  let cols = new GTree.column_list in
+  let argument = cols#add string in
+  let tactic = cols#add string in
+  let status = cols#add boolean in
+  let nb_goals = cols#add string in
+  
+  let model = GTree.tree_store cols in
+  let new_arg s =
+    let row = model#append () in
+    model#set ~row ~column:argument s;
+    row
+  in
+  let new_tac arg s =  
+    let row = model#append ~parent:arg () in
+    model#set ~row ~column:tactic s;
+    model#set ~row ~column:status false;
+    model#set ~row ~column:nb_goals "?";
+    row
+  in
+  let view = GTree.view ~model ~packing:sw#add () in
+  let _ = view#selection#set_mode `SINGLE in
+  let _ = view#set_rules_hint true in
+
+  let col = GTree.view_column ~title:"Argument" ()
+	      ~renderer:(GTree.cell_renderer_text [], ["text",argument]) in
+  let _ = view#append_column col in
+  let col = GTree.view_column ~title:"Tactics" ()
+	      ~renderer:(GTree.cell_renderer_text [], ["text",tactic]) in
+  let _ = view#append_column col in
+  let col = GTree.view_column ~title:"Status" ()
+	      ~renderer:(GTree.cell_renderer_toggle [], ["active",status]) in
+  let _ = view#append_column col in
+  let col = GTree.view_column ~title:"Delta Goal" ()
+	      ~renderer:(GTree.cell_renderer_text [], ["text",nb_goals]) in
+  let _ = view#append_column col in 
+
+  let _ = GMisc.separator `HORIZONTAL ~packing:box1#pack () in
+  
+  let box2 = GPack.vbox ~spacing: 10 ~border_width: 10 ~packing: box1#pack () 
+  in
+  let button_stop = GButton.button ~label: "Stop" ~packing: box2#add () in
+  let _ = button_stop#connect#clicked ~callback: window#misc#hide in
+
+object(self)
+  val window = window
+  val roots = Hashtbl.create 17
+  val mutable tbl = MyMap.empty 
+  val blaster_lock = Mutex.create () 
+  method lock = blaster_lock 
+  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) 
+    = 
+    let root_iter = 
+      try Hashtbl.find roots root 
+      with Not_found -> 
+	let nr = new_arg root in
+	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
+
+  method clear () = 
+    model#clear ();      
+    tbl <- MyMap.empty;
+    Hashtbl.clear roots;
+    
+  method blaster () = 
+    view#expand_all ();
+    try MyMap.iter 
+      (fun root_name l ->
+	 try 
+	   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;
+				       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 
+	     )
+	     l
+	 with Done -> ())
+      tbl;
+      Condition.signal blaster_killed;
+      prerr_endline "End of blaster";
+    with Stop ->
+      Condition.signal blaster_killed;
+      prerr_endline "End of blaster (stopped !)";
+
+  initializer 
+    ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));
+    ignore (view#selection#connect#after#changed ~callback:
+	      begin fun () ->
+		prerr_endline "selection changed";
+		List.iter 
+		  (fun path ->let pt = GtkTree.TreePath.to_string path in
+		     let it = model#get_iter path in
+		     prerr_endline (string_of_bool (model#iter_is_valid it));
+		     let name = model#get 
+				  ~row:(if String.length pt >1 then begin
+					  ignore (GtkTree.TreePath.up path);
+					  model#get_iter path
+					end else it
+				       ) 
+				  ~column:argument in
+		     let tactic = model#get ~row:it ~column:tactic in
+		     prerr_endline ("Got name: "^name);
+		     let success = model#get ~row:it ~column:status in
+		     if success then try 
+		       prerr_endline "Got success";
+		       let _,_,f = MyMap.find tactic (MyMap.find name tbl) in
+		       f ();
+		       (* window#misc#hide () *)
+		     with _ -> ()
+		  )
+		  view#selection#get_selected_rows
+	      end);
+
+(* needs lablgtk2 update    ignore (view#connect#after#row_activated
+   (fun path vcol ->
+   prerr_endline "Activated";
+   );
+*)
+end
+
+let blaster_window = ref None
+
+let main n = blaster_window := Some (new blaster_window n)
+
+let present_blaster_window () = match !blaster_window with 
+  | None -> failwith "No blaster window."
+  | Some c -> c#window#misc#show (* present*) (); c
+
+
+let blaster_window () = match !blaster_window with 
+  | None -> failwith "No blaster window."
+  | Some c -> c
+
+
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
new file mode 100644
index 00000000..42b65048
--- /dev/null
+++ b/ide/command_windows.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: command_windows.ml,v 1.13.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+
+class command_window () = 
+  let window = GWindow.window 
+		 ~allow_grow:true ~allow_shrink:true 
+		 ~width:320 ~height:200
+		 ~position:`CENTER
+		 ~title:"CoqIde queries" ~show:false ()
+  in
+  let accel_group = GtkData.AccelGroup.create () in
+  let vbox = GPack.vbox ~homogeneous:false ~packing:window#add () in
+  let toolbar = GButton.toolbar 
+		  ~orientation:`HORIZONTAL 
+		  ~style:`ICONS
+		  ~tooltips:true 
+		  ~packing:(vbox#pack 
+			       ~expand:false
+			       ~fill:false)
+		  ()
+  in
+  let notebook = GPack.notebook ~scrollable:true 
+		   ~packing:(vbox#pack 
+			       ~expand:true
+			       ~fill:true
+			    ) 
+		   ()
+  in
+  let _ = 
+    toolbar#insert_button
+      ~tooltip:"Hide Window"
+      ~text:"Hide Window"
+      ~icon:(Ideutils.stock_to_widget ~size:`LARGE_TOOLBAR `CLOSE)
+      ~callback:window#misc#hide
+      ()
+  in
+  let new_page_menu = 
+    toolbar#insert_button
+      ~tooltip:"New Page"
+      ~text:"New Page"
+      ~icon:(Ideutils.stock_to_widget ~size:`LARGE_TOOLBAR `NEW)
+(*
+      ~callback:window#misc#hide
+*)
+      ()
+  in
+
+  let kill_page_menu = 
+    toolbar#insert_button
+      ~tooltip:"Kill Page"
+      ~text:"Kill Page"
+      ~icon:(Ideutils.stock_to_widget ~size:`LARGE_TOOLBAR `DELETE)
+      ~callback:(fun () -> notebook#remove_page notebook#current_page)
+      ()
+  in
+object(self)
+  val window = window
+(*
+  val menubar = menubar
+*)
+  val new_page_menu = new_page_menu
+  val notebook = notebook
+  method window = window
+  method new_command ?command ?term () =
+    let frame = GBin.frame 
+		  ~shadow_type:`ETCHED_OUT
+		  ~packing:notebook#append_page
+		  ()
+    in
+    notebook#goto_page (notebook#page_num frame#coerce);
+    let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
+    let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+    let combo = GEdit.combo ~popdown_strings:Coq_commands.state_preserving
+		  ~enable_arrow_keys:true
+		  ~allow_empty:false
+		  ~value_in_list:false (* true is not ok with disable_activate...*)
+		  ~packing:hbox#pack
+		  ()
+    in
+    combo#disable_activate ();
+    let on_activate c () = 
+      if List.mem combo#entry#text Coq_commands.state_preserving then c () 
+      else prerr_endline "Not a state preserving command" 
+    in
+    let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in
+    entry#misc#set_can_default true;
+    let r_bin =
+      GBin.scrolled_window 
+	~vpolicy:`AUTOMATIC 
+	~hpolicy:`AUTOMATIC
+	~packing:(vbox#pack ~fill:true ~expand:true) () in
+    let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
+    let result = GText.view ~packing:r_bin#add () in
+    result#misc#set_can_focus true; (* false causes problems for selection *)
+    result#set_editable false;
+    let callback () =
+      let com = combo#entry#text in
+      let phrase = 
+	if String.get com (String.length com - 1) = '.'
+	then com ^ " " else com ^ " " ^ entry#text ^" . " 
+      in
+      try
+	ignore(Coq.interp false phrase);
+	result#buffer#set_text 
+	  ("Result for command " ^ phrase ^ ":\n" ^ Ideutils.read_stdout ())
+      with e ->
+	let (s,loc) = Coq.process_exn e in
+	assert (Glib.Utf8.validate s);
+	result#buffer#set_text s
+    in
+    ignore (combo#entry#connect#activate ~callback:(on_activate callback));
+    ignore (ok_b#connect#clicked ~callback:(on_activate callback));
+
+    begin match command,term with 
+      | None,None -> ()
+      | Some c, None -> 
+	  combo#entry#set_text c;
+	  
+      | Some c, Some t -> 
+	  combo#entry#set_text c;
+	  entry#set_text t
+	 
+      | None , Some t -> 
+	  entry#set_text t
+    end;
+    on_activate callback ();
+    entry#misc#grab_focus ();
+    entry#misc#grab_default ();
+    ignore (entry#connect#activate ~callback);
+    ignore (combo#entry#connect#activate ~callback);
+    self#window#present ()
+
+  initializer 
+    ignore (new_page_menu#connect#clicked self#new_command);
+    ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));
+end
+
+let command_window = ref None
+
+let main () = command_window := Some (new command_window ())
+
+let command_window () = match !command_window with 
+  | None -> failwith "No command window."
+  | Some c -> c
diff --git a/ide/command_windows.mli b/ide/command_windows.mli
new file mode 100644
index 00000000..014be777
--- /dev/null
+++ b/ide/command_windows.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: command_windows.mli,v 1.1.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+
+class command_window :
+  unit ->
+  object
+    method new_command : ?command:string -> ?term:string -> unit -> unit
+    method window : GWindow.window
+  end
+
+val main : unit -> unit
+
+val command_window : unit -> command_window
+
+
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
new file mode 100644
index 00000000..1c0720d1
--- /dev/null
+++ b/ide/config_lexer.mll
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: config_lexer.mll,v 1.4.2.1 2004/07/16 19:30:19 herbelin Exp $ *)
+
+{
+
+  open Lexing
+  open Format
+  open Config_parser
+  open Util
+
+  let string_buffer = Buffer.create 1024
+
+}
+
+let space = [' ' '\010' '\013' '\009' '\012']
+let char = ['A'-'Z' 'a'-'z' '_' '0'-'9']
+let ident = char+
+
+rule token = parse
+  | space+        { token lexbuf }
+  | '#' [^ '\n']* { token lexbuf }
+  | ident { IDENT (lexeme lexbuf) }
+  | '='   { EQUAL }
+  | '"'   { Buffer.reset string_buffer; 
+	    Buffer.add_char string_buffer '"';
+	    string lexbuf;
+	    let s = Buffer.contents string_buffer in
+	    STRING (Scanf.sscanf s "%S" (fun s -> s)) }
+  | _     { let c = lexeme_start lexbuf in
+	    eprintf ".coqiderc: invalid character (%d)\n@." c; 
+	    token lexbuf }
+  | eof   { EOF }
+
+and string = parse
+  | '"'  { Buffer.add_char string_buffer '"' }
+  | '\\' '"' | _ 
+         { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf }
+  | eof  { eprintf ".coqiderc: unterminated string\n@." }
+
+{
+
+  let load_file f =
+    let c = open_in f in
+    let lb = from_channel c in
+    let m = Config_parser.prefs token lb in
+    close_in c;
+    m
+
+  let print_file f m =
+    let c = open_out f in
+    let fmt = formatter_of_out_channel c in
+    let rec print_list fmt = function
+      | [] -> ()
+      | s :: sl -> fprintf fmt "%S@ %a" s print_list sl
+    in
+    Stringmap.iter 
+      (fun k s -> fprintf fmt "@[<hov 2>%s = %a@]@\n" k print_list s) m;
+    fprintf fmt "@.";
+    close_out c
+
+}
diff --git a/ide/config_parser.mly b/ide/config_parser.mly
new file mode 100644
index 00000000..48005efe
--- /dev/null
+++ b/ide/config_parser.mly
@@ -0,0 +1,43 @@
+/***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: config_parser.mly,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ */
+
+%{
+
+  open Parsing
+  open Util
+
+%}
+
+%token <string> IDENT STRING
+%token EQUAL EOF
+
+%type <(string list) Util.Stringmap.t> prefs
+%start prefs
+
+%%
+
+prefs:
+  pref_list EOF { $1 }
+;
+
+pref_list:
+   pref_list pref { let (k,d) = $2 in Stringmap.add k d $1 }
+ | /* epsilon */  { Stringmap.empty }
+;
+
+pref:
+  IDENT EQUAL string_list { ($1, List.rev $3) }
+;
+
+string_list:
+   string_list STRING { $2 :: $1 }
+ | /* epsilon */      { [] }
+;
+
diff --git a/ide/coq.ml b/ide/coq.ml
new file mode 100644
index 00000000..e582f2d9
--- /dev/null
+++ b/ide/coq.ml
@@ -0,0 +1,479 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq.ml,v 1.38.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+open Vernac
+open Vernacexpr
+open Pfedit
+open Pp
+open Util
+open Names
+open Term
+open Printer
+open Environ
+open Evarutil
+open Evd
+open Hipattern
+open Tacmach
+open Reductionops
+open Termops
+open Ideutils
+
+let prerr_endline s = if !debug then prerr_endline s else ()
+
+let output = ref (Format.formatter_of_out_channel stdout)
+
+let msg m = 
+  let b =  Buffer.create 103 in
+  Pp.msg_with (Format.formatter_of_buffer b) m;
+  Buffer.contents b
+
+let msgnl m = 
+  (msg m)^"\n"
+
+let init () = 
+  (* To hide goal in lower window. 
+     Problem: should not hide "xx is assumed"
+     messages *)
+(**)
+  Options.make_silent true;
+(**)
+  Coqtop.init_ide ()
+
+
+let i = ref 0
+
+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)
+    (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_in_coq_path f = 
+  try 
+  let base = Filename.chop_extension (Filename.basename f) in
+  let _ = Library.locate_qualified_library 
+	    (Libnames.make_qualid Names.empty_dirpath 
+	       (Names.id_of_string base)) in
+  prerr_endline (f ^ "is in coq path");
+  true
+  with _ ->  
+    prerr_endline (f ^ "is NOT in coq path");
+    false  
+
+let is_in_proof_mode () = 
+  try ignore (get_pftreestate ()); true with _ -> false
+
+let user_error_loc l s =
+  raise (Stdpp.Exc_located (l, Util.UserError ("CoqIde", s)))
+
+let interp verbosely s = 
+  prerr_endline "Starting interp...";
+  prerr_endline s;
+  let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+  let pe = Pcoq.Gram.Entry.parse Pcoq.main_entry pa in
+  match pe with 
+    | None -> assert false
+    | Some((loc,vernac) as last) ->
+	match vernac with
+	  | VernacDefinition _  | VernacStartTheoremProof _ 
+	  | VernacBeginSection _ | VernacGoal _
+	  | VernacDefineModule _ | VernacDeclareModuleType _
+	  | VernacDeclareTacticDefinition _
+		when is_in_proof_mode () -> 
+		  user_error_loc loc (str "CoqIDE do not support nested goals")
+	  | VernacDebug _ ->
+	      user_error_loc loc (str "Debug mode not available within CoqIDE")
+	  | VernacResetName _
+	  | VernacResetInitial 
+	  | VernacBack _ 
+	  | VernacAbort _ 
+	  | VernacAbortAll
+	  | VernacRestart
+	  | VernacSuspend
+	  | VernacResume _
+	  | VernacUndo _ ->
+	      user_error_loc loc (str "Use CoqIDE navigation instead") 
+	  | _ ->
+	      begin
+		match vernac with
+		  | VernacPrintOption _ 
+		  | VernacCheckMayEval _
+		  | VernacGlobalCheck _
+		  | VernacPrint _
+		  | VernacSearch _ 
+		    -> !flash_info 
+			"Warning: query commands should not be inserted in scripts" 
+		  | VernacDefinition (_,_,DefineBody _,_) 
+		  | VernacInductive _
+		  | VernacFixpoint _
+		  | VernacCoFixpoint _
+		  | VernacEndProof _
+		    -> Options.make_silent (not verbosely)
+		  | _ -> ()
+	      end;
+	      Vernac.raw_do_vernac (Pcoq.Gram.parsable (Stream.of_string s));
+	      Options.make_silent true;
+	      prerr_endline ("...Done with interp of : "^s);
+	      last
+
+let interp_and_replace s = 
+  let result = interp false s in
+  let msg = read_stdout () in
+  result,msg
+
+let nb_subgoals pf =
+  List.length (fst (Refiner.frontier (Tacmach.proof_of_pftreestate pf)))
+
+type tried_tactic = 
+  | Interrupted
+  | Success of int (* nb of goals after *)
+  | Failed
+
+let try_interptac s = 
+  try
+    prerr_endline ("Starting try_interptac: "^s);
+    let pf = get_pftreestate () in
+    let pe = Pcoq.Gram.Entry.parse 
+	       Pcoq.main_entry 
+	       (Pcoq.Gram.parsable (Stream.of_string s)) 
+    in match pe with 
+    | Some (loc,(VernacSolve (n, tac, _))) ->
+	let tac = Tacinterp.interp tac in
+	let pf' = solve_nth_pftreestate n tac pf in
+	prerr_endline "Success";
+	let nb_goals = nb_subgoals pf' - nb_subgoals pf in
+	Success nb_goals
+    | _ ->
+	prerr_endline "try_interptac: not a tactic"; Failed
+  with 
+  | Sys.Break | Stdpp.Exc_located (_,Sys.Break)
+      -> prerr_endline "try_interp: interrupted"; Interrupted
+  | Stdpp.Exc_located (_,e) -> prerr_endline ("try_interp: failed ("^(Printexc.to_string e)); Failed
+  | e -> Failed	  
+
+let is_tactic = function
+  | VernacSolve _ -> true
+  | _ -> false
+
+
+let rec is_pervasive_exn = function
+  | Out_of_memory | Stack_overflow | Sys.Break -> true
+  | Error_in_file (_,_,e) -> is_pervasive_exn e
+  | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
+  | DuringCommandInterp (_,e) -> is_pervasive_exn e
+  | _ -> false
+
+let print_toplevel_error exc =
+  let (dloc,exc) =
+    match exc with
+      | DuringCommandInterp (loc,ie) ->
+          if loc = dummy_loc then (None,ie) else (Some loc, ie)
+      | _ -> (None, exc) 
+  in
+  let (loc,exc) =
+    match exc with
+      | Stdpp.Exc_located (loc, ie) -> (Some loc),ie
+      | Error_in_file (s, (_,fname, loc), ie) -> None, ie
+      | _ -> dloc,exc
+  in
+  match exc with
+    | End_of_input  -> 	str "Please report: End of input",None
+    | Vernacexpr.ProtectedLoop -> 
+	str "ProtectedLoop  not allowed by coqide!",None
+    | Vernacexpr.Drop ->  str "Drop is not allowed by coqide!",None
+    | Vernacexpr.Quit -> str "Quit is not allowed by coqide! Use menus.",None
+    | _ -> 
+	(try Cerrors.explain_exn exc with e -> 
+	   str "Failed to explain error. This is an internal Coq error. Please report.\n"
+	   ++ str (Printexc.to_string  e)),
+	(if is_pervasive_exn exc then None else loc)
+
+let process_exn e = let s,loc= print_toplevel_error e in (msgnl s,loc)
+
+let interp_last last = 
+  prerr_string "*";
+  try
+    vernac_com (States.with_heavy_rollback Vernacentries.interp) last
+  with e ->
+    let s,_ = process_exn e in prerr_endline ("Replay during undo failed because: "^s);
+    raise e
+
+
+type hyp = env * evar_map *
+           ((identifier * string) * constr option * constr) * 
+           (string * string)
+type concl = env * evar_map * constr * 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))
+
+let prepare_hyps sigma env =
+  assert (rel_context env = []);
+  let hyps =
+    fold_named_context
+      (fun env d acc -> let hyp = prepare_hyp sigma env d in hyp :: acc)
+      env ~init:[] 
+  in
+  List.rev hyps
+
+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)))
+
+let get_current_goals () = 
+    let pfts = get_pftreestate () in
+    let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in 
+    let sigma = Tacmach.evc_of_pftreestate pfts in
+    List.map (prepare_goal sigma) gls
+
+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)
+
+
+type word_class = Normal | Kwd | Reserved
+
+
+let kwd = [(* "Compile";"Inductive";"Qed";"Type";"end";"Axiom";
+	      "Definition";"Load";"Quit";"Variable";"in";"Cases";"FixPoint";
+	      "Parameter";"Set";"of";"CoFixpoint";"Grammar";"Proof";"Syntax";
+	      "using";"CoInductive";"Hypothesis";"Prop";"Theorem";
+	   *)
+  "Add"; "AddPath"; "Axiom"; "Chapter"; "CoFixpoint";
+  "CoInductive"; "Defined"; "Definition"; 
+  "End"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Hint";
+  "Hypothesis"; "Immediate"; "Implicits"; "Import"; "Inductive"; 
+  "Infix"; "Lemma"; "Load"; "Local"; 
+  "Match"; "Module"; "Module Type";
+  "Mutual"; "Parameter"; "Print"; "Proof"; "Qed";
+  "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme";
+  "Section"; "Show"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; 
+  "Unset"; "Variable"; "Variables"; 
+]
+	    
+let reserved = []
+
+module SHashtbl = 
+  Hashtbl.Make 
+    (struct 
+       type t = string
+       let equal = ( = )
+       let hash = Hashtbl.hash
+     end)
+
+
+let word_tbl = SHashtbl.create 37
+let _ = 
+  List.iter (fun w -> SHashtbl.add word_tbl w Kwd) kwd;
+  List.iter (fun w -> SHashtbl.add word_tbl w Reserved) reserved
+
+let word_class s = 
+  try
+    SHashtbl.find word_tbl s
+  with Not_found -> Normal
+
+type reset_info = NoReset | Reset of Names.identifier * bool ref
+
+let compute_reset_info = function 
+  | VernacDefinition (_, (_,id), DefineBody _, _) 
+  | VernacBeginSection (_,id) 
+  | VernacDefineModule ((_,id), _, _, _) 
+  | VernacDeclareModule ((_,id), _, _, _)
+  | VernacDeclareModuleType ((_,id), _, _)
+  | VernacAssumption (_, (_,((_,id)::_,_))::_)
+  | VernacInductive (_, ((_,id),_,_,_,_) :: _) ->
+      Reset (id, ref true)
+  | VernacDefinition (_, (_,id), ProveBody _, _)
+  | VernacStartTheoremProof (_, (_,id), _, _, _) ->
+      Reset (id, ref false)
+  | _ -> NoReset
+
+let reset_initial () = 
+  prerr_endline "Reset initial called"; flush stderr;
+  Vernacentries.abort_refine Lib.reset_initial ()
+
+let reset_to id = 
+  prerr_endline ("Reset called with "^(string_of_id id));
+  Vernacentries.abort_refine Lib.reset_name (Util.dummy_loc,id)
+let reset_to_mod id = 
+  prerr_endline ("Reset called to Mod/Sect with "^(string_of_id id)); 
+  Vernacentries.abort_refine Lib.reset_mod (Util.dummy_loc,id)
+
+
+let hyp_menu (env, sigma, ((coqident,ident),_,ast),(s,pr_ast)) =
+  [("clear "^ident),("clear "^ident^".");
+   
+   ("apply "^ident),
+   ("apply "^ident^".");
+   
+   ("exact "^ident),
+   ("exact "^ident^".");
+
+   ("generalize "^ident),
+   ("generalize "^ident^".");
+   
+   ("absurd <"^ident^">"),
+   ("absurd "^
+    pr_ast
+    ^".") ] @
+
+   (if is_equation ast then
+      [ "discriminate "^ident, "discriminate "^ident^".";
+	"injection "^ident, "injection "^ident^"." ]
+    else
+      []) @
+   
+   (let _,t = splay_prod env sigma ast in
+    if is_equation t then 
+      [ "rewrite "^ident, "rewrite "^ident^".";
+	"rewrite <- "^ident, "rewrite <- "^ident^"." ]
+    else
+      []) @
+   
+  [("elim "^ident),
+   ("elim "^ident^".");
+   
+   ("inversion "^ident),
+   ("inversion "^ident^".");
+   
+   ("inversion clear "^ident),
+   ("inversion_clear "^ident^".")] 
+
+let concl_menu (_,_,concl,_) = 
+  let is_eq = is_equation concl in
+  ["intro", "intro.";
+   "intros", "intros.";
+   "intuition","intuition." ] @
+   
+   (if is_eq then 
+      ["reflexivity", "reflexivity.";
+       "discriminate", "discriminate.";
+       "symmetry", "symmetry." ]
+    else 
+      []) @
+
+  ["assumption" ,"assumption.";
+   "omega", "omega.";
+   "ring", "ring.";
+   "auto with *", "auto with *.";
+   "eauto with *", "eauto with *.";
+   "tauto", "tauto.";
+   "trivial", "trivial.";
+   "decide equality", "decide equality.";
+
+   "simpl", "simpl.";
+   "subst", "subst.";
+
+   "red", "red.";
+   "split", "split.";
+   "left", "left.";
+   "right", "right.";
+  ]
+
+
+let id_of_name = function 
+  | Names.Anonymous -> id_of_string "x" 
+  | Names.Name x -> x
+
+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' = 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 is_state_preserving = function
+  | VernacPrint _ | VernacPrintOption _ | VernacGlobalCheck _
+  | VernacCheckMayEval _ | VernacSearch _ | VernacLocate _ 
+  | VernacShow _ | VernacMemOption _ | VernacComments _ 
+  | VernacChdir None | VernacNop -> 
+      prerr_endline "state preserving command found"; true
+  | _ -> 
+      false
+
+
+let current_status () = 
+  let path = msg (Libnames.pr_dirpath (Lib.cwd ())) in
+  let path = if path = "Top" then "Ready" else "Ready in " ^ String.sub path 4 (String.length path - 4) in
+  try
+    path ^ ", proving " ^ (Names.string_of_id (Pfedit.get_current_proof_name ()))
+  with _ -> path
+
+  
diff --git a/ide/coq.mli b/ide/coq.mli
new file mode 100644
index 00000000..bcebd4e6
--- /dev/null
+++ b/ide/coq.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq.mli,v 1.14.2.2 2004/07/18 11:20:15 herbelin Exp $ *)
+
+open Names
+open Term
+open Environ
+open Evd
+
+val version : unit -> string
+
+val init : unit -> string list 
+val interp : bool -> string -> Util.loc * Vernacexpr.vernac_expr
+val interp_last : Util.loc * Vernacexpr.vernac_expr -> unit
+val interp_and_replace : string -> (Util.loc * Vernacexpr.vernac_expr) * string
+
+val is_tactic : Vernacexpr.vernac_expr -> bool
+val is_state_preserving : Vernacexpr.vernac_expr -> bool
+
+(* type hyp = (identifier * constr option * constr) * string *)
+
+type hyp = env * evar_map * 
+           ((identifier*string) * constr option * constr) * (string * string)
+type concl = env * evar_map * constr * string
+type goal = hyp list * concl
+
+val get_current_goals : unit -> goal list
+
+val get_current_goals_nb : unit -> int
+
+val print_no_goal : unit -> string
+
+val process_exn : exn -> string*(Util.loc option)
+
+type reset_info = NoReset | Reset of Names.identifier * bool ref
+
+val compute_reset_info : Vernacexpr.vernac_expr -> reset_info
+val reset_initial : unit -> unit
+val reset_to : identifier -> unit
+val reset_to_mod : identifier -> unit
+
+val hyp_menu : hyp -> (string * string) list
+val concl_menu : concl -> (string * string) list
+
+val is_in_coq_lib : string -> bool
+val is_in_coq_path : string -> bool
+
+val make_cases : string -> string list list
+
+
+type tried_tactic = 
+  | Interrupted
+  | Success of int (* nb of goals after *)
+  | Failed
+
+val try_interptac: string -> tried_tactic
+
+(* Message to display in lower status bar. *)
+
+val current_status : unit -> string
diff --git a/ide/coq.png b/ide/coq.png
new file mode 100644
index 00000000..011203f7
--- /dev/null
+++ b/ide/coq.png
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
new file mode 100644
index 00000000..1169d438
--- /dev/null
+++ b/ide/coq_commands.ml
@@ -0,0 +1,406 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq_commands.ml,v 1.15.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+let commands = [
+  [(* "Abort"; *)
+   "Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T.";
+   "Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T.";
+   "Add Field";
+   "Add LoadPath";
+   "Add ML Path";
+   "Add Morphism";
+   "Add Printing If";
+   "Add Printing Let";
+   "Add Rec LoadPath";
+   "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 Setoid";
+   "Axiom";];
+  [(* "Back"; *) ];
+  ["Canonical Structure";
+   "Chapter";
+   "Coercion";
+   "Coercion Local";
+   "CoFixpoint";
+   "CoInductive";
+  ];
+  ["Declare ML Module";
+   "Defined.";
+   "Definition";
+   "Derive Dependent Inversion";
+   "Derive Dependent Inversion__clear";
+   "Derive Inversion";
+   "Derive Inversion__clear";
+  ];
+  ["End";
+   "End Silent.";
+   "Eval"; 
+   "Extract Constant";
+   "Extract Inductive";
+   "Extraction Inline";
+   "Extraction Language";
+   "Extraction NoInline";];
+  ["Fact";
+   "Fixpoint";
+   "Focus";];
+  ["Global Variable";
+   "Goal";
+   "Grammar";];
+  ["Hint";
+   "Hint Constructors";
+   "Hint Extern";
+   "Hint Immediate";
+   "Hint Resolve";
+   "Hint Rewrite";
+   "Hint Unfold";
+   "Hypothesis";];
+  ["Identity Coercion";
+   "Implicits";
+   "Inductive";
+   "Infix";
+   ];
+  ["Lemma";
+   "Load";
+   "Load Verbose";
+   "Local";
+   "Ltac";
+  ];
+  ["Module";
+   "Module Type";
+   "Mutual Inductive";];
+  ["Notation";];
+  ["Opaque";];
+  ["Parameter";
+   "Proof."];
+  ["Qed.";
+   ];
+  ["Read Module";
+   "Record";
+   "Remark";
+   "Remove LoadPath";
+   "Remove Printing If";
+   "Remove Printing Let";
+   "Require";
+   "Require Export";
+   "Require Import";
+   "Reset Extraction Inline";
+   "Restore State"; 
+   ];
+  [  "Save.";
+     "Scheme";
+     "Section";
+     "Set Extraction AutoInline";
+     "Set Extraction Optimize";
+     "Set Hyps__limit";
+     "Set Implicit Arguments";
+     "Set Printing Coercion";
+     "Set Printing Coercions";
+     "Set Printing Synth";
+     "Set Printing Wildcard";
+     "Set Silent.";
+     "Set Undo";
+     (*"Show";
+     "Show Conjectures";
+     "Show Implicits";
+     "Show Intro";
+     "Show Intros";
+     "Show Programs";
+     "Show Proof";
+     "Show Script";
+     "Show Tree";*)
+     "Structure";
+     (* "Suspend"; *)
+     "Syntactic Definition";
+     "Syntax";];
+  [
+   "Test Printing If";
+   "Test Printing Let";
+   "Test Printing Synth";
+   "Test Printing Wildcard";
+   "Theorem";
+   "Time";
+   "Transparent";];
+  [(* "Undo"; *)
+   "Unfocus";
+   "Unset Extraction AutoInline";
+   "Unset Extraction Optimize";
+   "Unset Hyps__limit";
+   "Unset Implicit Arguments";
+   "Unset Printing Coercion";
+   "Unset Printing Coercions";
+   "Unset Printing Synth";
+   "Unset Printing Wildcard";
+   "Unset Silent.";
+   "Unset Undo";];
+  ["Variable";
+   "Variables";];
+  ["Write State";];
+]
+
+let state_preserving = [
+  "Check";
+  "Eval";
+  "Eval compute in";
+  "Extraction";
+  "Extraction Library";
+  "Extraction Module";
+  "Inspect";
+  "Locate";
+  "Print";
+  "Print All.";
+  "Print Classes";
+  "Print Coercion Paths";
+  "Print Coercions";
+  "Print Extraction Inline";
+  "Print Grammar";
+  "Print Graph";
+  "Print Hint";
+  "Print Hint *";
+  "Print HintDb";
+  "Print Implicit";
+  "Print LoadPath";
+  "Print ML Modules";
+  "Print ML Path";
+  "Print Module";
+  "Print Module Type";
+  "Print Modules";
+  "Print Proof";
+  "Print Scope";
+  "Print Scopes.";
+  "Print Section";
+  
+  "Print Table Printing If.";
+  "Print Table Printing Let.";
+  "Print Tables.";
+  "Print Term";
+
+  "Print Visibility";
+
+  "Pwd.";
+
+  "Recursive Extraction";
+  "Recursive Extraction Library";
+
+  "Search";
+  "SearchAbout";
+  "SearchPattern";
+  "SearchRewrite";
+
+  "Show";
+  "Show Conjectures";
+  "Show Implicits";
+  "Show Intro";
+  "Show Intros";
+  "Show Proof";
+  "Show Script";
+  "Show Tree";
+
+  "Test Printing If";
+  "Test Printing Let";
+  "Test Printing Synth";
+  "Test Printing Wildcard";
+]
+
+
+let tactics = 
+  [
+    [
+      "abstract";
+      "absurd";
+      "apply";
+      "apply __ with";
+      "assert";
+      "assert (__:__)";
+      "assert (__:=__)";
+      "assumption";
+      "auto";
+      "auto with";
+      "autorewrite";
+    ];
+
+   [
+     "case";
+     "case __ with";
+     "casetype";
+     "cbv";
+     "cbv in";
+     "change";
+     "change __ in";
+     "clear";
+     "clearbody";
+     "cofix";
+     "compare";
+     "compute";
+     "compute in";
+     "congruence";
+     "constructor";
+     "constructor __ with";
+     "contradiction";
+     "cut";
+     "cutrewrite";
+   ];
+
+   [
+     "decide equality";
+     "decompose";
+     "decompose record";
+     "decompose sum";
+     "dependent inversion";
+     "dependent inversion __ with";
+     "dependent inversion__clear";
+     "dependent inversion__clear __ with";
+     "dependent rewrite ->";
+     "dependent rewrite <-";
+     "destruct";
+     "discriminate";
+     "do";
+     "double induction";
+   ];
+
+   [
+     "eapply";
+     "eauto";
+     "eauto with";
+     "eexact";
+     "elim";
+     "elim __ using";
+     "elim __ with";
+     "elimtype";
+     "exact";
+     "exists";
+   ];
+
+   [
+     "fail";
+     "field";
+     "first";
+     "firstorder";
+     "firstorder using";
+     "firstorder with";
+     "fix";
+     "fix __ with";
+     "fold";
+     "fold __ in";
+     "fourier";
+     "functional induction";
+   ];
+
+   [
+     "generalize";
+     "generalize dependent";
+   ];
+   
+   [
+     "hnf";
+   ];
+
+   [
+     "idtac";
+     "induction";
+     "info";
+     "injection";
+     "instantiate (__:=__)";
+     "intro";
+     "intro after";
+     "intro __ after";
+     "intros";
+     "intros until";
+     "intuition";
+     "inversion";
+     "inversion __ in";
+     "inversion __ using";
+     "inversion __ using __ in";
+     "inversion__clear";
+     "inversion__clear __ in";
+   ];
+
+   [
+     "jp <n>";
+     "jp";
+   ];
+
+   [
+     "lapply";
+     "lazy";
+     "lazy in";
+     "left";
+   ];
+
+   [
+     "move __ after";
+   ];
+
+   [
+     "omega";
+   ];
+
+   [
+     "pattern";
+     "pose";
+     "pose __:=__)";
+     "progress";
+   ];
+
+   [
+     "quote";
+   ];
+
+   [
+     "red";
+     "red in";
+     "refine";
+     "reflexivity";
+     "rename __ into";
+     "repeat";
+     "replace __ with";
+     "rewrite";
+     "rewrite __ in";
+     "rewrite <-";
+     "rewrite <- __ in";
+     "right";
+     "ring";
+   ];
+
+   [
+     "set";
+     "set (__:=__)";
+     "setoid__replace";
+     "setoid__rewrite";
+     "simpl";
+     "simpl __ in";
+     "simple destruct";
+     "simple induction";
+     "simple inversion";
+     "simplify__eq";
+     "solve";
+     "split";
+(*     "split__Rabs";
+     "split__Rmult";
+*)
+     "subst";
+     "symmetry";
+     "symmetry in";
+   ];
+
+   [
+     "tauto";
+     "transitivity";
+     "trivial";
+     "try";
+   ];
+   
+   [
+     "unfold";
+     "unfold __ in";
+   ];
+]
+
+
diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml
new file mode 100644
index 00000000..4dd20b47
--- /dev/null
+++ b/ide/coq_tactics.ml
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq_tactics.ml,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+let tactics = [
+  "Abstract";
+  "Absurd";
+  "Apply";
+  "Apply ... with";
+  "Assert";
+  "Assumption";
+  "Auto";
+  "AutoRewrite";
+  "Binding list";
+  "Case";
+  "Case ... with";
+  "Cbv";
+  "Change";
+  "Change ... in";
+  "Clear";
+  "ClearBody";
+  "Compare";
+  "Compute";
+  "Constructor";
+  "Constructor ... with";
+  "Contradiction";
+  "Conversion tactics";
+  "Cut";
+  "CutRewrite";
+  "Decide Equality";
+  "Decompose";
+  "Decompose Record";
+  "Decompose Sum";
+  "Dependent Inversion";
+  "Dependent Inversion ... with";
+  "Dependent Inversion_clear";
+  "Dependent Inversion_clear ... with";
+  "Dependent Rewrite ->";
+  "Dependent Rewrite <-";
+  "Derive Inversion";
+  "Destruct";
+  "Discriminate";
+  "DiscrR";
+  "Do";
+  "Double Induction";
+  "EApply";
+  "EAuto";
+  "Elim ... using";
+  "Elim ... with";
+  "ElimType";
+  "Exact";
+  "Exists";
+  "Fail";
+  "Field";
+  "First";
+  "Fold";
+  "Fourier";
+  "Generalize";
+  "Generalize Dependent";
+  "Print Hint";
+  "Hnf";
+  "Idtac";
+  "Induction";
+  "Info";
+  "Injection";
+  "Intro";
+  "Intro ... after";
+  "Intro after";
+  "Intros";
+  "Intros pattern";
+  "Intros until";
+  "Intuition";
+  "Inversion";
+  "Inversion ... in";
+  "Inversion ... using";
+  "Inversion ... using ... in";
+  "Inversion_clear";
+  "Inversion_clear ... in";
+  "LApply";
+  "Lazy";
+  "Left";
+  "LetTac";
+  "Move";
+  "NewDestruct";
+  "NewInduction";
+  "Omega";
+  "Orelse";
+  "Pattern";
+  "Pose";
+  "Prolog";
+  "Quote";
+  "Red";
+  "Refine";
+  "Reflexivity";
+  "Rename";
+  "Repeat";
+  "Replace ... with";
+  "Rewrite";
+  "Rewrite ->";
+  "Rewrite -> ... in";
+  "Rewrite <-";
+  "Rewrite <- ... in";
+  "Rewrite ... in";
+  "Right";
+  "Ring";
+  "Setoid_replace";
+  "Setoid_rewrite";
+  "Simpl";
+  "Simple Inversion";
+  "Simplify_eq";
+  "Solve";
+  "Split";
+  "SplitAbsolu";
+  "SplitRmult";
+  "Subst";
+  "Symmetry";
+  "Tacticals";
+  "Tauto";
+  "Transitivity";
+  "Trivial";
+  "Try";
+  "tactic macros";
+  "Unfold";
+  "Unfold ... in";
+]
diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli
new file mode 100644
index 00000000..8d603346
--- /dev/null
+++ b/ide/coq_tactics.mli
@@ -0,0 +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        *)
+(************************************************************************)
+
+(* $Id: coq_tactics.mli,v 1.1.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+val tactics : string list
+
diff --git a/ide/coqide.ml b/ide/coqide.ml
new file mode 100644
index 00000000..2169862e
--- /dev/null
+++ b/ide/coqide.ml
@@ -0,0 +1,3386 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqide.ml,v 1.99.2.2 2004/07/18 11:20:15 herbelin Exp $ *)
+
+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
+	
+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
+
+
+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
+
+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
+
+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
+
+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
+
+(* 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 
+  exception Found of int
+  type 'a t = ('a option) array ref
+  let create () = ref [||]
+  let length t = Array.length !t
+  let get t i = out_some (Array.get !t i)
+  let set t i v = Array.set !t i (Some v)
+  let remove t i = Array.set !t i None
+  let append t e = t := Array.append !t [|Some e|]; (Array.length !t)-1
+  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
+	
+  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
+end
+
+type 'a viewable_script =
+    {view : Undo.undoable_view;
+     mutable analyzed_view : 'a option;
+    }
+
+
+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
+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]
+
+let crash_save i =
+(*  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
+
+let ignore_break () =
+  List.iter
+    (fun i ->
+       try Sys.set_signal i (Sys.Signal_handle crash_save)
+       with _ -> prerr_endline "Signal ignored (normal if Win32)")
+    signals_to_crash;
+  Sys.set_signal Sys.sigint Sys.Signal_ignore
+
+(* Locking machinery for Coq kernel *)
+let coq_computing = Mutex.create ()
+
+(* To prevent Coq from interrupting during undoing...*)
+let coq_may_stop = Mutex.create ()
+
+let break () = 
+  prerr_endline "User break received:";
+  if not (Mutex.try_lock coq_computing) then 
+    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)";
+    end
+  else begin
+    Mutex.unlock coq_computing;
+    prerr_endline " ignored (not computing)"
+  end
+
+let full_do_if_not_computing text f x = 
+  ignore 
+    (Thread.create 
+       (async 
+	  (fun () ->
+	     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 () -> !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)"))
+       ())
+
+let do_if_not_computing text f x = 
+  ignore (full_do_if_not_computing text f x)
+
+
+let add_input_view tv = 
+  Vector.append input_views tv
+
+let get_input_view i = 
+  if 0 <= i && i < Vector.length input_views
+  then
+    Vector.get input_views i
+  else raise Not_found 
+
+let active_view = ref None
+
+let get_active_view () = Vector.get input_views (out_some !active_view)
+
+let set_active_view i = 
+  (match !active_view with  None -> () | Some 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
+
+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
+
+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 ()
+
+
+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 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 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)
+
+let is_on_word_limit it = inside_word it || ends_word it 
+
+let rec find_word_start it =
+  prerr_endline "Find word start";
+  if not it#nocopy#backward_char then 
+    (prerr_endline "find_word_start: cannot backward"; it)
+  else if is_word_char it#char
+  then find_word_start it
+  else (it#nocopy#forward_char; 
+	prerr_endline ("Word start at: "^(string_of_int it#offset));it)
+let find_word_start (it:GText.iter) = find_word_start it#copy
+
+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)
+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
+
+
+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
+		  
+let rec complete_forward w (it:GText.iter) = 
+  prerr_endline "Complete forward...";
+  match it#forward_search w with 
+    | None -> None
+    | 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)
+	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
+
+let rec complete input_buffer w (offset:int) =
+  match !last_completion with 
+    | Some (lw,loffset,lpos,backward)
+	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
+	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
+      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
+	  
+
+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
+
+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)
+
+type info =  {start:GText.mark;
+	      stop:GText.mark;
+	      ast:Util.loc * Vernacexpr.vernac_expr;
+	      reset_info:Coq.reset_info;
+	     }
+
+exception Size of int
+let (processed_stack:info Stack.t) = Stack.create ()
+let push x = Stack.push x processed_stack
+let pop () = try Stack.pop processed_stack with Stack.Empty -> raise (Size 0)
+let top () = try Stack.top processed_stack with Stack.Empty -> raise (Size 0)
+let is_empty () = Stack.is_empty processed_stack
+
+  
+(* push a new Coq phrase *)
+
+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
+  | _ -> ()
+  in
+  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)); 
+	reset_info = Reset (_, r) } 
+       when id = id' -> raise Exit
+    | { reset_info = Reset (_, r) } -> r := false
+    | _ -> ()
+  in
+  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;
+	   stop = end_of_phrase_mark;
+	   ast = 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
+    | _ -> ()
+
+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
+    | _ -> ()
+
+(* For electric handlers *)
+exception Found
+
+(* For find_phrase_starting_at *)
+exception Stop of int
+
+let activate_input i = 
+  (match !active_view with
+     | None -> () 
+     | Some n ->
+	 let a_v = out_some (Vector.get input_views n).analyzed_view in
+	 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
+
+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)
+    msg
+
+
+class analyzed_view index =
+  let {view = input_view_} as current_all_ =  get_input_view index in
+  let proof_view_ = out_some !proof_view in
+  let message_view_ = out_some !message_view in
+object(self)
+  val current_all =  current_all_
+  val input_view = current_all_.view
+  val proof_view = out_some !proof_view
+  val message_view = out_some !message_view
+  val input_buffer = input_view_#buffer
+  val proof_buffer = proof_view_#buffer
+  val message_buffer = message_view_#buffer 
+  val mutable is_active = false
+  val mutable read_only = false
+  val mutable filename = None 
+  val mutable stats = None
+  val mutable last_modification_time = 0.
+  val mutable last_auto_save_time = 0.
+  val mutable detached_views = []
+
+  val mutable auto_complete_on = !current.auto_complete
+
+  method private toggle_auto_complete = 
+    auto_complete_on <- not auto_complete_on
+  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
+  method add_detached_view (w:GWindow.window) = 
+    detached_views <- w::detached_views
+  method remove_detached_view (w:GWindow.window) = 
+    detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views
+
+  method kill_detached_views () = 
+    List.iter (fun w -> w#destroy ()) detached_views;
+    detached_views <- []
+
+  method view = input_view
+  method filename = filename
+  method stats = stats
+  method set_filename f = 
+    filename <- f;
+    match f with 
+    | Some f -> stats <- my_stat f
+    | None -> ()
+
+  method update_stats = 
+    match filename with 
+    | 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";
+	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 -> ()
+	
+  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
+    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)
+	     
+  method private need_auto_save = 
+    input_buffer#modified &&
+    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	      
+      
+  method save_as f =
+    if Sys.file_exists f then 
+      match (GToolbox.question_box ~title:"File exists on disk"
+	       ~buttons:["Overwrite";
+			 "Cancel";] 
+	       ~default:1
+	       ~icon:
+	       (let img = GMisc.image () in
+		img#set_stock `DIALOG_WARNING;
+		img#set_icon_size `DIALOG;
+		img#coerce)
+	       ("File "^f^"already exists")
+	    )
+      with 1 -> self#save f
+      | _ -> false
+    else self#save f
+
+  method set_read_only b = read_only<-b
+  method read_only = read_only
+  method is_active = is_active
+  method insert_message s =
+    message_buffer#insert s;
+    message_view#misc#draw None
+
+  method set_message s =
+    message_buffer#set_text s;
+    message_view#misc#draw None
+
+  method clear_message = message_buffer#set_text ""
+  val mutable last_index = true
+  val last_array = [|"";""|]
+  method get_start_of_input =  input_buffer#get_iter_at_mark (`NAME "start_of_input") 
+
+  method get_insert = get_insert input_buffer
+
+  method recenter_insert = 
+    (* BUG : to investigate further: 
+       FIXED : Never call  GMain.* in thread !
+       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)
+	      `INSERT)
+
+
+  method indent_current_line = 
+    let get_nb_space it =
+      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
+    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
+
+
+  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)
+	
+
+  val mutable full_goal_done = true
+
+  method show_goals_full = 
+    if not full_goal_done then
+      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:
+				     (fun () -> ignore
+					(self#insert_this_phrase_on_success 
+					   true
+					   true 
+					   false 
+					   ("progress "^ip^"\n") 
+					   (ip^"\n"))
+				     )
+				  )
+			      in
+			      List.iter add_coq_command commands;
+			      loc_menu#popup 
+				~button:3
+				~time:(GdkEvent.Button.time ev);
+			    end
+			| `MOTION_NOTIFY -> 
+			    proof_buffer#remove_tag
+			    ~start:proof_buffer#start_iter
+			    ~stop:proof_buffer#end_iter
+			    last_shown_area;
+			    prerr_endline "Before find_tag_limits";
+			    
+			    let s,e = find_tag_limits tag 
+					(new GText.iter it) 
+			    in
+			    prerr_endline "After find_tag_limits";
+			    proof_buffer#apply_tag 
+			      ~start:s 
+			      ~stop:e 
+			      last_shown_area;
+			    
+			    prerr_endline "Applied tag";
+			    ()
+			| _ -> ()
+			end;false
+		     )
+		  );
+		tag
+	      in
+	      List.iter
+		(fun ((_,_,_,(s,_)) as hyp) -> 
+		   let tag = coq_menu (hyp_menu hyp) in
+		   proof_buffer#insert ~tags:[tag] (s^"\n"))
+		hyps;
+	      proof_buffer#insert 
+		(String.make 38 '_' ^"(1/"^
+		 (string_of_int goal_nb)^
+		 ")\n") 
+	      ;
+	      let tag = coq_menu (concl_menu concl) in
+	      let _,_,_,sconcl = concl in
+	      proof_buffer#insert ~tags:[tag] 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) ;
+	      full_goal_done <- true;
+	  with e -> prerr_endline (Printexc.to_string e)
+      end
+      
+  method send_to_coq verbosely replace phrase show_output show_error localize =
+    try 
+      full_goal_done <- false;
+      prerr_endline "Send_to_coq starting now";
+      if replace then begin
+	let r,info = 
+(*	  full_do_if_not_computing "coq eval and replace" *)
+	    Coq.interp_and_replace ("Info " ^ phrase) 
+	in
+	let msg = read_stdout () in 
+	self#insert_message (if show_output then msg else "");
+
+	Some r
+	
+      end else begin
+	let r = Some (Coq.interp verbosely phrase) in
+	let msg = read_stdout () in 
+	self#insert_message (if show_output then msg else "");
+	r
+      end
+    with e ->
+      (if show_error then
+	 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;
+	   ));
+      None
+
+  method find_phrase_starting_at (start:GText.iter) = 
+    prerr_endline "find_phrase_starting_at starting now";
+    let trash_bytes = ref "" in
+    let end_iter = start#copy in
+    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
+    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
+
+  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
+
+	  
+  method process_next_phrase verbosely display_goals do_highlight = 
+    begin
+      try 
+	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;
+	begin 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; false
+	| Some(start,stop) ->
+	    prerr_endline "process_next_phrase : to_process highlight";
+	    let b = input_buffer in
+	    if do_highlight then begin
+	      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";
+	    let phrase = start#get_slice ~stop in
+	    let r = 
+	      match self#send_to_coq verbosely false phrase true true true with
+	      | Some ast ->
+		  begin
+		    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;
+		    true
+		  end
+	      | None -> false
+	    in
+	    if do_highlight then begin
+	      b#remove_tag_by_name ~start ~stop "to_process" ;
+	      input_view#set_editable true;
+	      !pop_info ();
+	    end;
+	    r;
+	end
+      with e -> raise e
+    end
+    
+  method insert_this_phrase_on_success 
+    show_output show_msg localize coqphrase insertphrase = 
+    match self#send_to_coq false false coqphrase show_output show_msg localize with
+    | Some ast ->
+	begin
+	  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;
+	  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...
+	    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 _ -> ()*)
+	  true
+	end
+    | None -> 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
+    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");
+    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 =
+    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;
+    Coq.reset_initial ()
+
+
+  (* backtrack Coq to the phrase preceding iterator [i] *)
+  method backtrack_to_no_lock i =
+    prerr_endline "Backtracking_to iter starts now.";
+    (* re-synchronize Coq to the current state of the stack *)
+    let rec synchro () =
+      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
+    in
+    let add_undo t = match t with | Some n -> Some (succ n) | None -> None
+    in
+    (* 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
+    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 ());
+	  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.
+Please restart and report NOW.";
+      end
+    else prerr_endline "backtrack_to : discarded (...)"
+      
+  method backtrack_to i = 
+    if Mutex.try_lock coq_may_stop then 
+      (!push_info "Undoing...";self#backtrack_to_no_lock i ; Mutex.unlock coq_may_stop;
+       !pop_info ())
+    else prerr_endline "backtrack_to : discarded (lock is busy)"
+
+  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
+
+  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 ()); 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);
+	      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);
+	      update_input ()
+	  | { ast = (_, a) } when is_state_preserving a ->
+	      ignore (pop ());
+	      update_input ()
+	  | _ -> 
+	      self#backtrack_to_no_lock start
+	  end;
+	with
+	| Size 0 -> (* !flash_info "Nothing to Undo"*)()
+       );
+       !pop_info ();
+       Mutex.unlock coq_may_stop)
+    else prerr_endline "undo_last_step discarded"
+
+      
+  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')
+		       (fun () -> self#insert_command t'' t'')
+		   in
+		   let set_current_goal (s,t) = 
+		     c#set
+		       "Goal 1"
+		       s 
+		       (fun () -> try_interptac ("progress "^t))
+		       (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 = 
+    self#clear_message;
+    ignore (self#insert_this_phrase_on_success true false false cp ip)
+
+  method tactic_wizard l =
+    self#clear_message;
+    ignore 
+      (List.exists 
+	 (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
+  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
+	
+
+  val mutable deact_id = None
+  val mutable act_id = None
+
+  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;
+    );
+    deact_id <- Some 
+      (input_view#event#connect#key_press self#disconnected_keypress_handler);
+    prerr_endline "CONNECTED  inactive : ";
+    print_id (out_some deact_id)
+
+  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
+    );
+    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 ()
+
+      
+      
+  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;
+	 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 ()
+		   | _ -> ())
+	   )
+
+  method help_for_keyword () = 
+    
+    browse_keyword (self#insert_message) (get_current_word ())
+
+  initializer 
+    ignore (message_buffer#connect#insert_text
+	      ~callback:(fun it s -> ignore 
+			   (message_view#scroll_to_mark
+			      ~use_align:false
+			      ~within_margin:0.49
+			      `INSERT)));
+    ignore (input_buffer#connect#insert_text
+	      ~callback:(fun it s ->
+			   if (it#compare self#get_start_of_input)<0
+			   then GtkSignal.stop_emit ();
+			   if String.length s > 1 then 
+			     (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor it)));
+    ignore (input_buffer#connect#after#apply_tag
+	      ~callback:(fun tag ~start ~stop ->
+			   if (start#compare self#get_start_of_input)>=0
+			   then 
+			     input_buffer#remove_tag_by_name 
+			       ~start
+			       ~stop
+			       "processed"
+			)
+	   );
+    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
+			       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#changed
+	      ~callback:(fun () -> 
+			   last_modification_time <- Unix.time ();
+			   let r = input_view#visible_rect in
+			   let stop = 
+			     input_view#get_iter_at_location 
+			       ~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 
+			)
+	   );
+    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))
+end
+
+let create_input_tab filename =
+  let b = GText.buffer () in 
+  let tablabel = 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 fr1 = GBin.frame ~shadow_type:`ETCHED_OUT
+	      ~packing:((notebook ())#append_page
+			  ~tab_label:v_box#coerce) () 
+  in 
+  let sw1 = GBin.scrolled_window
+	      ~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
+
+
+let last_make = ref "";;
+let last_make_index = ref 0;;
+let search_compile_error_regexp =
+  Str.regexp
+    "File \"\\([^\"]+\\)\", line \\([0-9]+\\), characters \\([0-9]+\\)-\\([0-9]+\\)";;
+
+let search_next_error () =
+  let _ = Str.search_forward search_compile_error_regexp !last_make !last_make_index in
+  let f = Str.matched_group 1 !last_make
+  and l = int_of_string (Str.matched_group 2 !last_make)
+  and b = int_of_string (Str.matched_group 3 !last_make)
+  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))
+
+let main files = 
+  (* Statup preferences *)
+  load_pref ();
+
+  (* 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
+(*
+  let icon_image = Filename.concat lib_ide "coq.ico" in
+  let icon = GdkPixbuf.from_file icon_image in
+  w#set_icon (Some icon);
+*)
+  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));
+
+  (* File/Save Menu *)
+  let save_m = file_factory#add_item "_Save" 
+		 ~key:GdkKeysyms._S 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);
+
+  (* 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"
+	      (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"
+	      (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)
+      ()
+  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"
+	    (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" (fun () -> 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
+
+  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" (fun () -> 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 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" 
+    (* ~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 
+    "_Forward to" 
+    ~tooltip:"Forward to" 
+    ~key:GdkKeysyms._Right
+    ~callback:(do_or_activate (fun a -> a#process_until_insert_or_error))
+    `GOTO_LAST;
+  add_to_menu_toolbar 
+    "_Backward to" 
+    ~tooltip:"Backward to" 
+    ~key:GdkKeysyms._Left
+    ~callback:(do_or_activate (fun a-> a#backtrack_to_insert))
+    `GOTO_FIRST;
+*)
+  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"
+		 (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"
+		     (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);
+
+  (* 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:
+	      (do_if_not_computing "simple template"
+		 (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
+
+  (* 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
+
+  (* 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
+  
+
+  (* 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"
+			 (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) 
+			    () 
+		  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: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"
+		  (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 = Filename.concat lib_ide "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\
+       \nFeature wish or bug report: use Web interface\n\
+       \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 (Filename.concat lib_ide "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;
+
+;;
+
+let start () = 
+  let files = Coq.init () in
+  ignore_break ();
+  GtkMain.Rc.add_default_file (Filename.concat lib_ide ".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
+
diff --git a/ide/coqide.mli b/ide/coqide.mli
new file mode 100644
index 00000000..15e28fea
--- /dev/null
+++ b/ide/coqide.mli
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqide.mli,v 1.1.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+(* The CoqIde main module. The following function [start] will parse the
+   command line, initialize the load path, load the input 
+   state, load the files given on the command line, load the ressource file,
+   produce the output state if any, and finally will launch the interface. *)
+
+val start : unit -> unit
diff --git a/ide/extract_index.mll b/ide/extract_index.mll
new file mode 100644
index 00000000..4a8c37f1
--- /dev/null
+++ b/ide/extract_index.mll
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: extract_index.mll,v 1.2.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+{
+  open Lexing 
+}
+
+(* additional lexer to extract URL from Coq manual's index *)
+
+rule entry = parse
+  | "<LI><TT>" [^ ',']* "</TT>, "
+      { let s = lexeme lexbuf in
+	let n = String.length s in
+	String.sub s 8 (n - 15), extract_index_url lexbuf }
+  | "<LI>" [^ ',']* ", " 
+      { let s = lexeme lexbuf in
+	let n = String.length s in
+	String.sub s 4 (n - 6), extract_index_url lexbuf }
+
+and extract_index_url = parse
+  | "<A HREF=\"" [^ '"']* '"'
+      { let s = lexeme lexbuf in
+	let n = String.length s in
+	String.sub s 9 (n - 10) }
diff --git a/ide/find_phrase.mll b/ide/find_phrase.mll
new file mode 100644
index 00000000..8081474f
--- /dev/null
+++ b/ide/find_phrase.mll
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: find_phrase.mll,v 1.8.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+{
+  exception Lex_error of string
+  let length = ref 0
+  let buff = Buffer.create 513
+  exception EOF of string
+
+}
+
+let phrase_sep = '.'
+
+rule next_phrase = parse
+  | "(*" { incr length; incr length; 
+	   skip_comment lexbuf;
+	   next_phrase lexbuf}
+  | '"'[^'"']*'"' { let lexeme = Lexing.lexeme lexbuf in 
+		 let ulen = Glib.Utf8.length lexeme in
+		 length := !length + ulen;
+		 Buffer.add_string buff lexeme;
+		 next_phrase lexbuf
+	       }
+  | phrase_sep[' ''\n''\t''\r'] {
+      length := !length + 2; 
+      Buffer.add_string buff (Lexing.lexeme lexbuf);
+      Buffer.contents buff}
+
+  | phrase_sep eof{
+      length := !length + 2; 
+      Buffer.add_string buff (Lexing.lexeme lexbuf);
+      Buffer.add_char buff '\n';
+      raise (EOF(Buffer.contents buff))}
+  | _ 
+      { 
+	let c = Lexing.lexeme_char lexbuf 0 in 
+	if Ideutils.is_char_start c then incr length; 
+	Buffer.add_char buff c ;
+	next_phrase lexbuf
+      }
+  | eof  { raise (Lex_error "Phrase should end with . followed by a separator") }
+and skip_comment = parse
+  | "*)" {incr length; incr length; ()}
+  | "(*" {incr length; incr length; 
+	  skip_comment lexbuf;
+	  skip_comment lexbuf}
+  | _  { if Ideutils.is_char_start (Lexing.lexeme_char lexbuf 0) then 
+	   incr length; 
+	 skip_comment lexbuf}
+  | eof  { raise (Lex_error "No closing *)") }
+
+
+{
+  let get lb = 
+    Buffer.reset buff;
+    length := 0;
+    next_phrase lb
+
+}
diff --git a/ide/highlight.mll b/ide/highlight.mll
new file mode 100644
index 00000000..21063459
--- /dev/null
+++ b/ide/highlight.mll
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: highlight.mll,v 1.14.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+{
+
+  open Lexing
+
+  type color = string
+
+  type highlight_order = int * int * color
+
+  let comment_start = ref 0
+
+}
+
+let space = 
+  [' ' '\010' '\013' '\009' '\012']
+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*
+
+let keyword = 
+  "Add" | "CoInductive" | "Defined" | 
+  "End" | "Export" | "Extraction" | "Hint" |
+  "Implicits" | "Import" | 
+  "Infix" | "Load" | "match" | "Module" | "Module Type" |
+  "Proof" | "Qed" |
+  "Record" | "Require" | "Save" | "Scheme" |
+  "Section" | "Unset" |
+  "Set"  
+
+let declaration = 
+  "Lemma" | "Axiom" | "CoFixpoint" | "Definition"  |
+  "Fixpoint" | "Hypothesis" | 
+  "Inductive" | "Parameter" | "Theorem" | 
+  "Variable" | "Variables" 
+
+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" } 
+  | _    { next_order lexbuf}
+  | eof  { raise End_of_file }
+
+and comment = parse
+  | "*)" { !comment_start,lexeme_end lexbuf,"comment" }
+  | "(*" { ignore (comment lexbuf); comment lexbuf }
+  | _    { comment lexbuf }
+  | eof  { raise End_of_file }
+
+{
+  open Ideutils
+
+  let highlighting = ref false
+
+  let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop = 
+    if !highlighting then prerr_endline "Rejected highlight" 
+    else begin
+      highlighting := true;
+      prerr_endline "Highlighting slice now";
+      input_buffer#remove_tag_by_name ~start ~stop "error";
+      input_buffer#remove_tag_by_name ~start ~stop "kwd";
+      input_buffer#remove_tag_by_name ~start ~stop "decl";
+      input_buffer#remove_tag_by_name ~start ~stop "comment";
+
+      (try begin
+	let offset = start#offset in
+	let s = start#get_slice ~stop in
+	let convert_pos = byte_offset_to_char_offset s in
+	let lb = Lexing.from_string s in
+	try 
+	  while true do
+	    let b,e,o=next_order lb in
+	    let b,e = convert_pos b,convert_pos e in
+	    let start = input_buffer#get_iter_at_char (offset + b) in
+	    let stop = input_buffer#get_iter_at_char (offset + e) in
+	    input_buffer#apply_tag_by_name ~start ~stop o 
+	  done
+	with End_of_file -> ()
+      end
+      with _ -> ());
+      highlighting := false
+    end
+
+  let highlight_current_line input_buffer = 
+    try 
+      let i = get_insert input_buffer in
+      highlight_slice input_buffer (i#set_line_offset 0) i
+    with _ -> ()
+
+  let highlight_around_current_line input_buffer = 
+    try 
+      let i = get_insert input_buffer in
+      highlight_slice input_buffer 
+	(i#backward_lines 10) 
+	(ignore (i#nocopy#forward_lines 10);i)
+
+    with _ -> ()
+      
+  let highlight_all input_buffer = 
+  try 
+    highlight_slice input_buffer input_buffer#start_iter input_buffer#end_iter
+  with _ -> ()
+
+}
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
new file mode 100644
index 00000000..8ec0e9e4
--- /dev/null
+++ b/ide/ideutils.ml
@@ -0,0 +1,307 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ideutils.ml,v 1.30.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+
+open Preferences
+
+exception Forbidden
+
+(* status bar and locations *)
+
+let status = ref None
+let push_info = ref (function s -> failwith "not ready")
+let pop_info = ref (function s -> failwith "not ready")
+let flash_info = ref  (fun ?delay s -> failwith "not ready")
+
+let set_location = ref  (function s -> failwith "not ready")
+
+let pulse = ref (function () -> failwith "not ready")
+
+
+let debug = Options.debug
+
+let prerr_endline s =
+  if !debug then (prerr_endline s;flush stderr)
+let prerr_string s =
+  if !debug then (prerr_string s;flush stderr)
+
+let lib_ide = Filename.concat Coq_config.coqlib "ide"
+  
+let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
+
+let is_char_start c = let code = Char.code c in code < 0x80 || code >= 0xc0
+
+let byte_offset_to_char_offset s byte_offset = 
+  if (byte_offset < String.length s) then begin
+    let count_delta = ref 0 in
+    for i = 0 to byte_offset do
+      let code = Char.code s.[i] in
+      if code >= 0x80 && code < 0xc0 then incr count_delta
+    done;
+    byte_offset - !count_delta
+  end
+  else begin
+    let count_delta = ref 0 in
+    for i = 0 to String.length s - 1 do
+      let code = Char.code s.[i] in
+      if code >= 0x80 && code < 0xc0 then incr count_delta
+    done;
+    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)))
+
+
+let do_convert s = 
+  Utf8_convert.f
+    (if Glib.Utf8.validate s then begin
+       prerr_endline "Input is UTF-8";s
+     end else
+       let from_loc () = 
+	 let _,char_set = Glib.Convert.get_charset () in
+	 !flash_info
+	   ("Converting from locale ("^char_set^")");
+	 Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
+       in
+       let from_manual () = 
+	 !flash_info 
+	   ("Converting from "^ !current.encoding_manual);
+	 Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual
+       in
+       if !current.encoding_use_utf8 || !current.encoding_use_locale then begin
+	 try
+	   from_loc ()
+	 with _ -> from_manual ()
+       end else begin
+	 try
+	   from_manual () 
+	 with _ -> from_loc ()
+       end)
+
+let try_convert s = 
+  try
+    do_convert s
+  with _ -> 
+    "(* Fatal error: wrong encoding in input.
+Please choose a correct encoding in the preference panel.*)";;
+
+
+let try_export file_name s = 
+  try let s = 
+    try if !current.encoding_use_utf8 then begin
+      (prerr_endline "UTF-8 is enforced" ;s)
+    end else if !current.encoding_use_locale then begin
+      let is_unicode,char_set = Glib.Convert.get_charset () in
+      if is_unicode then 
+	(prerr_endline "Locale is UTF-8" ;s)	
+      else
+	(prerr_endline ("Locale is "^char_set);
+	 Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
+    end else 	
+      (prerr_endline ("Manual charset is "^ !current.encoding_manual);
+       Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s)
+    with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
+  in
+  let oc = open_out file_name in
+  output_string oc s;
+  close_out oc;
+  true
+  with e -> prerr_endline (Printexc.to_string e);false
+
+let my_stat f = try Some (Unix.stat f) with _ -> None
+
+let revert_timer = ref None
+let disconnect_revert_timer () = match !revert_timer with
+  | None -> ()
+  | Some id -> GMain.Timeout.remove id; revert_timer := None
+
+let auto_save_timer = ref None
+let disconnect_auto_save_timer () = match !auto_save_timer with
+  | None -> ()
+  | Some id -> GMain.Timeout.remove id; auto_save_timer := None
+
+let highlight_timer = ref None
+let set_highlight_timer f = 
+  match !highlight_timer with 
+    | None -> 
+	revert_timer := 
+      Some (GMain.Timeout.add ~ms:2000 
+	      ~callback:(fun () -> f (); highlight_timer := None; true))
+    | Some id -> 
+	GMain.Timeout.remove id;
+	revert_timer := 
+	Some (GMain.Timeout.add ~ms:2000 
+		~callback:(fun () -> f (); highlight_timer := None; true))
+
+
+(* Get back the standard coq out channels *)
+let read_stdout,clear_stdout =
+  let out_buff = Buffer.create 100 in
+  Pp_control.std_ft := Format.formatter_of_buffer out_buff;
+  (fun () -> Format.pp_print_flush !Pp_control.std_ft (); 
+     let r = Buffer.contents out_buff in
+     Buffer.clear out_buff; r),
+  (fun () -> 
+     Format.pp_print_flush !Pp_control.std_ft (); Buffer.clear out_buff)
+
+
+let last_dir = ref ""
+let select_file ~title ?(dir = last_dir) ?(filename="") () =
+  let fs =
+    if Filename.is_relative filename then begin
+      if !dir <> "" then
+        let filename = Filename.concat !dir filename in 
+        GWindow.file_selection ~show_fileops:true ~modal:true ~title ~filename ()
+      else
+        GWindow.file_selection ~show_fileops:true ~modal:true ~title ()
+    end else begin
+      dir := Filename.dirname filename;
+      GWindow.file_selection ~show_fileops:true ~modal:true ~title ~filename ()
+    end
+  in
+  fs#complete ~filter:"";
+  ignore (fs#connect#destroy ~callback: GMain.Main.quit);
+  let file = ref None in 
+  ignore (fs#ok_button#connect#clicked ~callback:
+    begin fun () ->
+      file := Some fs#filename; 
+      dir := Filename.dirname fs#filename;
+      fs#destroy ()
+    end);
+  ignore (fs # cancel_button # connect#clicked ~callback:fs#destroy);
+  fs # show ();
+  GMain.Main.main ();
+  !file
+
+
+let find_tag_start (tag :GText.tag) (it:GText.iter) =
+  let it = it#copy in
+  let tag = Some tag in
+  while not (it#begins_tag tag) && it#nocopy#backward_char do
+    ()
+  done;
+  it
+let find_tag_stop (tag :GText.tag) (it:GText.iter) =
+  let it = it#copy in
+  let tag = Some tag in
+  while not (it#ends_tag tag) && it#nocopy#forward_char do
+    ()
+  done;
+  it
+let find_tag_limits (tag :GText.tag) (it:GText.iter) = 
+ (find_tag_start tag it , find_tag_stop tag it)
+
+(* explanations ?? *)
+let async = 
+  if Sys.os_type <> "Unix" then GtkThread.async else 
+    (fun x -> x)
+
+let stock_to_widget ?(size=`DIALOG) s = 
+  let img = GMisc.image () 
+  in img#set_stock s;
+  img#coerce
+
+let rec print_list print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; print_list print fmt r
+
+
+let run_command 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 = try_convert (String.sub buff 0 !n) in 
+    f r;
+    Buffer.add_string result r;
+    let r = try_convert (String.sub buffe 0 !ne) in 
+    f r;
+    Buffer.add_string result r 
+  done;
+  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
+
+let browse f url =
+  let l,r = !current.cmd_browse in
+  let (s,res) = run_command f (l ^ url ^ r) in
+  ()
+
+let url_for_keyword =
+  let ht = Hashtbl.create 97 in
+  begin try
+    let cin = open_in (Filename.concat lib_ide "index_urls.txt") in
+    try while true do
+      let s = input_line cin in
+      try 
+	let i = String.index s ',' in
+	let k = String.sub s 0 i in
+	let u = String.sub s (i + 1) (String.length s - i - 1) in
+	Hashtbl.add ht k u
+      with _ ->
+	()
+    done with End_of_file ->
+      close_in cin
+  with _ ->
+    ()
+  end;
+  (Hashtbl.find ht : string -> string)
+
+
+let browse_keyword f text = 
+  try let u = url_for_keyword text in browse f (!current.doc_url ^ u) 
+  with _ -> ()
+
+
+let underscore = Glib.Utf8.to_unichar "_" (ref 0)
+
+let arobase = Glib.Utf8.to_unichar "@" (ref 0)
+let prime = Glib.Utf8.to_unichar "'" (ref 0)
+let bn = Glib.Utf8.to_unichar "\n" (ref 0)
+let space = Glib.Utf8.to_unichar " " (ref 0)
+let tab = Glib.Utf8.to_unichar "\t" (ref 0)
+
+
+(*
+  checks if two file names refer to the same (existing) file
+*)
+
+let same_file f1 f2 =
+  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) 
+  with
+      Unix.Unix_error _ -> false
+
+let absolute_filename f =
+  if Filename.is_relative f then 
+    Filename.concat (Sys.getcwd ()) f
+  else f
+	      
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
new file mode 100644
index 00000000..7c225e0e
--- /dev/null
+++ b/ide/ideutils.mli
@@ -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        *)
+(************************************************************************)
+
+(* $Id: ideutils.mli,v 1.6.2.1 2004/07/16 19:30:20 herbelin Exp $ *)
+
+val async : ('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
+val clear_stdout : unit -> unit
+val debug : bool ref
+val disconnect_revert_timer : unit -> unit
+val disconnect_auto_save_timer : unit -> unit
+val do_convert : string -> string
+val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter
+val find_tag_start : GText.tag -> GText.iter -> GText.iter
+val find_tag_stop : GText.tag -> GText.iter -> GText.iter
+val get_insert : < get_iter_at_mark : [> `INSERT] -> 'a; .. > -> 'a
+
+val is_char_start : char -> bool
+
+val lib_ide : string
+val my_stat : string -> Unix.stats option
+
+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
+val select_file :
+  title:string ->
+  ?dir:string ref -> ?filename:string -> unit -> string option
+val set_highlight_timer : (unit -> 'a) -> unit
+val try_convert : string -> string
+val try_export : string -> string -> bool
+val stock_to_widget :  ?size:Gtk.Tags.icon_size -> GtkStock.id -> GObj.widget
+
+open Format
+val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
+
+val run_command : (string -> unit) -> string -> Unix.process_status*string
+
+
+val prime : Glib.unichar
+val underscore : Glib.unichar
+val arobase : Glib.unichar
+val bn : Glib.unichar
+val space : Glib.unichar
+val tab : Glib.unichar
+
+
+val status : GMisc.statusbar option ref 
+val push_info : (string -> unit) ref
+val pop_info : (unit -> unit) ref
+val flash_info : (?delay:int -> string -> unit) ref
+
+val set_location : (string -> unit) ref
+
+val pulse : (unit -> unit) ref
+
+
+(*
+  checks if two file names refer to the same (existing) file
+*)
+
+val same_file : string -> string -> bool
+
+(*
+  returns an absolute filename equivalent to given filename
+*)
+val absolute_filename : string -> string
diff --git a/ide/index_urls.txt b/ide/index_urls.txt
new file mode 100644
index 00000000..fea61809
--- /dev/null
+++ b/ide/index_urls.txt
@@ -0,0 +1,563 @@
++,node.0.2.0.html#@default146
+-,node.0.2.1.html#@default247
+2,node.1.2.9.html#@default514
+;,node.1.2.12.html#@default547
+?,node.1.0.6.html#@default358
+?,node.1.2.1.html#@default410
+&,node.0.2.0.html#@default164
+{A}+{B},node.0.2.0.html#@default174
+{x:A & (P x)},node.0.2.0.html#@default163
+{x:A | (P x)},node.0.2.0.html#@default157
+|,node.0.2.0.html#@default158
+A*B,node.0.2.0.html#@default150
+A+{B},node.0.2.0.html#@default178
+A+B,node.0.2.0.html#@default145
+Abort,node.1.1.0.html#@default385
+Absolute names,node.0.1.6.html#@default85
+Abstract,node.1.2.12.html#@default559
+Absurd,node.1.2.3.html#@default442
+Acc,node.0.2.0.html#@default215
+Acc_inv,node.0.2.0.html#@default216
+Acc_rec,node.0.2.0.html#@default217
+Add Abstract Ring,node.3.7.4.html#@default643
+Add Abstract Semi Ring,node.3.7.4.html#@default644
+Add Field,node.1.2.10.html#@default526
+Add LoadPath,node.1.0.4.html#@default338
+Add ML Path,node.1.0.4.html#@default342
+Add Morphism,node.3.8.2.html#@default647
+Add Printing If,node.0.1.1.html#@default67
+Add Printing Let,node.0.1.1.html#@default63
+Add Rec LoadPath,node.1.0.4.html#@default339
+Add Rec ML Path,node.1.0.4.html#@default343
+Add Ring,node.1.2.10.html#@default523
+Add Semi Ring,node.1.2.10.html#@default524
+Add Setoid,node.3.8.1.html#@default646
+All,node.0.2.0.html#@default110
+AllT,node.0.2.0.html#@default224
+Apply,node.1.2.2.html#@default427
+Apply ... with,node.1.2.2.html#@default428
+Arithmetical notations,node.0.2.1.html#@default244
+Arity,node.0.3.4.html#@default288
+Assert,node.1.2.2.html#@default433
+Associativity,node.2.0.1.html#@default571
+Assumption,node.1.2.2.html#@default412
+Auto,node.1.2.10.html#@default515
+AutoRewrite,node.1.2.10.html#@default528
+Axiom,node.0.0.2.html#@default24
+abstractions,node.0.0.1.html#@default16
+absurd,node.0.2.0.html#@default121
+absurd_set,node.0.2.0.html#@default188
+all,node.0.2.0.html#@default109
+allT,node.0.2.0.html#@default223
+and,node.0.2.0.html#@default99
+and_rec,node.0.2.0.html#@default189
+applications,node.0.0.1.html#@default18
+Back,node.1.0.5.html#@default348
+Bad Magic Number,node.1.0.3.html#@default331
+Begin Silent,node.1.0.7.html#@default366
+Binding list,node.1.2.2.html#@default441
+beta-reduction,node.0.3.2.html#@default274
+bool,node.0.2.0.html#@default135
+bool_choice,node.0.2.0.html#@default181
+byte-code,node.3.0.0.html#@default574
+Calculus of (Co)Inductive Constructions,node.0.3.html#@default255
+Canonical Structure,node.0.1.7.html#@default91
+Case,node.1.2.6.html#@default468
+Case ... with,node.1.2.6.html#@default469
+Cases,node.3.2.html#@default593
+Cases...of...end,node.0.0.1.html#@default21
+Cbv,node.1.2.4.html#@default445
+Cd,node.1.0.4.html#@default337
+Change,node.1.2.2.html#@default438
+Change ... in,node.1.2.2.html#@default440
+Chapter,node.0.1.3.html#@default73
+Check,node.1.0.1.html#@default308
+Choice,node.0.2.0.html#@default179
+Choice2,node.0.2.0.html#@default180
+CIC,node.0.3.html#@default254
+Clear,node.1.2.2.html#@default414
+ClearBody,node.1.2.2.html#@default415
+Coercion,node.3.3.5.html#@default601
+Coercion Local,node.3.3.5.html#@default602
+Coercions,node.0.1.8.html#@default92
+and sections,node.3.3.9.html#@default616
+classes,node.3.3.1.html#@default596
+FUNCLASS,node.3.3.2.html#@default597
+identity,node.3.3.3.html#@default599
+inheritance graph,node.3.3.4.html#@default600
+presentation,node.3.3.html#@default595
+SORTCLASS,node.3.3.2.html#@default598
+CoFixpoint,node.0.0.2.html#@default40
+CoInductive,node.0.0.2.html#@default38
+Comments,node.0.0.0.html#@default2
+Compare,node.1.2.8.html#@default489
+Compiled files,node.1.0.3.html#@default327
+Compute,node.1.2.4.html#@default447
+Connectives,node.0.2.0.html#@default94
+Constant,node.0.0.2.html#@default31
+Constructor,node.1.2.5.html#@default455
+Constructor ...  with,node.1.2.5.html#@default456
+Context,node.0.3.1.html#@default263
+Contradiction,node.1.2.3.html#@default443
+Contributions,node.0.2.2.html#@default253
+Conversion rules,node.0.3.2.html#@default273
+Conversion tactics,node.1.2.4.html#@default444
+coqdep,node.3.1.1.html#@default582
+coq_Makefile,node.3.1.2.html#@default584
+coqmktop,node.3.1.0.html#@default579
+coq-tex,node.3.1.3.html#@default586
+coqweb,node.3.1.3.html#@default587
+Correctness,node.3.5.html#@default619
+Cut,node.1.2.2.html#@default434
+CutRewrite,node.1.2.7.html#@default482
+congr_eqT,node.0.2.0.html#@default241
+conj,node.0.2.0.html#@default100
+coqc,node.3.0.html#@default573
+coqtop,node.3.0.html#@default572
+Datatypes,node.0.2.0.html#@default132
+Debugger,node.3.1.0.html#@default580
+Decide Equality,node.1.2.8.html#@default488
+Declarations,node.0.0.2.html#@default23
+Declare ML Module,node.1.0.3.html#@default333
+Decompose,node.1.2.6.html#@default473
+Decompose Record,node.1.2.6.html#@default475
+Decompose Sum,node.1.2.6.html#@default474
+Defined,node.0.0.2.html#@default48
+Definition,node.0.0.2.html#@default33
+Definitions,node.0.0.2.html#@default29
+Dependencies,node.3.1.1.html#@default581
+Dependent Inversion,node.1.2.9.html#@default501
+Dependent Inversion ... with,node.1.2.9.html#@default503
+Dependent Inversion_clear,node.1.2.9.html#@default502
+Dependent Inversion_clear ... with,node.1.2.9.html#@default504
+Dependent Rewrite ->,node.1.2.8.html#@default495
+Dependent Rewrite <-,node.1.2.8.html#@default496
+Derive Dependent Inversion,node.1.2.9.html#@default511
+Derive Dependent Inversion_clear,node.1.2.9.html#@default512
+Derive Inversion,node.1.2.9.html#@default508
+Derive Inversion_clear,node.1.2.9.html#@default509
+Derive Inversion_clear ... with,node.1.2.9.html#@default510
+Destruct,node.1.2.6.html#@default466
+Discriminate,node.1.2.8.html#@default490
+DiscrR,node.0.2.1.html#@default250
+Do,node.1.2.12.html#@default542
+Double Induction,node.1.2.6.html#@default472
+Drop,node.1.0.7.html#@default365
+delta-reduction,node.0.0.2.html#@default30
+EApply,node.1.2.2.html#@default429
+EAuto,node.1.2.10.html#@default517
+Elim ... using,node.1.2.6.html#@default463
+Elim ... with,node.1.2.6.html#@default462
+Singleton elimination,node.0.3.4.html#@default294
+Elimination sorts,node.0.3.4.html#@default291
+ElimType,node.1.2.6.html#@default464
+Emacs,node.3.1.5.html#@default589
+EmptyT,node.0.2.0.html#@default233
+End,node.0.1.3.html#@default74
+End Silent,node.1.0.7.html#@default368
+Environment,node.0.0.2.html#@default32
+Environment variables,node.3.0.3.html#@default577
+Equality,node.0.2.0.html#@default118
+Eval,node.1.0.1.html#@default309
+EX,node.0.2.0.html#@default113
+EXT,node.0.2.0.html#@default229
+Ex,node.0.2.0.html#@default112
+Ex2,node.0.2.0.html#@default116
+Exact,node.1.2.1.html#@default408
+Exc,node.0.2.0.html#@default182
+Except,node.0.2.0.html#@default187
+Exists,node.1.2.5.html#@default458
+Explicitation of implicit arguments,node.0.1.7.html#@default88
+ExT,node.0.2.0.html#@default228
+ExT2,node.0.2.0.html#@default231
+Extensive grammars,node.1.0.6.html#@default362
+Extract Constant,node.3.6.1.html#@default637
+Extract Inductive,node.3.6.1.html#@default638
+Extraction,node.3.6.html#@default623
+Extraction,node.1.0.1.html#@default310
+Extraction Inline,node.3.6.1.html#@default633
+Extraction Language,node.3.6.1.html#@default628
+Extraction Module,node.3.6.0.html#@default626
+Extraction NoInline,node.3.6.1.html#@default634
+eq,node.0.2.0.html#@default119
+eq_add_S,node.0.2.0.html#@default193
+eq_ind_r,node.0.2.0.html#@default126
+eq_rec,node.0.2.0.html#@default186
+eq_rec_r,node.0.2.0.html#@default127
+eq_rect,node.0.2.0.html#@default128
+eq_rect_r,node.0.2.0.html#@default129
+eq_S,node.0.2.0.html#@default190
+eqT,node.0.2.0.html#@default236
+eqT_ind_r,node.0.2.0.html#@default242
+eqT_rec_r,node.0.2.0.html#@default243
+error,node.0.2.0.html#@default184
+ex,node.0.2.0.html#@default111
+ex2,node.0.2.0.html#@default115
+ex_intro,node.0.2.0.html#@default114
+ex_intro2,node.0.2.0.html#@default117
+exist,node.0.2.0.html#@default160
+exist2,node.0.2.0.html#@default162
+existS,node.0.2.0.html#@default166
+existS2,node.0.2.0.html#@default170
+exT,node.0.2.0.html#@default227
+exT2,node.0.2.0.html#@default232
+exT_intro,node.0.2.0.html#@default230
+Fact,node.0.0.2.html#@default44
+Fail,node.1.2.12.html#@default540
+False,node.0.2.0.html#@default97
+False_rec,node.0.2.0.html#@default185
+Field,node.1.2.10.html#@default525
+First,node.1.2.12.html#@default553
+Fix,node.0.3.4.html#@default298
+Fix_F,node.0.2.0.html#@default219
+Fix_F_eq,node.0.2.0.html#@default222
+Fix_F_inv,node.0.2.0.html#@default221
+Fixpoint,node.0.0.2.html#@default39
+Focus,node.1.1.1.html#@default392
+Fold,node.1.2.4.html#@default453
+Fourier,node.1.2.10.html#@default527
+Fst,node.0.2.0.html#@default155
+f_equal,node.0.2.0.html#@default124
+f_equal<I>i</I>,node.0.2.0.html#@default130
+false,node.0.2.0.html#@default137
+fix_eq,node.0.2.0.html#@default220
+fst,node.0.2.0.html#@default153
+Gallina,node.0.0.html#@default0
+gallina,node.3.1.6.html#@default591
+Generalize,node.1.2.2.html#@default436
+Generalize Dependent,node.1.2.2.html#@default437
+Global Variable,node.3.5.2.html#@default620
+Goal,node.0.0.2.html#@default50
+Grammar,node.1.0.6.html#@default361
+ge,node.0.2.0.html#@default208
+gen,node.0.2.0.html#@default226
+goal,node.1.2.html#@default405
+gt,node.0.2.0.html#@default209
+Head normal form,node.0.3.2.html#@default286
+Hint,node.1.2.11.html#@default531
+Hint Rewrite,node.1.2.10.html#@default529
+Hints databases,node.1.2.11.html#@default530
+Hints Immediate,node.1.2.11.html#@default533
+Hints Resolve,node.1.2.11.html#@default532
+Hints Unfold,node.1.2.11.html#@default534
+Hnf,node.1.2.4.html#@default449
+HTML,node.3.1.4.html#@default588
+Hypothesis,node.0.0.2.html#@default28
+I,node.0.2.0.html#@default96
+Identity Coercion,node.3.3.5.html#@default605
+Idtac,node.1.2.12.html#@default538
+IF,node.0.2.0.html#@default107
+proof of,node.3.5.html#@default618
+Implicit Arguments Off,node.1.0.6.html#@default355
+Implicit Arguments On,node.1.0.6.html#@default354
+Implicits,node.1.0.6.html#@default356
+Induction,node.1.2.6.html#@default465
+Inductive,node.0.0.2.html#@default36
+Inductive definitions,node.0.0.2.html#@default35
+Infix,node.1.0.6.html#@default363
+Info,node.1.2.12.html#@default557
+Injection,node.1.2.8.html#@default492
+Inspect,node.1.0.0.html#@default305
+Intro,node.1.2.2.html#@default418
+Intro ... after,node.1.2.2.html#@default426
+Intro after,node.1.2.2.html#@default425
+Intros,node.1.2.2.html#@default422
+Intros pattern,node.1.2.6.html#@default471
+Intros until,node.1.2.2.html#@default423
+Intuition,node.1.2.10.html#@default520
+Inversion,node.1.2.9.html#@default497
+Inversion ... in,node.1.2.9.html#@default499
+Inversion ... using,node.1.2.9.html#@default505
+Inversion ... using ... in,node.1.2.9.html#@default506
+Inversion_clear,node.1.2.9.html#@default498
+Inversion_clear ... in,node.1.2.9.html#@default500
+IsSucc,node.0.2.0.html#@default195
+if ... then ... else,node.0.1.1.html#@default55
+iff,node.0.2.0.html#@default106
+implicit arguments,node.0.1.7.html#@default86
+inl,node.0.2.0.html#@default147
+inleft,node.0.2.0.html#@default176
+inr,node.0.2.0.html#@default148
+inright,node.0.2.0.html#@default177
+iota-reduction,node.0.3.2.html#@default275
+LApply,node.1.2.2.html#@default430
+Lazy,node.1.2.4.html#@default446
+Left,node.1.2.5.html#@default459
+Lemma,node.0.0.2.html#@default42
+LetTac,node.1.2.2.html#@default431
+Lexical conventions,node.0.0.0.html#@default1
+Libraries,node.0.1.5.html#@default82
+Load,node.1.0.2.html#@default325
+Load Verbose,node.1.0.2.html#@default326
+Loadpath,node.1.0.4.html#@default335
+Local,node.0.0.2.html#@default34
+Local definitions,node.0.0.1.html#@default19
+Locate,node.1.0.1.html#@default323
+Locate Library,node.1.0.4.html#@default346
+Logical paths,node.0.1.5.html#@default83
+le,node.0.2.0.html#@default204
+le_n,node.0.2.0.html#@default205
+le_S,node.0.2.0.html#@default206
+left,node.0.2.0.html#@default172
+let ... in,node.0.1.1.html#@default56
+let-in,node.0.0.1.html#@default20
+local context,node.1.1.html#@default372
+lt,node.0.2.0.html#@default207
+Makefile,node.3.1.2.html#@default583
+Man pages,node.3.1.7.html#@default592
+ML-like patterns,node.0.1.1.html#@default54
+Module,node.0.1.4.html#@default75
+Module Type,node.0.1.4.html#@default78
+Move,node.1.2.2.html#@default416
+Mutual Inductive,node.0.0.2.html#@default37
+mult,node.0.2.0.html#@default201
+mult_n_O,node.0.2.0.html#@default202
+mult_n_Sm,node.0.2.0.html#@default203
+NewDestruct,node.1.2.6.html#@default467
+NewInduction,node.1.2.6.html#@default461
+None,node.0.2.0.html#@default143
+Normal form,node.0.3.2.html#@default285
+Notation,node.2.0.0.html#@default569
+Notations for real numbers,node.0.2.1.html#@default249
+n_Sn,node.0.2.0.html#@default197
+nat,node.0.2.0.html#@default138
+nat_case,node.0.2.0.html#@default210
+nat_double_ind,node.0.2.0.html#@default211
+native code,node.3.0.0.html#@default575
+not,node.0.2.0.html#@default98
+not_eq_S,node.0.2.0.html#@default194
+notT,node.0.2.0.html#@default235
+O,node.0.2.0.html#@default139
+O_S,node.0.2.0.html#@default196
+Omega,node.1.2.10.html#@default521
+Opaque,node.1.0.1.html#@default311
+Options of the command line,node.3.0.4.html#@default578
+Orelse,node.1.2.12.html#@default544
+option,node.0.2.0.html#@default141
+or,node.0.2.0.html#@default103
+or_introl,node.0.2.0.html#@default104
+or_intror,node.0.2.0.html#@default105
+Parameter,node.0.0.2.html#@default25
+Pattern,node.1.2.4.html#@default454
+Peano's arithmetic notations,node.0.2.1.html#@default248
+Pose,node.1.2.2.html#@default432
+Positivity,node.0.3.4.html#@default287
+Precedences,node.2.0.1.html#@default570
+Pretty printing,node.1.0.6.html#@default360
+Print,node.1.0.0.html#@default302
+Print All,node.1.0.0.html#@default304
+Print Classes,node.3.3.6.html#@default606
+Print Coercion Paths,node.3.3.6.html#@default609
+Print Coercions,node.3.3.6.html#@default607
+Print Extraction Inline,node.3.6.1.html#@default635
+Print Graph,node.3.3.6.html#@default608
+Print Hint,node.1.2.11.html#@default535
+Print HintDb,node.1.2.11.html#@default536
+Print LoadPath,node.1.0.4.html#@default341
+Print ML Modules,node.1.0.3.html#@default334
+Print ML Path,node.1.0.4.html#@default344
+Print Module,node.0.1.4.html#@default80
+Print Module Type,node.0.1.4.html#@default81
+Print Modules,node.1.0.3.html#@default332
+Print Proof,node.1.0.0.html#@default303
+Print Section,node.1.0.0.html#@default306
+Print Table Printing If,node.0.1.1.html#@default70
+Print Table Printing Let,node.0.1.1.html#@default66
+Programming,node.0.2.0.html#@default131
+Prolog,node.1.2.10.html#@default518
+Prompt,node.1.1.html#@default371
+Proof,node.0.0.2.html#@default45
+Proof editing,node.1.1.html#@default370
+Proof General,node.3.1.5.html#@default590
+Proof term,node.1.1.html#@default373
+Prop,node.0.0.1.html#@default11
+Pwd,node.1.0.4.html#@default336
+pair,node.0.2.0.html#@default152
+plus,node.0.2.0.html#@default198
+plus_n_O,node.0.2.0.html#@default199
+plus_n_Sm,node.0.2.0.html#@default200
+pred,node.0.2.0.html#@default191
+pred_Sn,node.0.2.0.html#@default192
+prod,node.0.2.0.html#@default149
+products,node.0.0.1.html#@default17
+proj1,node.0.2.0.html#@default101
+proj2,node.0.2.0.html#@default102
+projS1,node.0.2.0.html#@default167
+projS2,node.0.2.0.html#@default168
+Qed,node.0.0.2.html#@default47
+Qualified identifiers,node.0.1.6.html#@default84
+Quantifiers,node.0.2.0.html#@default108
+Quit,node.1.0.7.html#@default364
+Quote,node.1.2.9.html#@default513
+?,node.0.1.7.html#@default90
+Read Module,node.1.0.3.html#@default328
+Record,node.0.1.0.html#@default52
+Recursion,node.0.2.0.html#@default213
+Recursive arguments,node.0.3.4.html#@default300
+Recursive Extraction,node.3.6.0.html#@default625
+Recursive Extraction Module,node.3.6.0.html#@default627
+Red,node.1.2.4.html#@default448
+Refine,node.1.2.1.html#@default409
+Reflexivity,node.1.2.7.html#@default484
+Remark,node.0.0.2.html#@default43
+Remove LoadPath,node.1.0.4.html#@default340
+Remove Printing If,node.0.1.1.html#@default68
+Remove Printing Let,node.0.1.1.html#@default64
+Rename,node.1.2.2.html#@default417
+Replace ... with,node.1.2.7.html#@default483
+Require,node.1.0.3.html#@default329
+Require Export,node.1.0.3.html#@default330
+Reset,node.1.0.5.html#@default347
+Reset Extraction Inline,node.3.6.1.html#@default636
+Reset Initial,node.1.0.5.html#@default350
+Resource file,node.3.0.2.html#@default576
+Restart,node.1.1.1.html#@default391
+Restore State,node.1.0.5.html#@default349
+Resume,node.1.1.0.html#@default387
+Rewrite,node.1.2.7.html#@default476
+Rewrite ->,node.1.2.7.html#@default477
+Rewrite -> ... in,node.1.2.7.html#@default480
+Rewrite <-,node.1.2.7.html#@default478
+Rewrite <- ... in,node.1.2.7.html#@default481
+Rewrite ... in,node.1.2.7.html#@default479
+Right,node.1.2.5.html#@default460
+Ring,node.1.2.10.html#@default522
+refl_eqT,node.0.2.0.html#@default237
+refl_equal,node.0.2.0.html#@default120
+right,node.0.2.0.html#@default173
+S,node.0.2.0.html#@default140
+Save,node.0.0.2.html#@default49
+Scheme,node.1.2.13.html#@default561
+Script file,node.1.0.2.html#@default324
+Search,node.1.0.1.html#@default313
+Search ... inside ...,node.1.0.1.html#@default317
+Search ... outside ...,node.1.0.1.html#@default320
+SearchAbout,node.1.0.1.html#@default314
+SearchPattern,node.1.0.1.html#@default315
+SearchPattern ... outside ...,node.1.0.1.html#@default321
+SearchRewrite,node.1.0.1.html#@default316
+SearchRewrite ... inside ...,node.1.0.1.html#@default319
+SearchRewrite ... outside ...,node.1.0.1.html#@default322
+Section,node.0.1.3.html#@default72
+Sections,node.0.1.3.html#@default71
+Set,node.0.0.1.html#@default10
+Set Extraction AutoInline,node.3.6.1.html#@default631
+Set Extraction Optimize,#@default629
+Set Hyps_limit,node.1.1.2.html#@default402
+Set Implicit Arguments,node.0.1.7.html#@default87
+Set Printing Coercion,node.3.3.7.html#@default612
+Set Printing Coercions,node.3.3.7.html#@default610
+Set Printing Synth,node.0.1.1.html#@default60
+Set Printing Wildcard,node.0.1.1.html#@default57
+Set Undo,node.1.1.1.html#@default389
+Setoid_replace,node.3.8.html#@default645
+Setoid_rewrite,node.3.8.3.html#@default649
+Show,node.1.1.2.html#@default394
+Show Conjectures,node.1.1.2.html#@default399
+Show Implicits,node.1.1.2.html#@default395
+Show Intro,node.1.1.2.html#@default400
+Show Intros,node.1.1.2.html#@default401
+Show Programs,node.3.5.2.html#@default621
+Show Proof,node.1.1.2.html#@default398
+Show Script,node.1.1.2.html#@default396
+Show Tree,node.1.1.2.html#@default397
+Silent mode,node.1.0.7.html#@default367
+Simpl,node.1.2.4.html#@default450
+Simple Inversion,node.1.2.9.html#@default507
+Simplify_eq,node.1.2.8.html#@default494
+Small inductive type,node.0.3.4.html#@default292
+Snd,node.0.2.0.html#@default156
+Solve,node.1.2.12.html#@default555
+Some,node.0.2.0.html#@default142
+Sorts,node.0.0.1.html#@default8
+Split,node.1.2.5.html#@default457
+SplitAbsolu,node.0.2.1.html#@default251
+SplitRmult,node.0.2.1.html#@default252
+Strong elimination,node.0.3.4.html#@default293
+Structure,node.3.3.8.html#@default615
+Subst,node.1.2.7.html#@default487
+Substitution,node.0.3.0.html#@default262
+Suspend,node.1.1.0.html#@default386
+Symmetry,node.1.2.7.html#@default485
+Syntactic Definition,node.0.1.7.html#@default89
+Syntax,node.1.0.6.html#@default359
+sig,node.0.2.0.html#@default159
+sig2,node.0.2.0.html#@default161
+sigS,node.0.2.0.html#@default165
+sigS2,node.0.2.0.html#@default169
+snd,node.0.2.0.html#@default154
+sort,node.0.0.1.html#@default7
+specif,node.0.0.1.html#@default14
+subgoal,node.1.2.html#@default406
+sum,node.0.2.0.html#@default144
+sum_eqT,node.0.2.0.html#@default238
+sumbool,node.0.2.0.html#@default171
+sumor,node.0.2.0.html#@default175
+sym_eq,node.0.2.0.html#@default122
+sym_not_eq,node.0.2.0.html#@default125
+sym_not_eqT,node.0.2.0.html#@default239
+Tactic Definition,node.1.2.14.html#@default563
+Tacticals,node.1.2.12.html#@default537
+Do,node.1.2.12.html#@default543
+Fail,node.1.2.12.html#@default541
+First,node.1.2.12.html#@default554
+Solve,node.1.2.12.html#@default556
+Idtac,node.1.2.12.html#@default539
+Info,node.1.2.12.html#@default558
+Orelse,node.1.2.12.html#@default545
+Repeat,node.1.2.12.html#@default546
+Try,node.1.2.12.html#@default552
+Tactics,node.1.2.html#@default404
+Tauto,node.1.2.10.html#@default519
+Terms,node.0.0.1.html#@default5
+Test Printing If,node.0.1.1.html#@default69
+Test Printing Let,node.0.1.1.html#@default65
+Test Printing Synth,node.0.1.1.html#@default62
+Test Printing Wildcard,node.0.1.1.html#@default59
+Theorem,node.0.0.2.html#@default41
+Theories,node.0.2.html#@default93
+Time,node.1.0.7.html#@default369
+Transitivity,node.1.2.7.html#@default486
+Transparent,node.1.0.1.html#@default312
+Trivial,node.1.2.10.html#@default516
+True,node.0.2.0.html#@default95
+Try,node.1.2.12.html#@default551
+Type,node.0.0.1.html#@default9
+Type of constructor,node.0.3.4.html#@default289
+Typing rules,node.0.3.1.html#@default265
+Ax,node.0.3.1.html#@default266
+Cases,node.0.3.4.html#@default296
+Const,node.0.3.1.html#@default268
+Conv,node.0.3.2.html#@default282
+Fix,node.0.3.4.html#@default299
+Lam,node.0.3.1.html#@default270
+Let,node.0.3.1.html#@default272
+Prod,node.0.3.1.html#@default269
+Var,node.0.3.1.html#@default267
+tactic macros,node.1.2.14.html#@default562
+trans_eq,node.0.2.0.html#@default123
+trans_eqT,node.0.2.0.html#@default240
+true,node.0.2.0.html#@default136
+tt,node.0.2.0.html#@default134
+Undo,node.1.1.1.html#@default388
+Unfocus,node.1.1.1.html#@default393
+Unfold,node.1.2.4.html#@default451
+Unfold ... in,node.1.2.4.html#@default452
+UnitT,node.0.2.0.html#@default234
+Unset Extraction AutoInline,node.3.6.1.html#@default632
+Unset Extraction Optimize,#@default630
+Unset Hyps_limit,node.1.1.2.html#@default403
+Unset Implicit Arguments,node.1.0.6.html#@default353
+Unset Printing Coercion,node.3.3.7.html#@default613
+Unset Printing Coercions,node.3.3.7.html#@default611
+Unset Printing Synth,node.0.1.1.html#@default61
+Unset Printing Wildcard,node.0.1.1.html#@default58
+Unset Undo,node.1.1.1.html#@default390
+unit,node.0.2.0.html#@default133
+Variable,node.0.0.2.html#@default26
+Variables,node.0.0.2.html#@default27
+value,node.0.2.0.html#@default183
+Well founded induction,node.0.2.0.html#@default214
+Well foundedness,node.0.2.0.html#@default212
+Write State,node.1.0.5.html#@default351
+well_founded,node.0.2.0.html#@default218
diff --git a/ide/preferences.ml b/ide/preferences.ml
new file mode 100644
index 00000000..8743b99b
--- /dev/null
+++ b/ide/preferences.ml
@@ -0,0 +1,540 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: preferences.ml,v 1.27.2.2 2004/07/16 19:30:20 herbelin Exp $ *)
+
+open Configwin
+open Printf
+open Util
+
+let pref_file = Filename.concat System.home ".coqiderc"
+
+let accel_file = Filename.concat System.home ".coqide.keys"
+
+let mod_to_str (m:Gdk.Tags.modifier) = 
+  match m with
+    | `MOD1 -> "MOD1"
+    | `MOD2 -> "MOD2"
+    | `MOD3 -> "MOD3"
+    | `MOD4 -> "MOD4"
+    | `MOD5 -> "MOD5"
+    | `BUTTON1 -> "BUTTON1"
+    | `BUTTON2 -> "BUTTON2"
+    | `BUTTON3 -> "BUTTON3"
+    | `BUTTON4 -> "BUTTON4"
+    | `BUTTON5 -> "BUTTON5"
+    | `CONTROL -> "CONTROL"
+    | `LOCK -> "LOCK"
+    | `SHIFT -> "SHIFT"
+
+let (str_to_mod:string -> Gdk.Tags.modifier) =
+  function
+    | "MOD1" -> `MOD1 
+    | "MOD2" -> `MOD2 
+    | "MOD3" -> `MOD3 
+    | "MOD4" -> `MOD4 
+    | "MOD5" -> `MOD5 
+    | "BUTTON1" -> `BUTTON1 
+    | "BUTTON2" -> `BUTTON2 
+    | "BUTTON3" -> `BUTTON3 
+    | "BUTTON4" -> `BUTTON4 
+    | "BUTTON5" -> `BUTTON5 
+    | "CONTROL" -> `CONTROL 
+    | "LOCK" -> `LOCK 
+    | "SHIFT" -> `SHIFT 
+    | s -> `MOD1
+
+type pref =
+    {
+      mutable cmd_coqc : string;
+      mutable cmd_make : string;
+      mutable cmd_coqmakefile : string;
+      mutable cmd_coqdoc : string;
+
+      mutable global_auto_revert : bool;
+      mutable global_auto_revert_delay : int;
+
+      mutable auto_save : bool;
+      mutable auto_save_delay : int;
+      mutable auto_save_name : string * string;
+
+      mutable encoding_use_locale : bool;
+      mutable encoding_use_utf8 : bool;
+      mutable encoding_manual : string;
+
+      mutable automatic_tactics : string list;
+      mutable cmd_print : string;
+
+      mutable modifier_for_navigation : Gdk.Tags.modifier list;
+      mutable modifier_for_templates : Gdk.Tags.modifier list;
+      mutable modifier_for_tactics : Gdk.Tags.modifier list;
+      mutable modifiers_valid : Gdk.Tags.modifier list;
+
+      mutable cmd_browse : string * string;
+      mutable cmd_editor : string * string;
+
+      mutable text_font : Pango.font_description;
+
+      mutable doc_url : string;
+      mutable library_url : string;
+
+      mutable show_toolbar : bool;
+      mutable contextual_menus_on_goal : bool;
+      mutable window_width : int;
+      mutable window_height :int;
+      mutable query_window_width : int;
+      mutable query_window_height : int;
+(*
+      mutable use_utf8_notation : bool;
+*)
+      mutable auto_complete : bool;
+    }
+
+let (current:pref ref) = 
+  ref {
+    cmd_coqc = "coqc";
+    cmd_make = "make";
+    cmd_coqmakefile = "coq_makefile -o makefile *.v";
+    cmd_coqdoc = "coqdoc -q -g";
+    cmd_print = "lpr";
+
+    global_auto_revert = false;
+    global_auto_revert_delay = 10000;
+    
+    auto_save = false;
+    auto_save_delay = 10000;
+    auto_save_name = "#","#";
+    
+    encoding_use_locale = true;
+    encoding_use_utf8 = false;
+    encoding_manual = "ISO_8859-1";
+
+    automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
+			 "auto with *"; "intuition" ];
+    
+    modifier_for_navigation = [`CONTROL; `MOD1];
+    modifier_for_templates = [`MOD4];
+    modifier_for_tactics = [`CONTROL; `MOD1];
+    modifiers_valid = [`SHIFT; `CONTROL; `MOD1; `MOD4];
+
+    
+    cmd_browse = 
+	 if Sys.os_type = "Win32"
+	 then "C:\\PROGRA~1\\INTERN~1\\IEXPLORE ", ""
+	 else "netscape -remote \"OpenURL(", ")\"";
+    cmd_editor = 
+	 if Sys.os_type = "Win32"
+	 then "NOTEPAD ", ""
+	 else "emacs ", "";
+    
+    text_font = Pango.Font.from_string "sans 12";
+
+    doc_url = "http://coq.inria.fr/doc/";
+    library_url = "http://coq.inria.fr/library/";
+    
+    show_toolbar = true;
+    contextual_menus_on_goal = true;
+    window_width = 800;
+    window_height = 600; 
+    query_window_width = 600;
+    query_window_height = 400;
+(*
+    use_utf8_notation = false;
+*)
+    auto_complete = false
+  }
+
+
+let change_font = ref (fun f -> ())
+
+let show_toolbar = ref (fun x -> ())
+
+let auto_complete = ref (fun x -> ())
+
+let contextual_menus_on_goal = ref (fun x -> ())
+
+let resize_window = ref (fun () -> ())
+
+let save_pref () =
+  (try GtkData.AccelMap.save accel_file 
+  with _ -> ());
+  let p = !current in
+  try 
+    let add = Stringmap.add in
+    let (++) x f = f x in
+    Stringmap.empty ++
+    add "cmd_coqc" [p.cmd_coqc] ++
+    add "cmd_make" [p.cmd_make] ++
+    add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
+    add "cmd_coqdoc" [p.cmd_coqdoc] ++
+    add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
+    add "global_auto_revert_delay" 
+      [string_of_int p.global_auto_revert_delay] ++
+    add "auto_save" [string_of_bool p.auto_save] ++
+    add "auto_save_delay" [string_of_int p.auto_save_delay] ++
+    add "auto_save_name" [fst p.auto_save_name; snd p.auto_save_name] ++
+
+    add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++
+    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 "cmd_print" [p.cmd_print] ++
+    add "modifier_for_navigation" 
+      (List.map mod_to_str p.modifier_for_navigation) ++
+    add "modifier_for_templates" 
+      (List.map mod_to_str p.modifier_for_templates) ++
+    add "modifier_for_tactics" 
+      (List.map mod_to_str p.modifier_for_tactics) ++
+    add "modifiers_valid" 
+      (List.map mod_to_str p.modifiers_valid) ++
+    add "cmd_browse" [fst p.cmd_browse; snd p.cmd_browse] ++
+    add "cmd_editor" [fst p.cmd_editor; snd p.cmd_editor] ++
+
+    add "text_font" [Pango.Font.to_string p.text_font] ++
+
+    add "doc_url" [p.doc_url] ++
+    add "library_url" [p.library_url] ++
+    add "show_toolbar" [string_of_bool p.show_toolbar] ++
+    add "contextual_menus_on_goal" 
+      [string_of_bool p.contextual_menus_on_goal] ++
+    add "window_height" [string_of_int p.window_height] ++
+    add "window_width" [string_of_int p.window_width] ++
+    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] ++
+    Config_lexer.print_file pref_file
+  with _ -> prerr_endline "Could not save preferences."
+  
+
+let load_pref () =
+  (try GtkData.AccelMap.load accel_file with _ -> ());
+  let p = !current in 
+  try 
+    let m = Config_lexer.load_file pref_file in
+    let np = { p with cmd_coqc = p.cmd_coqc } in
+    let set k f = try let v = Stringmap.find k m in f v with _ -> () in
+    let set_hd k f = set k (fun v -> f (List.hd v)) in
+    let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in
+    let set_int k f = set_hd k (fun v -> f (int_of_string v)) in
+    let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in
+    set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
+    set_hd "cmd_make" (fun v -> np.cmd_make <- v);
+    set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
+    set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
+    set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
+    set_int "global_auto_revert_delay" 
+      (fun v -> np.global_auto_revert_delay <- v);
+    set_bool "auto_save" (fun v -> np.auto_save <- v);
+    set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
+    set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
+    set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v);
+    set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v);
+    set_hd "encoding_manual" (fun v -> np.encoding_manual <- v);
+    set "automatic_tactics"
+      (fun v -> np.automatic_tactics <- v);
+    set_hd "cmd_print" (fun v -> np.cmd_print <- v);
+    set "modifier_for_navigation" 
+      (fun v -> np.modifier_for_navigation <- List.map str_to_mod v);
+    set "modifier_for_templates" 
+      (fun v -> np.modifier_for_templates <- List.map str_to_mod v);
+    set "modifier_for_tactics" 
+      (fun v -> np.modifier_for_tactics <- List.map str_to_mod v);
+    set "modifiers_valid" 
+      (fun v -> np.modifiers_valid <- List.map str_to_mod v);
+    set_pair "cmd_browse" (fun v1 v2 -> np.cmd_browse <- (v1,v2));
+    set_pair "cmd_editor" (fun v1 v2 -> np.cmd_editor <- (v1,v2));
+    set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v);
+    set_hd "doc_url" (fun v -> np.doc_url <- v);
+    set_hd "library_url" (fun v -> np.library_url <- v);
+    set_bool "show_toolbar" (fun v -> np.show_toolbar <- v);
+    set_bool "contextual_menus_on_goal" 
+      (fun v -> np.contextual_menus_on_goal <- v);
+    set_int "window_width" (fun v -> np.window_width <- v);
+    set_int "window_height" (fun v -> np.window_height <- v);
+    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);
+    current := np;
+(*
+    Format.printf "in laod_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+*)
+  with e -> 
+    prerr_endline ("Could not load preferences ("^
+		   (Printexc.to_string e)^").")
+    
+
+let configure () = 
+  let cmd_coqc = 
+    string
+      ~f:(fun s -> !current.cmd_coqc <- s) 
+      "       coqc"  !current.cmd_coqc in
+  let cmd_make = 
+    string 
+      ~f:(fun s -> !current.cmd_make <- s)
+      "       make" !current.cmd_make in
+  let cmd_coqmakefile = 
+    string 
+      ~f:(fun s -> !current.cmd_coqmakefile <- s)
+      "coqmakefile" !current.cmd_coqmakefile in
+  let cmd_coqdoc = 
+    string 
+      ~f:(fun s -> !current.cmd_coqdoc <- s)
+      "     coqdoc" !current.cmd_coqdoc in
+  let cmd_print = 
+    string 
+      ~f:(fun s -> !current.cmd_print <- s) 
+      "   Print ps" !current.cmd_print in
+
+  let config_font =
+    let box = GPack.hbox () in
+    let w = GMisc.font_selection () in
+    w#set_preview_text
+      "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
+    box#pack w#coerce;
+    ignore (w#misc#connect#realize 
+	      ~callback:(fun () -> w#set_font_name 
+			   (Pango.Font.to_string !current.text_font)));
+    custom
+      ~label:"Fonts for text"
+      box
+      (fun () -> 
+	 let fd =  w#font_name in
+	 !current.text_font <- (Pango.Font.from_string fd) ; 
+(*
+	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+*)
+	 !change_font !current.text_font)
+      true
+  in
+(*
+  let show_toolbar = 
+    bool 
+      ~f:(fun s -> 
+	    !current.show_toolbar <- s; 
+	    !show_toolbar s) 
+      "Show toolbar" !current.show_toolbar
+  in
+  let window_height =
+    string
+    ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600);
+	  !resize_window ();
+       ) 
+      "Window height" 
+      (string_of_int !current.window_height)
+  in  
+  let window_width =
+    string
+    ~f:(fun s -> !current.window_width <- 
+	  (try int_of_string s with _ -> 800)) 
+      "Window width" 
+      (string_of_int !current.window_width)
+  in  
+*)
+  let auto_complete = 
+    bool 
+      ~f:(fun s -> 
+	    !current.auto_complete <- s; 
+	    !auto_complete s) 
+      "Auto Complete" !current.auto_complete
+  in
+
+(*  let use_utf8_notation = 
+    bool 
+      ~f:(fun b -> 
+	    !current.use_utf8_notation <- b;
+	 ) 
+      "Use Unicode Notation: " !current.use_utf8_notation
+  in
+*)  
+(*
+  let config_appearance = [show_toolbar; window_width; window_height] in
+*)
+  let global_auto_revert = 
+    bool 
+      ~f:(fun s -> !current.global_auto_revert <- s) 
+      "Enable global auto revert" !current.global_auto_revert
+  in
+  let global_auto_revert_delay =
+    string
+    ~f:(fun s -> !current.global_auto_revert_delay <- 
+	  (try int_of_string s with _ -> 10000)) 
+      "Global auto revert delay (ms)" 
+      (string_of_int !current.global_auto_revert_delay)
+  in  
+
+  let auto_save = 
+    bool 
+      ~f:(fun s -> !current.auto_save <- s) 
+      "Enable auto save" !current.auto_save
+  in
+  let auto_save_delay =
+    string
+    ~f:(fun s -> !current.auto_save_delay <- 
+	  (try int_of_string s with _ -> 10000)) 
+      "Auto save delay (ms)" 
+      (string_of_int !current.auto_save_delay)
+  in  
+
+  let encodings = 
+    combo 
+      "File charset encoding "
+      ~f:(fun s -> 
+	    match s with
+	    | "UTF-8" -> 
+		!current.encoding_use_utf8 <- true;
+		!current.encoding_use_locale <- false
+	    | "LOCALE" ->
+		!current.encoding_use_utf8 <- false;
+		!current.encoding_use_locale <- true
+	    | _ -> 		
+		!current.encoding_use_utf8 <- false;
+		!current.encoding_use_locale <- false;
+		!current.encoding_manual <- s;
+	 )
+      ~new_allowed: true
+      ["UTF-8";"LOCALE";!current.encoding_manual]
+      (if !current.encoding_use_utf8 then "UTF-8" 
+       else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual)
+  in
+  let modifier_for_tactics = 
+    modifiers
+      ~allow:!current.modifiers_valid
+      ~f:(fun l -> !current.modifier_for_tactics <- l)
+      "Modifiers for Tactics Menu"
+      !current.modifier_for_tactics
+  in
+  let modifier_for_templates = 
+    modifiers
+      ~allow:!current.modifiers_valid
+      ~f:(fun l -> !current.modifier_for_templates <- l)
+      "Modifiers for Templates Menu"
+      !current.modifier_for_templates
+  in
+  let modifier_for_navigation = 
+    modifiers
+      ~allow:!current.modifiers_valid
+      ~f:(fun l -> !current.modifier_for_navigation <- l)
+      "Modifiers for Navigation Menu"
+      !current.modifier_for_navigation
+  in
+  let modifiers_valid = 
+    modifiers
+      ~f:(fun l -> !current.modifiers_valid <- l)
+      "Allowed modifiers"
+      !current.modifiers_valid
+  in
+  let mod_msg = 
+    string
+      "Needs restart to apply!"
+      ~editable:false
+      ""
+  in
+
+  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,""
+	    )
+      ~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,""
+	    )
+      ~help:"(%s for url)" 
+      "    Browser"
+      ((fst !current.cmd_browse)^"%s"^(snd !current.cmd_browse))
+  in    
+  let doc_url = 
+    string ~f:(fun s -> !current.doc_url <- s) " Manual URL"  !current.doc_url in
+  let library_url = 
+    string ~f:(fun s -> !current.library_url <- s) "Library URL"  !current.library_url in
+
+  let automatic_tactics = 
+    strings
+      ~f:(fun l -> !current.automatic_tactics <- l) 
+      ~add:(fun () -> ["<edit me>"])
+      "Wizard tactics to try in order" 
+      !current.automatic_tactics
+
+  in
+
+  let contextual_menus_on_goal =
+    bool 
+      ~f:(fun s -> 
+	    !current.contextual_menus_on_goal <- s; 
+	    !contextual_menus_on_goal s) 
+      "Contextual menus on goal" !current.contextual_menus_on_goal
+  in 
+
+  let misc = [contextual_menus_on_goal;auto_complete] in
+   
+(* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
+   (shame on Benjamin) *)
+  let cmds =
+    [Section("Fonts",
+	     [config_font]);
+     Section("Files",
+	     [global_auto_revert;global_auto_revert_delay;
+	      auto_save; auto_save_delay; (* auto_save_name*)
+	      encodings;
+	     ]);     
+(*
+     Section("Appearance",
+	     config_appearance);
+*)
+     Section("Externals",
+	     [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;
+	      cmd_editor;
+	      cmd_browse;doc_url;library_url]);
+     Section("Tactics Wizard",
+	     [automatic_tactics]);
+     Section("Shortcuts",
+	     [modifiers_valid; modifier_for_tactics;
+	      modifier_for_templates; modifier_for_navigation;mod_msg]);
+     Section("Misc",
+	     misc)]
+  in
+(*
+  Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+*)
+  let x = edit ~width:500 "Customizations" cmds in
+(*
+  Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+*)
+  match x with 
+    | Return_apply | Return_ok -> save_pref ()
+    | Return_cancel -> ()
+
diff --git a/ide/preferences.mli b/ide/preferences.mli
new file mode 100644
index 00000000..b4be283d
--- /dev/null
+++ b/ide/preferences.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: preferences.mli,v 1.8.2.1 2004/07/16 19:30:21 herbelin Exp $ *)
+
+type pref =
+    {
+      mutable cmd_coqc : string;
+      mutable cmd_make : string;
+      mutable cmd_coqmakefile : string;
+      mutable cmd_coqdoc : string;
+
+      mutable global_auto_revert : bool;
+      mutable global_auto_revert_delay : int;
+
+      mutable auto_save : bool;
+      mutable auto_save_delay : int;
+      mutable auto_save_name : string * string;
+
+      mutable encoding_use_locale : bool;
+      mutable encoding_use_utf8 : bool;
+      mutable encoding_manual : string;
+
+      mutable automatic_tactics : string list;
+      mutable cmd_print : string;
+
+      mutable modifier_for_navigation : Gdk.Tags.modifier list;
+      mutable modifier_for_templates : Gdk.Tags.modifier list;
+      mutable modifier_for_tactics : Gdk.Tags.modifier list;
+      mutable modifiers_valid : Gdk.Tags.modifier list;
+
+      mutable cmd_browse : string * string;
+      mutable cmd_editor : string * string;
+
+      mutable text_font : Pango.font_description;
+
+      mutable doc_url : string;
+      mutable library_url : string;
+
+      mutable show_toolbar : bool;
+      mutable contextual_menus_on_goal : bool;
+      mutable window_width : int;
+      mutable window_height : int;
+      mutable query_window_width : int;
+      mutable query_window_height : int;
+(*
+      mutable use_utf8_notation : bool;
+*)
+      mutable auto_complete : bool;
+    }
+
+val save_pref : unit -> unit
+val load_pref : unit -> unit
+
+val current : pref ref
+
+val configure : unit -> unit
+
+val change_font : ( Pango.font_description -> unit) ref
+val show_toolbar : (bool -> unit) ref
+val auto_complete : (bool -> unit) ref
+val resize_window : (unit -> unit) ref
diff --git a/ide/undo.ml b/ide/undo.ml
new file mode 100644
index 00000000..54449515
--- /dev/null
+++ b/ide/undo.ml
@@ -0,0 +1,178 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: undo.ml,v 1.8.2.1 2004/07/16 19:30:21 herbelin Exp $ *)
+
+open GText
+open Ideutils
+type action = 
+  | Insert of string * int * int (* content*pos*length *) 
+  | Delete of string * int * int (* content*pos*length *) 
+
+let neg act = match act with
+  | Insert (s,i,l) -> Delete (s,i,l)
+  | Delete (s,i,l) -> Insert (s,i,l)
+
+class undoable_view (tv:Gtk.text_view Gtk.obj) =
+  let undo_lock = ref true in 
+object(self)
+  inherit GText.view tv as super
+  val history = (Stack.create () : action Stack.t)
+  val redo = (Queue.create () : action Queue.t)
+  val nredo = (Stack.create () : action Stack.t)
+
+  method private dump_debug =
+    if false (* !debug *) then begin
+      prerr_endline "==========Stack top=============";
+      Stack.iter 
+	(fun e -> match e with
+	   | Insert(s,p,l) ->
+ 	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
+	   | Delete(s,p,l) -> 			   
+	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
+	history;
+      Printf.eprintf "Stack size %d\n" (Stack.length history);
+      prerr_endline "==========Stack Bottom==========";
+      prerr_endline "==========Queue start=============";
+      Queue.iter 
+	(fun e -> match e with
+	   | Insert(s,p,l) ->
+ 	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
+	   | Delete(s,p,l) -> 			   
+	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
+	redo;
+      Printf.eprintf "Stack size %d\n" (Queue.length redo);
+      prerr_endline "==========Queue End==========" 
+
+    end
+
+  method clear_undo = Stack.clear history; Stack.clear nredo; Queue.clear redo
+
+  method undo = if !undo_lock then begin
+    undo_lock := false;
+    prerr_endline "UNDO";
+    try begin
+      let r = 
+	match Stack.pop history with
+	  | Insert(s,p,l) as act -> 
+	      let start = self#buffer#get_iter_at_char p in
+	      (self#buffer#delete_interactive 
+		 ~start
+		 ~stop:(start#forward_chars l)
+		 ()) or
+	      (Stack.push act history; false)
+	  | Delete(s,p,l) as act -> 
+	      let iter = self#buffer#get_iter_at_char p in
+	      (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
+      end;
+      undo_lock := true; 
+      r
+    end
+    with Stack.Empty -> 
+      undo_lock := true; 
+      false
+  end else
+    (prerr_endline "UNDO DISCARDED"; true)
+
+  method redo = prerr_endline "REDO"; true
+  initializer
+(* INCORRECT: is called even while undoing...
+   ignore (self#buffer#connect#mark_set
+	      ~callback:
+	      (fun it tm -> if !undo_lock && not (Queue.is_empty redo) then begin
+		 Stack.iter (fun e -> Stack.push (neg e) history) nredo;
+		 Stack.clear nredo;
+		 Queue.iter (fun e -> Stack.push e history) redo;
+		 Queue.clear redo;
+	       end)
+	   );
+*)
+    ignore (self#buffer#connect#insert_text 
+	      ~callback:
+	      (fun it s ->
+		 if !undo_lock && not (Queue.is_empty redo) then begin
+		   Stack.iter (fun e -> Stack.push (neg e) history) nredo;
+		   Stack.clear nredo;
+		   Queue.iter (fun e -> Stack.push e history) redo;
+		   Queue.clear redo;
+		 end;
+		 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) -> 
+					       opos + olen <> pos
+					   | _ -> true)
+		 then *)
+		 Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history
+		 (*else begin
+		   match Stack.pop history with
+		     | Insert(olds,offset,len) -> 
+			 Stack.push 
+			 (Insert(olds^s,
+				 offset,
+				 len+(Glib.Utf8.length s)))
+			 history
+		     | _ -> assert false
+		   end*);
+		 self#dump_debug
+	      ));
+    ignore (self#buffer#connect#delete_range
+	      ~callback:
+	      (fun ~start ~stop -> 
+		 if !undo_lock && not (Queue.is_empty redo) then begin
+		   Queue.iter (fun e -> Stack.push e history) redo;
+		   Queue.clear redo;
+		 end;
+		 let start_offset = start#offset in
+		 let stop_offset = stop#offset in
+		 let s = self#buffer#get_text ~start ~stop () in
+(*		 if Stack.is_empty history or (match Stack.top history with
+						 | Delete(old,opos,olen) -> 
+						     olen=1 or opos <> start_offset
+						 | _ -> true
+					      )
+		 then
+*)		   Stack.push 
+		     (Delete(s,
+			     start_offset,
+			     stop_offset - start_offset
+			    ))
+		     history
+	(*	 else begin
+		   match Stack.pop history with
+		     | Delete(olds,offset,len) -> 
+			 Stack.push 
+			 (Delete(olds^s,
+				 offset,
+				 len+(Glib.Utf8.length s)))
+			 history
+		     | _ -> assert false
+			 
+		 end*);
+		 self#dump_debug
+	      ))
+end
+
+let undoable_view ?(buffer:GText.buffer option) =
+  GtkText.View.make_params [] 
+    ~cont:(GContainer.pack_container 
+	     ~create:
+	     (fun pl -> let w = match buffer with 
+	      | None -> GtkText.View.create []
+	      | Some b -> GtkText.View.create_with_buffer b#as_buffer
+	      in
+	      Gobject.set_params w pl; ((new undoable_view w):undoable_view)))
+    
+    
diff --git a/ide/undo.mli b/ide/undo.mli
new file mode 100644
index 00000000..6c7492ab
--- /dev/null
+++ b/ide/undo.mli
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: undo.mli,v 1.4.2.1 2004/07/16 19:30:21 herbelin Exp $ *)
+
+(* An undoable view class *)
+
+class undoable_view : Gtk.text_view Gtk.obj ->
+object
+  inherit GText.view
+  method undo : bool
+  method redo : bool
+  method clear_undo : unit
+end
+
+val undoable_view : 
+    ?buffer:GText.buffer ->
+    ?editable:bool ->
+    ?cursor_visible:bool ->
+    ?justification:GtkEnums.justification ->
+    ?wrap_mode:GtkEnums.wrap_mode ->
+    ?border_width:int ->
+    ?width:int ->
+    ?height:int ->
+    ?packing:(GObj.widget -> unit) ->
+    ?show:bool ->
+    unit ->
+  undoable_view
+
+
diff --git a/ide/utf8.v b/ide/utf8.v
new file mode 100644
index 00000000..574f2e65
--- /dev/null
+++ b/ide/utf8.v
@@ -0,0 +1,56 @@
+(* -*- coding:utf-8 -* *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Logic *)
+Notation "∀ x , P" := 
+  (forall x , P) (at level 200, x ident) : type_scope.
+Notation "∀ x y , P" := 
+  (forall x y , P) (at level 200, x ident, y ident) : type_scope.
+Notation "∀ x y z , P" := 
+  (forall x y z , P) (at level 200, x ident, y ident, z ident) : type_scope.
+Notation "∀ x y z u , P" := 
+  (forall x y z u , P) (at level 200, x ident, y ident, z ident, u ident) : type_scope.
+Notation "∀ x : t , P" := 
+  (forall x : t , P) (at level 200, x ident) : type_scope.
+Notation "∀ x y : t , P" := 
+  (forall x y : t , P) (at level 200, x ident, y ident) : type_scope.
+Notation "∀ x y z : t , P" := 
+  (forall x y z : t , P) (at level 200, x ident, y ident, z ident) : type_scope.
+Notation "∀ x y z u : t , P" := 
+  (forall x y z u : t , P) (at level 200, x ident, y ident, z ident, u ident) : type_scope.
+
+Notation "∃ x , P" := (exists x , P) (at level 200, x ident) : type_scope.
+Notation "∃ x : t , P" := (exists x : t, P) (at level 200, x ident) : type_scope.
+
+Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
+Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
+Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
+Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
+Notation "⌉ x" := (~x) (at level 75, right associativity) : type_scope.
+
+
+(* Abstraction *)
+(* Not nice
+Notation  "'λ' x : T , y" := ([x:T] y) (at level 1, x,T,y at level 10).
+Notation  "'λ' x := T , y" := ([x:=T] y) (at level 1, x,T,y at level 10).
+*)
+
+(* Arithmetic *)
+Notation "x ≤ y" := (le x y) (at level 70, no associativity).
+Notation "x ≥ y" := (ge x y) (at level 70, no associativity).
+
+(* test *)
+(*
+Goal ∀ x, True -> (∃ y , x ≥ y + 1) ∨ x ≤ 0.
+*)
+
+(* Integer Arithmetic *)
+(* TODO
+Notation "x ≤ y" := (Zle x y) (at level 1, y at level 10).
+*)
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
new file mode 100644
index 00000000..4c88adc5
--- /dev/null
+++ b/ide/utf8_convert.mll
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: utf8_convert.mll,v 1.1.2.1 2004/07/16 19:30:21 herbelin Exp $ *)
+
+{
+  open Lexing 
+  let b = Buffer.create 127
+
+}
+
+(* Replace all occurences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *)
+
+let digit = ['0'-'9''A'-'Z''a'-'z']
+let short = digit digit digit digit
+let long = short short
+
+rule entry = parse
+  | "\\x{" (short | long ) '}'
+      { let s = lexeme lexbuf in
+	let n = String.length s in
+	let code = 
+	  try Glib.Utf8.from_unichar 
+	    (int_of_string ("0x"^(String.sub s 3 (n - 4)))) 
+	  with _ -> s
+	in
+	let c = if Glib.Utf8.validate code then code else s in
+	Buffer.add_string b c;
+	entry lexbuf
+      }
+  | _ 
+      { let s = lexeme lexbuf in
+	Buffer.add_string b s;
+	entry lexbuf}
+  | eof
+      {
+	let s = Buffer.contents b in Buffer.reset b ; s
+      }
+
+
+{
+  let f s =
+   let lb = from_string s in
+   Buffer.reset b;
+   entry lb
+}
diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml
new file mode 100644
index 00000000..de6a7c57
--- /dev/null
+++ b/ide/utils/configwin.ml
@@ -0,0 +1,74 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+type parameter_kind = Configwin_types.parameter_kind
+
+type configuration_structure =
+    Configwin_types.configuration_structure =
+    Section of string * parameter_kind list
+  | Section_list of string * configuration_structure list
+
+type return_button =
+    Configwin_types.return_button =
+    Return_apply
+  | Return_ok
+  | Return_cancel
+
+module KeyOption = Configwin_types.KeyOption
+
+let string = Configwin_ihm.string
+let text = Configwin_ihm.text
+let strings = Configwin_ihm.strings
+let list = Configwin_ihm.list
+let bool = Configwin_ihm.bool
+let filename = Configwin_ihm.filename
+let filenames = Configwin_ihm.filenames
+let color = Configwin_ihm.color
+let font = Configwin_ihm.font
+let combo = Configwin_ihm.combo
+let custom = Configwin_ihm.custom
+let date = Configwin_ihm.date
+let hotkey = Configwin_ihm.hotkey
+let modifiers = Configwin_ihm.modifiers
+let html = Configwin_ihm.html
+
+let edit 
+    ?(apply=(fun () -> ()))
+    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 
+    ?(apply=(fun () -> ()))
+    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 
+    ~with_apply: false ~apply: (fun () -> ())
+
+let box = Configwin_ihm.box
+
+let tabbed_box = Configwin_ihm.tabbed_box
diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli
new file mode 100644
index 00000000..078befc6
--- /dev/null
+++ b/ide/utils/configwin.mli
@@ -0,0 +1,300 @@
+(**************************************************************************)
+(*                   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 is the interface of the Configwin library. *)
+
+(** {2 Types} *)
+
+(** This type represents the different kinds of parameters. *)
+type parameter_kind;;
+
+(** This type represents the structure of the configuration window. *)
+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 *)
+;;
+
+(** To indicate what button pushed the user when the window is closed. *)
+type return_button =
+    Return_apply
+      (** The user clicked on Apply at least once before
+	 closing the window with Cancel or the window manager. *)
+  | Return_ok
+      (** The user closed the window with the ok button. *)
+  | Return_cancel
+      (** The user closed the window with the cancel
+	 button or the window manager but never clicked
+	 on the apply button.*)
+
+
+(** {2 The key option class (to use with the {!Uoptions} 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
+
+(** {2 Functions to create parameters} *)
+
+(** [string label value] creates a string parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+*)
+val string : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: (string -> unit) -> string -> string -> 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.
+   @param f the function called to apply the value (default function does nothing).
+*)
+val bool : ?editable: bool -> ?help: string ->
+  ?f: (bool -> unit) -> string -> bool -> parameter_kind
+
+(** [strings label value] creates a string list parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+   @param add the function returning a list of strings when the user wants to add strings
+   (default returns an empty list).
+   @param eq the comparison function, used not to have doubles in list. Default
+   is [Pervasives.(=)]. If you want to allow doubles in the list, give a function
+   always returning false.
+*)
+val strings : ?editable: bool -> ?help: string ->
+  ?f: (string list -> unit) -> 
+    ?eq: (string -> string -> bool) ->
+      ?add: (unit -> string list) -> 
+	string -> string list -> parameter_kind
+	
+(** [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]
+   is the initial list.
+   @param editable indicate if the value is editable (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+   @param eq the comparison function, used not to have doubles in list. Default
+   is [Pervasives.(=)]. If you want to allow doubles in the list, give a function
+   always returning false.
+   @param edit an optional function to use to edit an element of the list.
+     The function returns an element, no matter if element was changed or not.
+     When this function is given, a "Edit" button appears next to the list.
+   @param add the function returning a list of values when the user wants to add values
+   (default returns an empty list).
+   @param titles an optional list of titles for the list. If the [f_strings]
+   function returns a list with more than one element, then you must give
+   a list of titles.
+   @param color an optional function returning the optional color for a given element.
+   This color is used to display the element in the list. The default function returns
+   no color for any element.
+*)
+val list : ?editable: bool -> ?help: string ->
+  ?f: ('a list -> unit) -> 
+    ?eq: ('a -> 'a -> bool) ->
+      ?edit: ('a -> 'a) ->
+	?add: (unit -> 'a list) -> 
+	  ?titles: string list ->
+	    ?color: ('a -> string option) ->
+	      string -> 
+		('a -> string list) ->
+		  'a list -> 
+		    parameter_kind
+
+(** [color label value] creates a color parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @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 -> 
+  ?f: (string -> unit) -> string -> string -> parameter_kind
+
+(** [font label value] creates a font parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @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 -> 
+  ?f: (string -> unit) -> string -> string -> parameter_kind
+
+(** [combo label choices value] creates a combo parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+   @param new_allowed indicate if a entry not in the list of choices is accepted
+   (default is [false]).
+   @param blank_allowed indicate if the empty selection [""] is accepted
+   (default is [false]).
+*)
+val combo : ?editable: bool -> ?expand: bool -> ?help: string -> 
+  ?f: (string -> unit) -> 
+    ?new_allowed: bool -> ?blank_allowed: bool ->
+      string -> string list -> string -> parameter_kind
+
+(** [text label value] creates a text parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the box for the text must expand or not (default is [true]).
+   @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 -> 
+  ?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 
+   to edit your bindings.
+*)
+val html : ?editable: bool -> ?expand: bool -> ?help: string -> 
+  ?f: (string -> unit) -> string -> string -> parameter_kind
+
+(** [filename label value] creates a filename parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+*)
+val filename : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?f: (string -> unit) -> string -> string -> parameter_kind
+
+(** [filenames label value] creates a filename list parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+   @param eq the comparison function, used not to have doubles in list. Default
+   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) -> 
+    ?eq: (string -> string -> bool) ->
+      string -> string list -> parameter_kind
+
+(** [date label value] creates a date parameter.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @param help an optional help message.
+   @param f the function called to apply the value (default function does nothing).
+   @param f_string the function used to display the date as a string. The parameter
+   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) -> 
+    ?f_string: ((int * int * int -> string)) ->
+      string -> (int * int * int) -> parameter_kind
+
+(** [hotkey label value] creates a hot key parameter.
+   A hot key is defined by a list of modifiers and a key code.
+   @param editable indicate if the value is editable (default is [true]).
+   @param expand indicate if the entry widget must expand or not (default is [true]).
+   @param help an optional help message.
+   @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) -> 
+    string -> (Gdk.Tags.modifier list * int) -> parameter_kind
+
+val modifiers : ?editable: bool -> ?expand: bool -> ?help: string ->
+  ?allow:(Gdk.Tags.modifier list) ->
+  ?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
+   must expand in its father.
+   @param label if a value is specified, a the box is packed into a frame.
+*)
+val custom : ?label: string -> GPack.box -> (unit -> unit) -> bool -> parameter_kind
+
+(** {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 
+   giving new values to parameters.
+*)
+val edit :
+  ?apply: (unit -> unit) ->
+  string ->
+  ?width:int ->
+  ?height:int ->
+  configuration_structure list ->
+  return_button
+
+(** This function takes a configuration structure and creates a window used
+   to get the various parameters from the user. It is the same window as edit but
+   there is no apply button.*)
+val get :
+  string ->
+  ?width:int ->
+  ?height:int ->
+  configuration_structure list ->
+  return_button
+
+(** 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 
+   giving new values to parameters.*)
+val simple_edit :
+  ?apply: (unit -> unit) ->
+  string ->
+  ?width:int ->
+  ?height:int ->
+  parameter_kind list -> return_button
+
+(** This function takes a list of parameter specifications and 
+   creates a window to configure the various parameters,
+   without Apply button.*)
+val simple_get :
+  string ->
+  ?width:int ->
+  ?height:int ->
+  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.
+*)
+val box : parameter_kind list -> 
+  (string * (unit -> unit)) list -> GPack.box
+
+(** 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
diff --git a/ide/utils/configwin_html_config.ml b/ide/utils/configwin_html_config.ml
new file mode 100644
index 00000000..fc2913d1
--- /dev/null
+++ b/ide/utils/configwin_html_config.ml
@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+(** The HTML editor bindings configurator. *)
+
+module C = Configwin_ihm
+open Configwin_types
+open Uoptions
+
+let simple_get = C.simple_edit 
+    ~with_apply: false ~apply: (fun () -> ())
+
+let params_hb hb =
+  let p_key = C.hotkey 
+      ~f: (fun k -> hb.html_key <- k) Configwin_messages.mKey
+      hb.html_key
+  in
+  let p_begin = C.string
+      ~f: (fun s -> hb.html_begin <- s)
+      Configwin_messages.html_begin
+      hb.html_begin
+  in
+  let p_end = C.string
+      ~f: (fun s -> hb.html_end <- s)
+      Configwin_messages.html_end
+      hb.html_end
+  in
+  [ p_key ; p_begin ; p_end ]
+
+let edit_hb hb =
+  ignore (simple_get Configwin_messages.mEdit (params_hb hb));
+  hb
+
+let add () =
+  let hb = { html_key = KeyOption.string_to_key "C-a" ;
+	     html_begin = "" ;
+	     html_end = "" ;
+	   } 
+  in
+  match simple_get Configwin_messages.mAdd (params_hb hb) with
+    Return_ok -> [hb]
+  | _ -> []
+
+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)
+      ~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 ;
+		   hb.html_begin ; hb.html_end ])
+      !!bindings
+  in
+  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
new file mode 100644
index 00000000..03ca706c
--- /dev/null
+++ b/ide/utils/configwin_ihm.ml
@@ -0,0 +1,1435 @@
+(**************************************************************************)
+(*                   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.*)
+
+open Configwin_types
+
+module O = Uoptions
+
+
+(** 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 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" ;
+	  html_begin = "<b>";
+	  html_end = "</b>" ;
+	} ;
+	{ html_key = KeyOption.string_to_key "A-i" ;
+	  html_begin = "<i>";
+	  html_end = "</i>" ;
+	} 
+      ]	
+  in
+  O.load ini ;
+  (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 
+   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 fs = GWindow.file_selection ~modal:true
+      ~title: the_title () in
+  (* we set the previous directory, if no directory is given *)
+  (
+   match dir with
+     None ->
+       if !last_dir <> "" then
+         let _ = fs#set_filename !last_dir in
+         ()
+       else
+         ()
+  | Some 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
+        None ->
+          (fun () -> files := [fs#filename] ; fs#destroy ())
+      | Some f ->
+          (fun () -> f fs#filename)
+      )
+  in
+  let _ = fs # cancel_button # connect#clicked ~callback:fs#destroy in
+  fs # show ();
+  GMain.Main.main ();
+  match !files with
+  | [] ->
+      []
+  | [""] ->
+      []
+  | l ->
+      (* we keep the directory in last_dir *)
+      last_dir := Filename.dirname (List.hd l);
+      l
+;;
+
+(** Make the user select a date. *)
+let select_date title (day,mon,year) =
+  let v_opt = ref None in
+  let window = GWindow.dialog ~modal:true ~title () in
+  let hbox = GPack.hbox ~border_width:10 ~packing:window#vbox#add () in
+  let cal = GMisc.calendar ~packing: (hbox#pack ~expand: true) () in
+  cal#select_month ~month: mon ~year: year ;
+  cal#select_day day;
+  let bbox = window#action_area in
+
+  let bok = GButton.button ~label: Configwin_messages.mOk
+      ~packing:(bbox#pack ~expand:true ~padding:4) ()
+  in
+  let bcancel = GButton.button ~label: Configwin_messages.mCancel
+      ~packing:(bbox#pack ~expand:true ~padding:4) ()
+  in
+  ignore (bok#connect#clicked ~callback:
+	    (fun () -> v_opt := Some (cal#date); window#destroy ()));
+  ignore(bcancel#connect#clicked ~callback: window#destroy);
+
+  bok#grab_default ();
+  ignore(window#connect#destroy ~callback: GMain.Main.quit);
+  window#set_position `CENTER;
+  window#show ();
+  GMain.Main.main ();
+  !v_opt
+
+
+(** This class builds a frame with a clist and two buttons :
+   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     
+   each instance of the class creates a frame. *)
+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 =
+  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) () 
+  in
+  let wlist = match titles_opt with
+    None -> 
+      GList.clist ~selection_mode: `MULTIPLE
+	~titles_show: false
+	~packing: wscroll#add ()
+  | Some l -> 
+      GList.clist ~selection_mode: `MULTIPLE 
+	~titles: l
+	~titles_show: true
+	~packing: wscroll#add ()
+  in
+  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 
+  in  (* the vbox for the buttons *)
+  let vbox_buttons = GPack.vbox () in
+  let _ = 
+    if editable then
+      let _ = hbox#pack ~expand: false vbox_buttons#coerce in
+      ()
+    else
+      () 
+  in
+  let wb_add = GButton.button
+      ~label: Configwin_messages.mAdd
+      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
+      ()
+  in
+  let wb_edit = GButton.button
+      ~label: Configwin_messages.mEdit
+      ()
+  in
+  let _ = match f_edit_opt with
+    None -> ()
+  | Some _ -> vbox_buttons#pack ~expand:false ~padding:2 wb_edit#coerce
+  in
+  let wb_up = GButton.button
+      ~label: Configwin_messages.mUp
+      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
+      ()
+  in
+  let wb_remove = GButton.button
+      ~label: Configwin_messages.mRemove
+      ~packing: (vbox_buttons#pack ~expand:false ~padding:2)
+      ()
+  in
+  object (self)
+    (** the list of selected rows *)
+    val mutable list_select = []
+
+    (** This method returns the frame created. *)
+    method box = wev
+
+    method update l =
+      (* set the new list in the provided listref *)
+      listref := l;
+      (* insert the elements in the clist *)
+      wlist#freeze ();
+      wlist#clear ();
+      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);
+      wlist#thaw ();
+      (* the list of selectd elements is now empty *)
+      list_select <- []
+
+    (** Move up the selected rows. *)
+    method up_selected =
+      let rec iter n selrows l =
+	match selrows with
+	  [] -> (l, [])
+	| m :: qrows ->
+	    match l with
+	      [] -> ([],[])
+	    | [_] -> (l,[])
+	    | e1 :: e2 :: q when m = n + 1 ->
+		let newl, newrows = iter (n+1) qrows (e1 :: q) in
+		(e2 :: newl, n :: newrows)
+	    | e1 :: q ->
+		let newl, newrows = iter (n+1) selrows q in
+		(e1 ::  newl, newrows)
+      in
+      let sorted_select = List.sort compare list_select in
+      let new_list, new_rows = iter 0 sorted_select !listref in
+      self#update new_list;
+      List.iter (fun n -> wlist#select n 0) new_rows
+
+    (** Make the user edit the first selected row. *)
+    method edit_selected f_edit =
+      let sorted_select = List.sort compare list_select in
+      match sorted_select with
+	[] -> ()
+      |	n :: _ ->
+	  try
+	    let ele = List.nth !listref n in
+	    let ele2 = f_edit ele in
+	    let rec iter m = function
+		[] -> []
+	      |	e :: q ->
+		  if n = m then
+		    ele2 :: q
+		  else
+		    e :: (iter (m+1) q)
+	    in
+	    self#update (iter 0 !listref);
+	    wlist#select n 0
+	  with
+	    Not_found ->
+	      ()
+
+    initializer
+      (** create the functions called when the buttons are clicked *)
+      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 
+           the listref, using the eq predicate *)
+        let l2 = List.fold_left
+            (fun acc -> fun ele ->
+              if List.exists (eq ele) acc then
+                acc
+              else
+                acc @ [ele])
+            !listref
+            l
+        in    
+        self#update l2
+      in
+      let f_remove () =
+        (* remove the selected items from the listref and the clist *)
+	let rec iter n = function
+	    [] -> []
+	  | h :: q ->
+	      if List.mem n list_select then
+		iter (n+1) q
+	      else
+		h :: (iter (n+1) q)
+	in
+        let new_list = iter 0 !listref in
+        self#update new_list
+      in
+      (* connect the functions to the buttons *)
+      ignore (wb_add#connect#clicked f_add);
+      ignore (wb_remove#connect#clicked f_remove);
+      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))
+      );
+      (* connect the selection and deselection of items in the clist *)
+      let f_select ~row ~column ~event =
+        try
+          list_select <- row :: list_select
+        with
+          Failure _ ->
+            ()
+      in
+      let f_unselect ~row ~column ~event =
+        try
+          let new_list_select = List.filter (fun n -> n <> row) list_select in
+          list_select <- new_list_select
+        with
+          Failure _ ->
+            ()
+      in
+      (* connect the select and deselect events *)
+      ignore(wlist#connect#select_row f_select);
+      ignore(wlist#connect#unselect_row f_unselect);
+
+      (* initialize the clist with the listref *)
+      self#update !listref
+  end;;
+
+
+(** This class is used to build a box for a string parameter.*)
+class string_param_box param =
+  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
+  let we = GEdit.entry
+      ~editable: param.string_editable
+      ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2)
+      ()
+  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 
+  in
+  let _ = we#set_text 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
+      if new_value <> param.string_value then
+	let _ = param.string_f_apply new_value in
+	param.string_value <- new_value
+      else
+	()
+  end ;;
+
+(** This class is used to build a box for a combo parameter.*)
+class combo_param_box param =
+  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*)
+      ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2)
+      ()
+  in
+  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 
+  in
+  let _ = wc#entry#set_editable param.combo_editable in
+  let _ = wc#entry#set_text param.combo_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 = wc#entry#text in
+      if new_value <> param.combo_value then
+	let _ = param.combo_f_apply new_value in
+	param.combo_value <- new_value
+      else
+	()
+  end ;;
+
+(** Class used to pack a custom box. *)
+class custom_param_box param =
+  let top = 
+    match param.custom_framed with
+      None -> param.custom_box#coerce
+    | Some l ->
+	let wf = GBin.frame ~label: l () in
+	wf#add param.custom_box#coerce;
+	wf#coerce
+  in
+  object (self)
+    method box = top
+    method apply = param.custom_f_apply ()
+  end
+
+(** This class is used to build a box for a color parameter.*)
+class color_param_box param =
+  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) () 
+  in
+  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 _ = 
+    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 
+  in
+  let set_color s =
+    let style = w_test#misc#style#copy in
+    (
+     try style#set_bg [ (`NORMAL, `NAME s) ; ]
+     with _ -> ()
+    );
+    w_test#misc#set_style style 
+  in
+  let _ = set_color !v in
+  let _ = we#set_text !v in
+  let f_sel () =
+    let dialog = GWindow.color_selection_dialog
+	~title: param.color_label
+	~modal: true
+	~show: true
+	()
+    in
+    let wb_ok = dialog#ok_button in
+    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 _ = 
+	    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;*)
+	  dialog#destroy ()
+	)
+    in
+    let _ = wb_cancel#connect#clicked dialog#destroy in
+    GMain.Main.main ()
+  in
+  let _ = 
+    if param.color_editable then ignore (wb#connect#clicked f_sel)
+  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
+      if new_value <> param.color_value then
+	let _ = param.color_f_apply new_value in
+	param.color_value <- new_value
+      else
+	()
+  end ;;
+
+(** This class is used to build a box for a font parameter.*)
+class font_param_box param =
+  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) () 
+  in
+  let we = GEdit.entry
+      ~editable: false
+      ~packing: (hbox#pack ~expand: param.font_expand ~padding: 2)
+      ()
+  in
+  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 
+  in
+  let set_entry_font font_opt =
+    match font_opt with
+      None -> ()
+    | Some s ->
+	let style = we#misc#style#copy in
+	(
+	 try 
+	   let font = Gdk.Font.load_fontset s in
+	   style#set_font font
+	 with _ -> ()
+	);
+	we#misc#set_style style
+  in
+  let _ = set_entry_font (Some !v) in
+  let _ = we#set_text !v in
+  let f_sel () =
+    let dialog = GWindow.font_selection_dialog
+	~title: param.font_label
+	~modal: true
+	~show: true
+	()
+    in
+    dialog#selection#set_font_name !v;
+    let wb_ok = dialog#ok_button in
+    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;*)
+	  dialog#destroy ()
+	)
+    in
+    let _ = wb_cancel#connect#clicked dialog#destroy in
+    GMain.Main.main ()
+  in
+  let _ = if param.font_editable then ignore (wb#connect#clicked f_sel) 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
+      if new_value <> param.font_value then
+	let _ = param.font_f_apply new_value in
+	param.font_value <- new_value
+      else
+	()
+  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
+  let wscroll = GBin.scrolled_window
+      ~vpolicy: `AUTOMATIC
+      ~hpolicy: `AUTOMATIC
+      ~packing: (hbox#pack ~expand: true ~padding: 2) () 
+  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 _ = 
+    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 
+  in
+  let _ = wt#buffer#insert param.string_value in
+
+  object (self)
+    val wt = wt
+    (** 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 = 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
+      else
+	()
+  end ;;
+
+(** This class is used to build a box a html parameter. *)
+class html_param_box param =
+  object (self)
+    inherit text_param_box param
+
+    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
+    initializer
+      let (_,html_bindings) = html_config_file_and_option () in
+      let add_shortcut hb =
+	let (mods, k) = hb.html_key in
+	Okey.add wt ~mods k (self#exec hb.html_begin hb.html_end)
+      in
+      List.iter add_shortcut (O.(!!) html_bindings)      
+  end
+
+(** This class is used to build a box for a boolean parameter.*)
+class bool_param_box param =
+  let wchk = GButton.check_button
+      ~label: param.bool_label
+      ()
+  in
+  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 
+  in
+  let _ = wchk#set_active param.bool_value in
+  let _ = wchk#misc#set_sensitive param.bool_editable in
+
+  object (self)
+    (** This method returns the check button ready to be packed. *)
+    method box = wchk#coerce
+    (** This method applies the new value of the parameter. *)
+    method apply =
+      let new_value = wchk#active in
+      if new_value <> param.bool_value then
+	let _ = param.bool_f_apply new_value in
+	param.bool_value <- new_value
+      else
+	()
+  end ;;
+
+(** This class is used to build a box for a file name parameter.*)
+class filename_param_box param =
+  let hbox = GPack.hbox () in
+  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 _ = 
+    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 
+  in
+  let _ = we#set_text param.string_value in
+
+  let f_click () =
+    match select_files param.string_label with
+      [] ->
+        ()
+    | f :: _ ->
+        we#set_text f
+  in
+  let _ = 
+    if param.string_editable then
+      let _ = wb#connect#clicked f_click in
+      ()
+    else
+      ()
+  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
+      if new_value <> param.string_value then
+	let _ = param.string_f_apply new_value in
+	param.string_value <- new_value
+      else
+	()
+  end ;;
+
+(** This class is used to build a box for a hot key parameter.*)
+class hotkey_param_box param =
+  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 () 
+  in
+  let we = GEdit.entry
+      ~editable: false
+      ~packing: (hbox#pack ~expand: param.hk_expand ~padding: 2)
+      ()
+  in
+  let value = ref param.hk_value in
+  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 
+  in
+  let _ = we#set_text (KeyOption.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
+    let modifiers = GdkEvent.Key.state ev in
+    let mods = List.filter
+	(fun m -> not (List.mem m mods_we_dont_care))
+	modifiers
+    in
+    value := (mods, key);
+    we#set_text (KeyOption.key_to_string !value);
+    false
+  in
+  let _ = 
+    if param.hk_editable then
+      ignore (we#event#connect#key_press capture)
+    else
+      ()
+  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 = !value in
+      if new_value <> param.hk_value then
+	let _ = param.hk_f_apply new_value in
+	param.hk_value <- new_value
+      else
+	()
+  end ;;
+
+class modifiers_param_box param =
+  let hbox = GPack.hbox () in
+  let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in
+  let wl = GMisc.label ~text: param.md_label 
+      ~packing: wev#add () 
+  in
+  let we = GEdit.entry
+      ~editable: false
+      ~packing: (hbox#pack ~expand: param.md_expand ~padding: 2)
+      ()
+  in
+  let value = ref param.md_value in
+  let _ = 
+    match param.md_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 
+  in
+  let _ = we#set_text (KeyOption.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
+    let mods = List.filter
+	(fun m -> (List.mem m mods_we_care))
+	modifiers
+    in
+    value := mods;
+    we#set_text (KeyOption.modifiers_to_string !value);
+    false
+  in
+  let _ = 
+    if param.md_editable then
+      ignore (we#event#connect#key_press capture)
+    else
+      ()
+  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 = !value in
+      if new_value <> param.md_value then
+	let _ = param.md_f_apply new_value in
+	param.md_value <- new_value
+      else
+	()
+  end ;;
+
+(** This class is used to build a box for a date parameter.*)
+class date_param_box param =
+  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) () 
+  in
+  let we = GEdit.entry
+      ~editable: false
+      ~packing: (hbox#pack ~expand: param.date_expand ~padding: 2)
+      ()
+  in
+  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 
+  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) -> 
+	v := (d,m,y) ;
+	we#set_text (param.date_f_string (d,m,y))
+  in
+  let _ = 
+    if param.date_editable then
+      let _ = wb#connect#clicked f_click in
+      ()
+    else
+      ()
+  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 =
+      if !v <> param.date_value then
+	let _ = param.date_f_apply !v in
+	param.date_value <- !v
+      else
+	()
+  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) =
+  let listref = ref param.list_value in
+  let frame_selection = new list_selection_box
+      listref
+      param.list_titles
+      param.list_help
+      param.list_f_edit
+      param.list_strings
+      param.list_color
+      param.list_eq
+      param.list_f_add param.list_label param.list_editable
+  in
+      
+  object (self)
+    (** This method returns the main box ready to be packed. *)
+    method box = frame_selection#box#coerce
+    (** This method applies the new value of the parameter. *)
+    method apply =
+      param.list_f_apply !listref ;
+      param.list_value <- !listref
+  end ;;
+
+(** 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) =
+  (* we build different widgets, according to the conf_struct parameter *)
+  let main_box = GPack.vbox () in
+  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
+	in
+	let list_children_boxes = List.map f param_list in
+	
+	(label, list_children_boxes)
+
+    | Section_list (label, struct_list) ->
+	let wnote = GPack.notebook 
+            (*homogeneous_tabs: true*)
+	    ~scrollable: true
+	    ~show_tabs: true
+	    ~tab_border: 3
+	    ~packing: (main_box#pack ~expand: true)
+	    ()
+	in
+	(* we create all the children boxes *)
+	let f structure =
+	  let new_box = new configuration_box 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 
+      ~tab_label: page_label#coerce
+      main_box#coerce
+  in
+
+  object (self)
+    (** This method returns the main box ready to be packed. *)
+    method box = main_box#coerce
+    (** This method make the new values of the paramters applied, recursively in
+       all boxes.*)
+    method apply =
+      List.iter (fun box -> box#apply) child_boxes
+  end
+;;
+
+(** Create a vbox 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.
+*)
+let tabbed_box conf_struct_list buttons =
+  let vbox = GPack.vbox () 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)
+      conf_struct_list
+  in
+  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 ->    
+        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 ();
+
+        iter_buttons q
+  in
+  iter_buttons ~grab: true buttons;
+
+  vbox
+
+(** This function takes a configuration structure list and creates a window
+   to configure the various parameters. *)
+let edit ?(with_apply=true)  
+    ?(apply=(fun () -> ()))
+    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)
+      conf_struct_list
+  in
+
+  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 =
+  let main_box = GPack.vbox  () in
+  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
+  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 
+  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 ();
+
+        iter_buttons q
+  in
+  iter_buttons ~grab: true buttons;
+
+  main_box
+
+
+(** 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) ;
+      ]	
+  in
+  let box = box param_list buttons in
+  window#add box#coerce;
+  let _ = window#show () in
+  GMain.Main.main () ;
+  !return
+
+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
+    {
+      string_label = label ;
+      string_help = help ;
+      string_value = v ;
+      string_editable = editable ;
+      string_f_apply = f ;
+      string_expand = expand ;
+    } 
+
+(** Create a bool param. *)
+let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v =
+  Bool_param
+    {
+      bool_label = label ;
+      bool_help = help ;
+      bool_value = v ;
+      bool_editable = editable ;
+      bool_f_apply = f ;
+    }
+
+(** Create a list param. *)
+let list ?(editable=true) ?help
+    ?(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 () ->
+      Obj.magic
+	(new list_param_box
+	   {
+	     list_label = label ;
+	     list_help = help ;
+	     list_value = v ;
+	     list_editable = editable ;
+	     list_titles = titles;
+	     list_eq = eq ;
+	     list_strings = f_strings ;
+	     list_color = color ;
+	     list_f_edit = edit ;
+	     list_f_add = add ;
+	     list_f_apply = f ;
+	   } 
+	)
+    )
+
+(** Create a strings param. *)
+let strings ?(editable=true) ?help
+    ?(f=(fun _ -> ())) 
+    ?(eq=Pervasives.(=))
+    ?(add=(fun () -> [])) label v =
+  list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v
+
+(** Create a color param. *)
+let color ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
+  Color_param
+    {
+      color_label = label ;
+      color_help = help ;
+      color_value = v ;
+      color_editable = editable ;
+      color_f_apply = f ;
+      color_expand = expand ;
+    }
+
+(** Create a font param. *)
+let font ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v =
+  Font_param
+    {
+      font_label = label ;
+      font_help = help ;
+      font_value = v ;
+      font_editable = editable ;
+      font_f_apply = f ;
+      font_expand = expand ;
+    }
+
+(** Create a combo param. *)
+let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) 
+    ?(new_allowed=false) 
+    ?(blank_allowed=false) label choices v =
+  Combo_param
+    {
+      combo_label = label ;
+      combo_help = help ;
+      combo_value = v ;
+      combo_editable = editable ;
+      combo_choices = choices ;
+      combo_new_allowed = new_allowed ;
+      combo_blank_allowed = blank_allowed ;
+      combo_f_apply = f ;
+      combo_expand = expand ;
+    }
+
+(** Create a text param. *)
+let text ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = 
+  Text_param
+    {
+      string_label = label ;
+      string_help = help ;
+      string_value = v ;
+      string_editable = editable ;
+      string_f_apply = f ;
+      string_expand = expand ;
+    } 
+
+(** Create a html param. *)
+let html ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = 
+  Html_param
+    {
+      string_label = label ;
+      string_help = help ;
+      string_value = v ;
+      string_editable = editable ;
+      string_f_apply = f ;
+      string_expand = expand ;
+    } 
+
+(** Create a filename param. *)
+let filename ?(editable=true) ?(expand=true)?help ?(f=(fun _ -> ())) label v = 
+  Filename_param
+    {
+      string_label = label ;
+      string_help = help ;
+      string_value = v ;
+      string_editable = editable ;
+      string_f_apply = f ;
+      string_expand = expand ;
+    } 
+
+(** Create a filenames param.*)
+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
+
+(** Create a date param. *)
+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
+    {
+      date_label = label ;
+      date_help = help ;
+      date_value = v ;
+      date_editable = editable ;
+      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 =
+  Hotkey_param
+    {
+      hk_label = label ;
+      hk_help = help ;
+      hk_value = v ;
+      hk_editable = editable ;
+      hk_f_apply = f ;
+      hk_expand = expand ;
+    } 
+
+let modifiers 
+  ?(editable=true) 
+  ?(expand=true) 
+  ?help 
+  ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) 
+  ?(f=(fun _ -> ())) label v =
+  Modifiers_param
+    {
+      md_label = label ;
+      md_help = help ;
+      md_value = v ;
+      md_editable = editable ;
+      md_f_apply = f ;
+      md_expand = expand ;
+      md_allow = allow ;
+    } 
+
+(** Create a custom param.*)
+let custom ?label box f expand =
+  Custom_param
+    {
+      custom_box = box ;
+      custom_f_apply = f ;
+      custom_expand = expand ;
+      custom_framed = label ;
+    } 
diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml
new file mode 100644
index 00000000..9c867845
--- /dev/null
+++ b/ide/utils/configwin_keys.ml
@@ -0,0 +1,4175 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+(** Key codes
+
+   Ce fichier provient de X11/keysymdef.h 
+   les noms des symboles deviennent : XK_ -> xk_
+
+   Thanks to Fabrice Le Fessant.
+*)
+
+let xk_VoidSymbol		= 0xFFFFFF	(** void symbol *)
+
+
+(** TTY Functions, cleverly chosen to map to ascii, for convenience of
+  programming, but could have been arbitrary (at the cost of lookup
+  tables in client code.
+*)
+
+let xk_BackSpace		= 0xFF08	(** back space, back char *)
+let xk_Tab			= 0xFF09
+let xk_Linefeed		= 0xFF0A	(** Linefeed, LF *)
+let xk_Clear		= 0xFF0B
+let xk_Return		= 0xFF0D	(** Return, enter *)
+let xk_Pause		= 0xFF13	(** Pause, hold *)
+let xk_Scroll_Lock		= 0xFF14
+let xk_Sys_Req		= 0xFF15
+let xk_Escape		= 0xFF1B
+let xk_Delete		= 0xFFFF	(** Delete, rubout *)
+
+
+
+(** International & multi-key character composition *)
+
+let xk_Multi_key		= 0xFF20  (** Multi-key character compose *)
+
+(** Japanese keyboard support *)
+
+let xk_Kanji		= 0xFF21	(** Kanji, Kanji convert *)
+let xk_Muhenkan		= 0xFF22  (** Cancel Conversion *)
+let xk_Henkan_Mode		= 0xFF23  (** Start/Stop Conversion *)
+let xk_Henkan		= 0xFF23  (** Alias for Henkan_Mode *)
+let xk_Romaji		= 0xFF24  (** to Romaji *)
+let xk_Hiragana		= 0xFF25  (** to Hiragana *)
+let xk_Katakana		= 0xFF26  (** to Katakana *)
+let xk_Hiragana_Katakana	= 0xFF27  (** Hiragana/Katakana toggle *)
+let xk_Zenkaku		= 0xFF28  (** to Zenkaku *)
+let xk_Hankaku		= 0xFF29  (** to Hankaku *)
+let xk_Zenkaku_Hankaku	= 0xFF2A  (** Zenkaku/Hankaku toggle *)
+let xk_Touroku		= 0xFF2B  (** Add to Dictionary *)
+let xk_Massyo		= 0xFF2C  (** Delete from Dictionary *)
+let xk_Kana_Lock		= 0xFF2D  (** Kana Lock *)
+let xk_Kana_Shift		= 0xFF2E  (** Kana Shift *)
+let xk_Eisu_Shift		= 0xFF2F  (** Alphanumeric Shift *)
+let xk_Eisu_toggle		= 0xFF30  (** Alphanumeric toggle *)
+
+(** = 0xFF31 thru = 0xFF3F are under xk_KOREAN *)
+
+(** Cursor control & motion *)
+
+let xk_Home			= 0xFF50
+let xk_Left			= 0xFF51	(** Move left, left arrow *)
+let xk_Up			= 0xFF52	(** Move up, up arrow *)
+let xk_Right		= 0xFF53	(** Move right, right arrow *)
+let xk_Down			= 0xFF54	(** Move down, down arrow *)
+let xk_Prior		= 0xFF55	(** Prior, previous *)
+let xk_Page_Up		= 0xFF55
+let xk_Next			= 0xFF56	(** Next *)
+let xk_Page_Down		= 0xFF56
+let xk_End			= 0xFF57	(** EOL *)
+let xk_Begin		= 0xFF58	(** BOL *)
+
+
+(** Misc Functions *)
+
+let xk_Select		= 0xFF60	(** Select, mark *)
+let xk_Print		= 0xFF61
+let xk_Execute		= 0xFF62	(** Execute, run, do *)
+let xk_Insert		= 0xFF63	(** Insert, insert here *)
+let xk_Undo			= 0xFF65	(** Undo, oops *)
+let xk_Redo			= 0xFF66	(** redo, again *)
+let xk_Menu			= 0xFF67
+let xk_Find			= 0xFF68	(** Find, search *)
+let xk_Cancel		= 0xFF69	(** Cancel, stop, abort, exit *)
+let xk_Help			= 0xFF6A	(** Help *)
+let xk_Break		= 0xFF6B
+let xk_Mode_switch		= 0xFF7E	(** Character set switch *)
+let xk_script_switch        = 0xFF7E  (** Alias for mode_switch *)
+let xk_Num_Lock		= 0xFF7F
+
+(** Keypad Functions, keypad numbers cleverly chosen to map to ascii *)
+
+let xk_KP_Space		= 0xFF80	(** space *)
+let xk_KP_Tab		= 0xFF89
+let xk_KP_Enter		= 0xFF8D	(** enter *)
+let xk_KP_F1		= 0xFF91	(** PF1, KP_A, ... *)
+let xk_KP_F2		= 0xFF92
+let xk_KP_F3		= 0xFF93
+let xk_KP_F4		= 0xFF94
+let xk_KP_Home		= 0xFF95
+let xk_KP_Left		= 0xFF96
+let xk_KP_Up		= 0xFF97
+let xk_KP_Right		= 0xFF98
+let xk_KP_Down		= 0xFF99
+let xk_KP_Prior		= 0xFF9A
+let xk_KP_Page_Up		= 0xFF9A
+let xk_KP_Next		= 0xFF9B
+let xk_KP_Page_Down		= 0xFF9B
+let xk_KP_End		= 0xFF9C
+let xk_KP_Begin		= 0xFF9D
+let xk_KP_Insert		= 0xFF9E
+let xk_KP_Delete		= 0xFF9F
+let xk_KP_Equal		= 0xFFBD	(** equals *)
+let xk_KP_Multiply		= 0xFFAA
+let xk_KP_Add		= 0xFFAB
+let xk_KP_Separator		= 0xFFAC	(** separator, often comma *)
+let xk_KP_Subtract		= 0xFFAD
+let xk_KP_Decimal		= 0xFFAE
+let xk_KP_Divide		= 0xFFAF
+
+let xk_KP_0			= 0xFFB0
+let xk_KP_1			= 0xFFB1
+let xk_KP_2			= 0xFFB2
+let xk_KP_3			= 0xFFB3
+let xk_KP_4			= 0xFFB4
+let xk_KP_5			= 0xFFB5
+let xk_KP_6			= 0xFFB6
+let xk_KP_7			= 0xFFB7
+let xk_KP_8			= 0xFFB8
+let xk_KP_9			= 0xFFB9
+
+
+
+(*
+ * Auxilliary Functions; note the duplicate definitions for left and right
+ * function keys;  Sun keyboards and a few other manufactures have such
+ * function key groups on the left and/or right sides of the keyboard.
+ * We've not found a keyboard with more than 35 function keys total.
+ *)
+
+let xk_F1			= 0xFFBE
+let xk_F2			= 0xFFBF
+let xk_F3			= 0xFFC0
+let xk_F4			= 0xFFC1
+let xk_F5			= 0xFFC2
+let xk_F6			= 0xFFC3
+let xk_F7			= 0xFFC4
+let xk_F8			= 0xFFC5
+let xk_F9			= 0xFFC6
+let xk_F10			= 0xFFC7
+let xk_F11			= 0xFFC8
+let xk_L1			= 0xFFC8
+let xk_F12			= 0xFFC9
+let xk_L2			= 0xFFC9
+let xk_F13			= 0xFFCA
+let xk_L3			= 0xFFCA
+let xk_F14			= 0xFFCB
+let xk_L4			= 0xFFCB
+let xk_F15			= 0xFFCC
+let xk_L5			= 0xFFCC
+let xk_F16			= 0xFFCD
+let xk_L6			= 0xFFCD
+let xk_F17			= 0xFFCE
+let xk_L7			= 0xFFCE
+let xk_F18			= 0xFFCF
+let xk_L8			= 0xFFCF
+let xk_F19			= 0xFFD0
+let xk_L9			= 0xFFD0
+let xk_F20			= 0xFFD1
+let xk_L10			= 0xFFD1
+let xk_F21			= 0xFFD2
+let xk_R1			= 0xFFD2
+let xk_F22			= 0xFFD3
+let xk_R2			= 0xFFD3
+let xk_F23			= 0xFFD4
+let xk_R3			= 0xFFD4
+let xk_F24			= 0xFFD5
+let xk_R4			= 0xFFD5
+let xk_F25			= 0xFFD6
+let xk_R5			= 0xFFD6
+let xk_F26			= 0xFFD7
+let xk_R6			= 0xFFD7
+let xk_F27			= 0xFFD8
+let xk_R7			= 0xFFD8
+let xk_F28			= 0xFFD9
+let xk_R8			= 0xFFD9
+let xk_F29			= 0xFFDA
+let xk_R9			= 0xFFDA
+let xk_F30			= 0xFFDB
+let xk_R10			= 0xFFDB
+let xk_F31			= 0xFFDC
+let xk_R11			= 0xFFDC
+let xk_F32			= 0xFFDD
+let xk_R12			= 0xFFDD
+let xk_F33			= 0xFFDE
+let xk_R13			= 0xFFDE
+let xk_F34			= 0xFFDF
+let xk_R14			= 0xFFDF
+let xk_F35			= 0xFFE0
+let xk_R15			= 0xFFE0
+
+(** Modifiers *)
+
+let xk_Shift_L		= 0xFFE1	(** Left shift *)
+let xk_Shift_R		= 0xFFE2	(** Right shift *)
+let xk_Control_L		= 0xFFE3	(** Left control *)
+let xk_Control_R		= 0xFFE4	(** Right control *)
+let xk_Caps_Lock		= 0xFFE5	(** Caps lock *)
+let xk_Shift_Lock		= 0xFFE6	(** Shift lock *)
+
+let xk_Meta_L		= 0xFFE7	(** Left meta *)
+let xk_Meta_R		= 0xFFE8	(** Right meta *)
+let xk_Alt_L		= 0xFFE9	(** Left alt *)
+let xk_Alt_R		= 0xFFEA	(** Right alt *)
+let xk_Super_L		= 0xFFEB	(** Left super *)
+let xk_Super_R		= 0xFFEC	(** Right super *)
+let xk_Hyper_L		= 0xFFED	(** Left hyper *)
+let xk_Hyper_R		= 0xFFEE	(** Right hyper *)
+
+
+(*
+ * ISO 9995 Function and Modifier Keys
+ * Byte 3 = = 0xFE
+ *)
+
+
+let	xk_ISO_Lock					= 0xFE01
+let	xk_ISO_Level2_Latch				= 0xFE02
+let	xk_ISO_Level3_Shift				= 0xFE03
+let	xk_ISO_Level3_Latch				= 0xFE04
+let	xk_ISO_Level3_Lock				= 0xFE05
+let	xk_ISO_Group_Shift		= 0xFF7E	(** Alias for mode_switch *)
+let	xk_ISO_Group_Latch				= 0xFE06
+let	xk_ISO_Group_Lock				= 0xFE07
+let	xk_ISO_Next_Group				= 0xFE08
+let	xk_ISO_Next_Group_Lock				= 0xFE09
+let	xk_ISO_Prev_Group				= 0xFE0A
+let	xk_ISO_Prev_Group_Lock				= 0xFE0B
+let	xk_ISO_First_Group				= 0xFE0C
+let	xk_ISO_First_Group_Lock				= 0xFE0D
+let	xk_ISO_Last_Group				= 0xFE0E
+let	xk_ISO_Last_Group_Lock				= 0xFE0F
+
+let	xk_ISO_Left_Tab					= 0xFE20
+let	xk_ISO_Move_Line_Up				= 0xFE21
+let	xk_ISO_Move_Line_Down				= 0xFE22
+let	xk_ISO_Partial_Line_Up				= 0xFE23
+let	xk_ISO_Partial_Line_Down			= 0xFE24
+let	xk_ISO_Partial_Space_Left			= 0xFE25
+let	xk_ISO_Partial_Space_Right			= 0xFE26
+let	xk_ISO_Set_Margin_Left				= 0xFE27
+let	xk_ISO_Set_Margin_Right				= 0xFE28
+let	xk_ISO_Release_Margin_Left			= 0xFE29
+let	xk_ISO_Release_Margin_Right			= 0xFE2A
+let	xk_ISO_Release_Both_Margins			= 0xFE2B
+let	xk_ISO_Fast_Cursor_Left				= 0xFE2C
+let	xk_ISO_Fast_Cursor_Right			= 0xFE2D
+let	xk_ISO_Fast_Cursor_Up				= 0xFE2E
+let	xk_ISO_Fast_Cursor_Down				= 0xFE2F
+let	xk_ISO_Continuous_Underline			= 0xFE30
+let	xk_ISO_Discontinuous_Underline			= 0xFE31
+let	xk_ISO_Emphasize				= 0xFE32
+let	xk_ISO_Center_Object				= 0xFE33
+let	xk_ISO_Enter					= 0xFE34
+
+let	xk_dead_grave					= 0xFE50
+let	xk_dead_acute					= 0xFE51
+let	xk_dead_circumflex				= 0xFE52
+let	xk_dead_tilde					= 0xFE53
+let	xk_dead_macron					= 0xFE54
+let	xk_dead_breve					= 0xFE55
+let	xk_dead_abovedot				= 0xFE56
+let	xk_dead_diaeresis				= 0xFE57
+let	xk_dead_abovering				= 0xFE58
+let	xk_dead_doubleacute				= 0xFE59
+let	xk_dead_caron					= 0xFE5A
+let	xk_dead_cedilla					= 0xFE5B
+let	xk_dead_ogonek					= 0xFE5C
+let	xk_dead_iota					= 0xFE5D
+let	xk_dead_voiced_sound				= 0xFE5E
+let	xk_dead_semivoiced_sound			= 0xFE5F
+let	xk_dead_belowdot				= 0xFE60
+
+let	xk_First_Virtual_Screen				= 0xFED0
+let	xk_Prev_Virtual_Screen				= 0xFED1
+let	xk_Next_Virtual_Screen				= 0xFED2
+let	xk_Last_Virtual_Screen				= 0xFED4
+let	xk_Terminate_Server				= 0xFED5
+
+let	xk_AccessX_Enable				= 0xFE70
+let	xk_AccessX_Feedback_Enable			= 0xFE71
+let	xk_RepeatKeys_Enable				= 0xFE72
+let	xk_SlowKeys_Enable				= 0xFE73
+let	xk_BounceKeys_Enable				= 0xFE74
+let	xk_StickyKeys_Enable				= 0xFE75
+let	xk_MouseKeys_Enable				= 0xFE76
+let	xk_MouseKeys_Accel_Enable			= 0xFE77
+let	xk_Overlay1_Enable				= 0xFE78
+let	xk_Overlay2_Enable				= 0xFE79
+let	xk_AudibleBell_Enable				= 0xFE7A
+
+let	xk_Pointer_Left					= 0xFEE0
+let	xk_Pointer_Right				= 0xFEE1
+let	xk_Pointer_Up					= 0xFEE2
+let	xk_Pointer_Down					= 0xFEE3
+let	xk_Pointer_UpLeft				= 0xFEE4
+let	xk_Pointer_UpRight				= 0xFEE5
+let	xk_Pointer_DownLeft				= 0xFEE6
+let	xk_Pointer_DownRight				= 0xFEE7
+let	xk_Pointer_Button_Dflt				= 0xFEE8
+let	xk_Pointer_Button1				= 0xFEE9
+let	xk_Pointer_Button2				= 0xFEEA
+let	xk_Pointer_Button3				= 0xFEEB
+let	xk_Pointer_Button4				= 0xFEEC
+let	xk_Pointer_Button5				= 0xFEED
+let	xk_Pointer_DblClick_Dflt			= 0xFEEE
+let	xk_Pointer_DblClick1				= 0xFEEF
+let	xk_Pointer_DblClick2				= 0xFEF0
+let	xk_Pointer_DblClick3				= 0xFEF1
+let	xk_Pointer_DblClick4				= 0xFEF2
+let	xk_Pointer_DblClick5				= 0xFEF3
+let	xk_Pointer_Drag_Dflt				= 0xFEF4
+let	xk_Pointer_Drag1				= 0xFEF5
+let	xk_Pointer_Drag2				= 0xFEF6
+let	xk_Pointer_Drag3				= 0xFEF7
+let	xk_Pointer_Drag4				= 0xFEF8
+let	xk_Pointer_Drag5				= 0xFEFD
+
+let	xk_Pointer_EnableKeys				= 0xFEF9
+let	xk_Pointer_Accelerate				= 0xFEFA
+let	xk_Pointer_DfltBtnNext				= 0xFEFB
+let	xk_Pointer_DfltBtnPrev				= 0xFEFC
+
+
+
+(*
+ * 3270 Terminal Keys
+ * Byte 3 = = 0xFD
+ *)
+
+
+let xk_3270_Duplicate      = 0xFD01
+let xk_3270_FieldMark      = 0xFD02
+let xk_3270_Right2         = 0xFD03
+let xk_3270_Left2          = 0xFD04
+let xk_3270_BackTab        = 0xFD05
+let xk_3270_EraseEOF       = 0xFD06
+let xk_3270_EraseInput     = 0xFD07
+let xk_3270_Reset          = 0xFD08
+let xk_3270_Quit           = 0xFD09
+let xk_3270_PA1            = 0xFD0A
+let xk_3270_PA2            = 0xFD0B
+let xk_3270_PA3            = 0xFD0C
+let xk_3270_Test           = 0xFD0D
+let xk_3270_Attn           = 0xFD0E
+let xk_3270_CursorBlink    = 0xFD0F
+let xk_3270_AltCursor      = 0xFD10
+let xk_3270_KeyClick       = 0xFD11
+let xk_3270_Jump           = 0xFD12
+let xk_3270_Ident          = 0xFD13
+let xk_3270_Rule           = 0xFD14
+let xk_3270_Copy           = 0xFD15
+let xk_3270_Play           = 0xFD16
+let xk_3270_Setup          = 0xFD17
+let xk_3270_Record         = 0xFD18
+let xk_3270_ChangeScreen   = 0xFD19
+let xk_3270_DeleteWord     = 0xFD1A
+let xk_3270_ExSelect       = 0xFD1B
+let xk_3270_CursorSelect   = 0xFD1C
+let xk_3270_PrintScreen    = 0xFD1D
+let xk_3270_Enter          = 0xFD1E
+
+
+(*
+ *  Latin 1
+ *  Byte 3 = 0
+ *)
+
+let xk_space               = 0x020
+let xk_exclam              = 0x021
+let xk_quotedbl            = 0x022
+let xk_numbersign          = 0x023
+let xk_dollar              = 0x024
+let xk_percent             = 0x025
+let xk_ampersand           = 0x026
+let xk_apostrophe          = 0x027
+let xk_quoteright          = 0x027	(** deprecated *)
+let xk_parenleft           = 0x028
+let xk_parenright          = 0x029
+let xk_asterisk            = 0x02a
+let xk_plus                = 0x02b
+let xk_comma               = 0x02c
+let xk_minus               = 0x02d
+let xk_period              = 0x02e
+let xk_slash               = 0x02f
+let xk_0                   = 0x030
+let xk_1                   = 0x031
+let xk_2                   = 0x032
+let xk_3                   = 0x033
+let xk_4                   = 0x034
+let xk_5                   = 0x035
+let xk_6                   = 0x036
+let xk_7                   = 0x037
+let xk_8                   = 0x038
+let xk_9                   = 0x039
+let xk_colon               = 0x03a
+let xk_semicolon           = 0x03b
+let xk_less                = 0x03c
+let xk_equal               = 0x03d
+let xk_greater             = 0x03e
+let xk_question            = 0x03f
+let xk_at                  = 0x040
+let xk_A                   = 0x041
+let xk_B                   = 0x042
+let xk_C                   = 0x043
+let xk_D                   = 0x044
+let xk_E                   = 0x045
+let xk_F                   = 0x046
+let xk_G                   = 0x047
+let xk_H                   = 0x048
+let xk_I                   = 0x049
+let xk_J                   = 0x04a
+let xk_K                   = 0x04b
+let xk_L                   = 0x04c
+let xk_M                   = 0x04d
+let xk_N                   = 0x04e
+let xk_O                   = 0x04f
+let xk_P                   = 0x050
+let xk_Q                   = 0x051
+let xk_R                   = 0x052
+let xk_S                   = 0x053
+let xk_T                   = 0x054
+let xk_U                   = 0x055
+let xk_V                   = 0x056
+let xk_W                   = 0x057
+let xk_X                   = 0x058
+let xk_Y                   = 0x059
+let xk_Z                   = 0x05a
+let xk_bracketleft         = 0x05b
+let xk_backslash           = 0x05c
+let xk_bracketright        = 0x05d
+let xk_asciicircum         = 0x05e
+let xk_underscore          = 0x05f
+let xk_grave               = 0x060
+let xk_quoteleft           = 0x060	(** deprecated *)
+let xk_a                   = 0x061
+let xk_b                   = 0x062
+let xk_c                   = 0x063
+let xk_d                   = 0x064
+let xk_e                   = 0x065
+let xk_f                   = 0x066
+let xk_g                   = 0x067
+let xk_h                   = 0x068
+let xk_i                   = 0x069
+let xk_j                   = 0x06a
+let xk_k                   = 0x06b
+let xk_l                   = 0x06c
+let xk_m                   = 0x06d
+let xk_n                   = 0x06e
+let xk_o                   = 0x06f
+let xk_p                   = 0x070
+let xk_q                   = 0x071
+let xk_r                   = 0x072
+let xk_s                   = 0x073
+let xk_t                   = 0x074
+let xk_u                   = 0x075
+let xk_v                   = 0x076
+let xk_w                   = 0x077
+let xk_x                   = 0x078
+let xk_y                   = 0x079
+let xk_z                   = 0x07a
+let xk_braceleft           = 0x07b
+let xk_bar                 = 0x07c
+let xk_braceright          = 0x07d
+let xk_asciitilde          = 0x07e
+
+let xk_nobreakspace        = 0x0a0
+let xk_exclamdown          = 0x0a1
+let xk_cent        	       = 0x0a2
+let xk_sterling            = 0x0a3
+let xk_currency            = 0x0a4
+let xk_yen                 = 0x0a5
+let xk_brokenbar           = 0x0a6
+let xk_section             = 0x0a7
+let xk_diaeresis           = 0x0a8
+let xk_copyright           = 0x0a9
+let xk_ordfeminine         = 0x0aa
+let xk_guillemotleft       = 0x0ab	(** left angle quotation mark *)
+let xk_notsign             = 0x0ac
+let xk_hyphen              = 0x0ad
+let xk_registered          = 0x0ae
+let xk_macron              = 0x0af
+let xk_degree              = 0x0b0
+let xk_plusminus           = 0x0b1
+let xk_twosuperior         = 0x0b2
+let xk_threesuperior       = 0x0b3
+let xk_acute               = 0x0b4
+let xk_mu                  = 0x0b5
+let xk_paragraph           = 0x0b6
+let xk_periodcentered      = 0x0b7
+let xk_cedilla             = 0x0b8
+let xk_onesuperior         = 0x0b9
+let xk_masculine           = 0x0ba
+let xk_guillemotright      = 0x0bb	(** right angle quotation mark *)
+let xk_onequarter          = 0x0bc
+let xk_onehalf             = 0x0bd
+let xk_threequarters       = 0x0be
+let xk_questiondown        = 0x0bf
+let xk_Agrave              = 0x0c0
+let xk_Aacute              = 0x0c1
+let xk_Acircumflex         = 0x0c2
+let xk_Atilde              = 0x0c3
+let xk_Adiaeresis          = 0x0c4
+let xk_Aring               = 0x0c5
+let xk_AE                  = 0x0c6
+let xk_Ccedilla            = 0x0c7
+let xk_Egrave              = 0x0c8
+let xk_Eacute              = 0x0c9
+let xk_Ecircumflex         = 0x0ca
+let xk_Ediaeresis          = 0x0cb
+let xk_Igrave              = 0x0cc
+let xk_Iacute              = 0x0cd
+let xk_Icircumflex         = 0x0ce
+let xk_Idiaeresis          = 0x0cf
+let xk_ETH                 = 0x0d0
+let xk_Eth                 = 0x0d0	(** deprecated *)
+let xk_Ntilde              = 0x0d1
+let xk_Ograve              = 0x0d2
+let xk_Oacute              = 0x0d3
+let xk_Ocircumflex         = 0x0d4
+let xk_Otilde              = 0x0d5
+let xk_Odiaeresis          = 0x0d6
+let xk_multiply            = 0x0d7
+let xk_Ooblique            = 0x0d8
+let xk_Ugrave              = 0x0d9
+let xk_Uacute              = 0x0da
+let xk_Ucircumflex         = 0x0db
+let xk_Udiaeresis          = 0x0dc
+let xk_Yacute              = 0x0dd
+let xk_THORN               = 0x0de
+let xk_Thorn               = 0x0de	(** deprecated *)
+let xk_ssharp              = 0x0df
+let xk_agrave              = 0x0e0
+let xk_aacute              = 0x0e1
+let xk_acircumflex         = 0x0e2
+let xk_atilde              = 0x0e3
+let xk_adiaeresis          = 0x0e4
+let xk_aring               = 0x0e5
+let xk_ae                  = 0x0e6
+let xk_ccedilla            = 0x0e7
+let xk_egrave              = 0x0e8
+let xk_eacute              = 0x0e9
+let xk_ecircumflex         = 0x0ea
+let xk_ediaeresis          = 0x0eb
+let xk_igrave              = 0x0ec
+let xk_iacute              = 0x0ed
+let xk_icircumflex         = 0x0ee
+let xk_idiaeresis          = 0x0ef
+let xk_eth                 = 0x0f0
+let xk_ntilde              = 0x0f1
+let xk_ograve              = 0x0f2
+let xk_oacute              = 0x0f3
+let xk_ocircumflex         = 0x0f4
+let xk_otilde              = 0x0f5
+let xk_odiaeresis          = 0x0f6
+let xk_division            = 0x0f7
+let xk_oslash              = 0x0f8
+let xk_ugrave              = 0x0f9
+let xk_uacute              = 0x0fa
+let xk_ucircumflex         = 0x0fb
+let xk_udiaeresis          = 0x0fc
+let xk_yacute              = 0x0fd
+let xk_thorn               = 0x0fe
+let xk_ydiaeresis          = 0x0ff
+
+
+(*
+ *   Latin 2
+ *   Byte 3 = 1
+ *)
+
+
+let xk_Aogonek             = 0x1a1
+let xk_breve               = 0x1a2
+let xk_Lstroke             = 0x1a3
+let xk_Lcaron              = 0x1a5
+let xk_Sacute              = 0x1a6
+let xk_Scaron              = 0x1a9
+let xk_Scedilla            = 0x1aa
+let xk_Tcaron              = 0x1ab
+let xk_Zacute              = 0x1ac
+let xk_Zcaron              = 0x1ae
+let xk_Zabovedot           = 0x1af
+let xk_aogonek             = 0x1b1
+let xk_ogonek              = 0x1b2
+let xk_lstroke             = 0x1b3
+let xk_lcaron              = 0x1b5
+let xk_sacute              = 0x1b6
+let xk_caron               = 0x1b7
+let xk_scaron              = 0x1b9
+let xk_scedilla            = 0x1ba
+let xk_tcaron              = 0x1bb
+let xk_zacute              = 0x1bc
+let xk_doubleacute         = 0x1bd
+let xk_zcaron              = 0x1be
+let xk_zabovedot           = 0x1bf
+let xk_Racute              = 0x1c0
+let xk_Abreve              = 0x1c3
+let xk_Lacute              = 0x1c5
+let xk_Cacute              = 0x1c6
+let xk_Ccaron              = 0x1c8
+let xk_Eogonek             = 0x1ca
+let xk_Ecaron              = 0x1cc
+let xk_Dcaron              = 0x1cf
+let xk_Dstroke             = 0x1d0
+let xk_Nacute              = 0x1d1
+let xk_Ncaron              = 0x1d2
+let xk_Odoubleacute        = 0x1d5
+let xk_Rcaron              = 0x1d8
+let xk_Uring               = 0x1d9
+let xk_Udoubleacute        = 0x1db
+let xk_Tcedilla            = 0x1de
+let xk_racute              = 0x1e0
+let xk_abreve              = 0x1e3
+let xk_lacute              = 0x1e5
+let xk_cacute              = 0x1e6
+let xk_ccaron              = 0x1e8
+let xk_eogonek             = 0x1ea
+let xk_ecaron              = 0x1ec
+let xk_dcaron              = 0x1ef
+let xk_dstroke             = 0x1f0
+let xk_nacute              = 0x1f1
+let xk_ncaron              = 0x1f2
+let xk_odoubleacute        = 0x1f5
+let xk_udoubleacute        = 0x1fb
+let xk_rcaron              = 0x1f8
+let xk_uring               = 0x1f9
+let xk_tcedilla            = 0x1fe
+let xk_abovedot            = 0x1ff
+
+
+(*
+ *   Latin 3
+ *   Byte 3 = 2
+ *)
+
+
+let xk_Hstroke             = 0x2a1
+let xk_Hcircumflex         = 0x2a6
+let xk_Iabovedot           = 0x2a9
+let xk_Gbreve              = 0x2ab
+let xk_Jcircumflex         = 0x2ac
+let xk_hstroke             = 0x2b1
+let xk_hcircumflex         = 0x2b6
+let xk_idotless            = 0x2b9
+let xk_gbreve              = 0x2bb
+let xk_jcircumflex         = 0x2bc
+let xk_Cabovedot           = 0x2c5
+let xk_Ccircumflex         = 0x2c6
+let xk_Gabovedot           = 0x2d5
+let xk_Gcircumflex         = 0x2d8
+let xk_Ubreve              = 0x2dd
+let xk_Scircumflex         = 0x2de
+let xk_cabovedot           = 0x2e5
+let xk_ccircumflex         = 0x2e6
+let xk_gabovedot           = 0x2f5
+let xk_gcircumflex         = 0x2f8
+let xk_ubreve              = 0x2fd
+let xk_scircumflex         = 0x2fe
+
+
+
+(*
+ *   Latin 4
+ *   Byte 3 = 3
+ *)
+
+
+let xk_kra                 = 0x3a2
+let xk_kappa               = 0x3a2	(** deprecated *)
+let xk_Rcedilla            = 0x3a3
+let xk_Itilde              = 0x3a5
+let xk_Lcedilla            = 0x3a6
+let xk_Emacron             = 0x3aa
+let xk_Gcedilla            = 0x3ab
+let xk_Tslash              = 0x3ac
+let xk_rcedilla            = 0x3b3
+let xk_itilde              = 0x3b5
+let xk_lcedilla            = 0x3b6
+let xk_emacron             = 0x3ba
+let xk_gcedilla            = 0x3bb
+let xk_tslash              = 0x3bc
+let xk_ENG                 = 0x3bd
+let xk_eng                 = 0x3bf
+let xk_Amacron             = 0x3c0
+let xk_Iogonek             = 0x3c7
+let xk_Eabovedot           = 0x3cc
+let xk_Imacron             = 0x3cf
+let xk_Ncedilla            = 0x3d1
+let xk_Omacron             = 0x3d2
+let xk_Kcedilla            = 0x3d3
+let xk_Uogonek             = 0x3d9
+let xk_Utilde              = 0x3dd
+let xk_Umacron             = 0x3de
+let xk_amacron             = 0x3e0
+let xk_iogonek             = 0x3e7
+let xk_eabovedot           = 0x3ec
+let xk_imacron             = 0x3ef
+let xk_ncedilla            = 0x3f1
+let xk_omacron             = 0x3f2
+let xk_kcedilla            = 0x3f3
+let xk_uogonek             = 0x3f9
+let xk_utilde              = 0x3fd
+let xk_umacron             = 0x3fe
+
+
+(*
+ * Katakana
+ * Byte 3 = 4
+ *)
+
+
+let xk_overline				       = 0x47e
+let xk_kana_fullstop                               = 0x4a1
+let xk_kana_openingbracket                         = 0x4a2
+let xk_kana_closingbracket                         = 0x4a3
+let xk_kana_comma                                  = 0x4a4
+let xk_kana_conjunctive                            = 0x4a5
+let xk_kana_middledot                              = 0x4a5  (** deprecated *)
+let xk_kana_WO                                     = 0x4a6
+let xk_kana_a                                      = 0x4a7
+let xk_kana_i                                      = 0x4a8
+let xk_kana_u                                      = 0x4a9
+let xk_kana_e                                      = 0x4aa
+let xk_kana_o                                      = 0x4ab
+let xk_kana_ya                                     = 0x4ac
+let xk_kana_yu                                     = 0x4ad
+let xk_kana_yo                                     = 0x4ae
+let xk_kana_tsu                                    = 0x4af
+let xk_kana_tu                                     = 0x4af  (** deprecated *)
+let xk_prolongedsound                              = 0x4b0
+let xk_kana_A                                      = 0x4b1
+let xk_kana_I                                      = 0x4b2
+let xk_kana_U                                      = 0x4b3
+let xk_kana_E                                      = 0x4b4
+let xk_kana_O                                      = 0x4b5
+let xk_kana_KA                                     = 0x4b6
+let xk_kana_KI                                     = 0x4b7
+let xk_kana_KU                                     = 0x4b8
+let xk_kana_KE                                     = 0x4b9
+let xk_kana_KO                                     = 0x4ba
+let xk_kana_SA                                     = 0x4bb
+let xk_kana_SHI                                    = 0x4bc
+let xk_kana_SU                                     = 0x4bd
+let xk_kana_SE                                     = 0x4be
+let xk_kana_SO                                     = 0x4bf
+let xk_kana_TA                                     = 0x4c0
+let xk_kana_CHI                                    = 0x4c1
+let xk_kana_TI                                     = 0x4c1  (** deprecated *)
+let xk_kana_TSU                                    = 0x4c2
+let xk_kana_TU                                     = 0x4c2  (** deprecated *)
+let xk_kana_TE                                     = 0x4c3
+let xk_kana_TO                                     = 0x4c4
+let xk_kana_NA                                     = 0x4c5
+let xk_kana_NI                                     = 0x4c6
+let xk_kana_NU                                     = 0x4c7
+let xk_kana_NE                                     = 0x4c8
+let xk_kana_NO                                     = 0x4c9
+let xk_kana_HA                                     = 0x4ca
+let xk_kana_HI                                     = 0x4cb
+let xk_kana_FU                                     = 0x4cc
+let xk_kana_HU                                     = 0x4cc  (** deprecated *)
+let xk_kana_HE                                     = 0x4cd
+let xk_kana_HO                                     = 0x4ce
+let xk_kana_MA                                     = 0x4cf
+let xk_kana_MI                                     = 0x4d0
+let xk_kana_MU                                     = 0x4d1
+let xk_kana_ME                                     = 0x4d2
+let xk_kana_MO                                     = 0x4d3
+let xk_kana_YA                                     = 0x4d4
+let xk_kana_YU                                     = 0x4d5
+let xk_kana_YO                                     = 0x4d6
+let xk_kana_RA                                     = 0x4d7
+let xk_kana_RI                                     = 0x4d8
+let xk_kana_RU                                     = 0x4d9
+let xk_kana_RE                                     = 0x4da
+let xk_kana_RO                                     = 0x4db
+let xk_kana_WA                                     = 0x4dc
+let xk_kana_N                                      = 0x4dd
+let xk_voicedsound                                 = 0x4de
+let xk_semivoicedsound                             = 0x4df
+let xk_kana_switch          = 0xFF7E  (** Alias for mode_switch *)
+
+
+(*
+ *  Arabic
+ *  Byte 3 = 5
+ *)
+
+
+let xk_Arabic_comma                                = 0x5ac
+let xk_Arabic_semicolon                            = 0x5bb
+let xk_Arabic_question_mark                        = 0x5bf
+let xk_Arabic_hamza                                = 0x5c1
+let xk_Arabic_maddaonalef                          = 0x5c2
+let xk_Arabic_hamzaonalef                          = 0x5c3
+let xk_Arabic_hamzaonwaw                           = 0x5c4
+let xk_Arabic_hamzaunderalef                       = 0x5c5
+let xk_Arabic_hamzaonyeh                           = 0x5c6
+let xk_Arabic_alef                                 = 0x5c7
+let xk_Arabic_beh                                  = 0x5c8
+let xk_Arabic_tehmarbuta                           = 0x5c9
+let xk_Arabic_teh                                  = 0x5ca
+let xk_Arabic_theh                                 = 0x5cb
+let xk_Arabic_jeem                                 = 0x5cc
+let xk_Arabic_hah                                  = 0x5cd
+let xk_Arabic_khah                                 = 0x5ce
+let xk_Arabic_dal                                  = 0x5cf
+let xk_Arabic_thal                                 = 0x5d0
+let xk_Arabic_ra                                   = 0x5d1
+let xk_Arabic_zain                                 = 0x5d2
+let xk_Arabic_seen                                 = 0x5d3
+let xk_Arabic_sheen                                = 0x5d4
+let xk_Arabic_sad                                  = 0x5d5
+let xk_Arabic_dad                                  = 0x5d6
+let xk_Arabic_tah                                  = 0x5d7
+let xk_Arabic_zah                                  = 0x5d8
+let xk_Arabic_ain                                  = 0x5d9
+let xk_Arabic_ghain                                = 0x5da
+let xk_Arabic_tatweel                              = 0x5e0
+let xk_Arabic_feh                                  = 0x5e1
+let xk_Arabic_qaf                                  = 0x5e2
+let xk_Arabic_kaf                                  = 0x5e3
+let xk_Arabic_lam                                  = 0x5e4
+let xk_Arabic_meem                                 = 0x5e5
+let xk_Arabic_noon                                 = 0x5e6
+let xk_Arabic_ha                                   = 0x5e7
+let xk_Arabic_heh                                  = 0x5e7  (** deprecated *)
+let xk_Arabic_waw                                  = 0x5e8
+let xk_Arabic_alefmaksura                          = 0x5e9
+let xk_Arabic_yeh                                  = 0x5ea
+let xk_Arabic_fathatan                             = 0x5eb
+let xk_Arabic_dammatan                             = 0x5ec
+let xk_Arabic_kasratan                             = 0x5ed
+let xk_Arabic_fatha                                = 0x5ee
+let xk_Arabic_damma                                = 0x5ef
+let xk_Arabic_kasra                                = 0x5f0
+let xk_Arabic_shadda                               = 0x5f1
+let xk_Arabic_sukun                                = 0x5f2
+let xk_Arabic_switch        = 0xFF7E  (** Alias for mode_switch *)
+
+
+(*
+ * Cyrillic
+ * Byte 3 = 6
+ *)
+
+let xk_Serbian_dje                                 = 0x6a1
+let xk_Macedonia_gje                               = 0x6a2
+let xk_Cyrillic_io                                 = 0x6a3
+let xk_Ukrainian_ie                                = 0x6a4
+let xk_Ukranian_je                                 = 0x6a4  (** deprecated *)
+let xk_Macedonia_dse                               = 0x6a5
+let xk_Ukrainian_i                                 = 0x6a6
+let xk_Ukranian_i                                  = 0x6a6  (** deprecated *)
+let xk_Ukrainian_yi                                = 0x6a7
+let xk_Ukranian_yi                                 = 0x6a7  (** deprecated *)
+let xk_Cyrillic_je                                 = 0x6a8
+let xk_Serbian_je                                  = 0x6a8  (** deprecated *)
+let xk_Cyrillic_lje                                = 0x6a9
+let xk_Serbian_lje                                 = 0x6a9  (** deprecated *)
+let xk_Cyrillic_nje                                = 0x6aa
+let xk_Serbian_nje                                 = 0x6aa  (** deprecated *)
+let xk_Serbian_tshe                                = 0x6ab
+let xk_Macedonia_kje                               = 0x6ac
+let xk_Byelorussian_shortu                         = 0x6ae
+let xk_Cyrillic_dzhe                               = 0x6af
+let xk_Serbian_dze                                 = 0x6af  (** deprecated *)
+let xk_numerosign                                  = 0x6b0
+let xk_Serbian_DJE                                 = 0x6b1
+let xk_Macedonia_GJE                               = 0x6b2
+let xk_Cyrillic_IO                                 = 0x6b3
+let xk_Ukrainian_IE                                = 0x6b4
+let xk_Ukranian_JE                                 = 0x6b4  (** deprecated *)
+let xk_Macedonia_DSE                               = 0x6b5
+let xk_Ukrainian_I                                 = 0x6b6
+let xk_Ukranian_I                                  = 0x6b6  (** deprecated *)
+let xk_Ukrainian_YI                                = 0x6b7
+let xk_Ukranian_YI                                 = 0x6b7  (** deprecated *)
+let xk_Cyrillic_JE                                 = 0x6b8
+let xk_Serbian_JE                                  = 0x6b8  (** deprecated *)
+let xk_Cyrillic_LJE                                = 0x6b9
+let xk_Serbian_LJE                                 = 0x6b9  (** deprecated *)
+let xk_Cyrillic_NJE                                = 0x6ba
+let xk_Serbian_NJE                                 = 0x6ba  (** deprecated *)
+let xk_Serbian_TSHE                                = 0x6bb
+let xk_Macedonia_KJE                               = 0x6bc
+let xk_Byelorussian_SHORTU                         = 0x6be
+let xk_Cyrillic_DZHE                               = 0x6bf
+let xk_Serbian_DZE                                 = 0x6bf  (** deprecated *)
+let xk_Cyrillic_yu                                 = 0x6c0
+let xk_Cyrillic_a                                  = 0x6c1
+let xk_Cyrillic_be                                 = 0x6c2
+let xk_Cyrillic_tse                                = 0x6c3
+let xk_Cyrillic_de                                 = 0x6c4
+let xk_Cyrillic_ie                                 = 0x6c5
+let xk_Cyrillic_ef                                 = 0x6c6
+let xk_Cyrillic_ghe                                = 0x6c7
+let xk_Cyrillic_ha                                 = 0x6c8
+let xk_Cyrillic_i                                  = 0x6c9
+let xk_Cyrillic_shorti                             = 0x6ca
+let xk_Cyrillic_ka                                 = 0x6cb
+let xk_Cyrillic_el                                 = 0x6cc
+let xk_Cyrillic_em                                 = 0x6cd
+let xk_Cyrillic_en                                 = 0x6ce
+let xk_Cyrillic_o                                  = 0x6cf
+let xk_Cyrillic_pe                                 = 0x6d0
+let xk_Cyrillic_ya                                 = 0x6d1
+let xk_Cyrillic_er                                 = 0x6d2
+let xk_Cyrillic_es                                 = 0x6d3
+let xk_Cyrillic_te                                 = 0x6d4
+let xk_Cyrillic_u                                  = 0x6d5
+let xk_Cyrillic_zhe                                = 0x6d6
+let xk_Cyrillic_ve                                 = 0x6d7
+let xk_Cyrillic_softsign                           = 0x6d8
+let xk_Cyrillic_yeru                               = 0x6d9
+let xk_Cyrillic_ze                                 = 0x6da
+let xk_Cyrillic_sha                                = 0x6db
+let xk_Cyrillic_e                                  = 0x6dc
+let xk_Cyrillic_shcha                              = 0x6dd
+let xk_Cyrillic_che                                = 0x6de
+let xk_Cyrillic_hardsign                           = 0x6df
+let xk_Cyrillic_YU                                 = 0x6e0
+let xk_Cyrillic_A                                  = 0x6e1
+let xk_Cyrillic_BE                                 = 0x6e2
+let xk_Cyrillic_TSE                                = 0x6e3
+let xk_Cyrillic_DE                                 = 0x6e4
+let xk_Cyrillic_IE                                 = 0x6e5
+let xk_Cyrillic_EF                                 = 0x6e6
+let xk_Cyrillic_GHE                                = 0x6e7
+let xk_Cyrillic_HA                                 = 0x6e8
+let xk_Cyrillic_I                                  = 0x6e9
+let xk_Cyrillic_SHORTI                             = 0x6ea
+let xk_Cyrillic_KA                                 = 0x6eb
+let xk_Cyrillic_EL                                 = 0x6ec
+let xk_Cyrillic_EM                                 = 0x6ed
+let xk_Cyrillic_EN                                 = 0x6ee
+let xk_Cyrillic_O                                  = 0x6ef
+let xk_Cyrillic_PE                                 = 0x6f0
+let xk_Cyrillic_YA                                 = 0x6f1
+let xk_Cyrillic_ER                                 = 0x6f2
+let xk_Cyrillic_ES                                 = 0x6f3
+let xk_Cyrillic_TE                                 = 0x6f4
+let xk_Cyrillic_U                                  = 0x6f5
+let xk_Cyrillic_ZHE                                = 0x6f6
+let xk_Cyrillic_VE                                 = 0x6f7
+let xk_Cyrillic_SOFTSIGN                           = 0x6f8
+let xk_Cyrillic_YERU                               = 0x6f9
+let xk_Cyrillic_ZE                                 = 0x6fa
+let xk_Cyrillic_SHA                                = 0x6fb
+let xk_Cyrillic_E                                  = 0x6fc
+let xk_Cyrillic_SHCHA                              = 0x6fd
+let xk_Cyrillic_CHE                                = 0x6fe
+let xk_Cyrillic_HARDSIGN                           = 0x6ff
+
+
+(*
+ * Greek
+ * Byte 3 = 7
+ *)
+
+
+let xk_Greek_ALPHAaccent                           = 0x7a1
+let xk_Greek_EPSILONaccent                         = 0x7a2
+let xk_Greek_ETAaccent                             = 0x7a3
+let xk_Greek_IOTAaccent                            = 0x7a4
+let xk_Greek_IOTAdiaeresis                         = 0x7a5
+let xk_Greek_OMICRONaccent                         = 0x7a7
+let xk_Greek_UPSILONaccent                         = 0x7a8
+let xk_Greek_UPSILONdieresis                       = 0x7a9
+let xk_Greek_OMEGAaccent                           = 0x7ab
+let xk_Greek_accentdieresis                        = 0x7ae
+let xk_Greek_horizbar                              = 0x7af
+let xk_Greek_alphaaccent                           = 0x7b1
+let xk_Greek_epsilonaccent                         = 0x7b2
+let xk_Greek_etaaccent                             = 0x7b3
+let xk_Greek_iotaaccent                            = 0x7b4
+let xk_Greek_iotadieresis                          = 0x7b5
+let xk_Greek_iotaaccentdieresis                    = 0x7b6
+let xk_Greek_omicronaccent                         = 0x7b7
+let xk_Greek_upsilonaccent                         = 0x7b8
+let xk_Greek_upsilondieresis                       = 0x7b9
+let xk_Greek_upsilonaccentdieresis                 = 0x7ba
+let xk_Greek_omegaaccent                           = 0x7bb
+let xk_Greek_ALPHA                                 = 0x7c1
+let xk_Greek_BETA                                  = 0x7c2
+let xk_Greek_GAMMA                                 = 0x7c3
+let xk_Greek_DELTA                                 = 0x7c4
+let xk_Greek_EPSILON                               = 0x7c5
+let xk_Greek_ZETA                                  = 0x7c6
+let xk_Greek_ETA                                   = 0x7c7
+let xk_Greek_THETA                                 = 0x7c8
+let xk_Greek_IOTA                                  = 0x7c9
+let xk_Greek_KAPPA                                 = 0x7ca
+let xk_Greek_LAMDA                                 = 0x7cb
+let xk_Greek_LAMBDA                                = 0x7cb
+let xk_Greek_MU                                    = 0x7cc
+let xk_Greek_NU                                    = 0x7cd
+let xk_Greek_XI                                    = 0x7ce
+let xk_Greek_OMICRON                               = 0x7cf
+let xk_Greek_PI                                    = 0x7d0
+let xk_Greek_RHO                                   = 0x7d1
+let xk_Greek_SIGMA                                 = 0x7d2
+let xk_Greek_TAU                                   = 0x7d4
+let xk_Greek_UPSILON                               = 0x7d5
+let xk_Greek_PHI                                   = 0x7d6
+let xk_Greek_CHI                                   = 0x7d7
+let xk_Greek_PSI                                   = 0x7d8
+let xk_Greek_OMEGA                                 = 0x7d9
+let xk_Greek_alpha                                 = 0x7e1
+let xk_Greek_beta                                  = 0x7e2
+let xk_Greek_gamma                                 = 0x7e3
+let xk_Greek_delta                                 = 0x7e4
+let xk_Greek_epsilon                               = 0x7e5
+let xk_Greek_zeta                                  = 0x7e6
+let xk_Greek_eta                                   = 0x7e7
+let xk_Greek_theta                                 = 0x7e8
+let xk_Greek_iota                                  = 0x7e9
+let xk_Greek_kappa                                 = 0x7ea
+let xk_Greek_lamda                                 = 0x7eb
+let xk_Greek_lambda                                = 0x7eb
+let xk_Greek_mu                                    = 0x7ec
+let xk_Greek_nu                                    = 0x7ed
+let xk_Greek_xi                                    = 0x7ee
+let xk_Greek_omicron                               = 0x7ef
+let xk_Greek_pi                                    = 0x7f0
+let xk_Greek_rho                                   = 0x7f1
+let xk_Greek_sigma                                 = 0x7f2
+let xk_Greek_finalsmallsigma                       = 0x7f3
+let xk_Greek_tau                                   = 0x7f4
+let xk_Greek_upsilon                               = 0x7f5
+let xk_Greek_phi                                   = 0x7f6
+let xk_Greek_chi                                   = 0x7f7
+let xk_Greek_psi                                   = 0x7f8
+let xk_Greek_omega                                 = 0x7f9
+let xk_Greek_switch         = 0xFF7E  (** Alias for mode_switch *)
+
+
+(*
+ * Technical
+ * Byte 3 = 8
+ *)
+
+
+let xk_leftradical                                 = 0x8a1
+let xk_topleftradical                              = 0x8a2
+let xk_horizconnector                              = 0x8a3
+let xk_topintegral                                 = 0x8a4
+let xk_botintegral                                 = 0x8a5
+let xk_vertconnector                               = 0x8a6
+let xk_topleftsqbracket                            = 0x8a7
+let xk_botleftsqbracket                            = 0x8a8
+let xk_toprightsqbracket                           = 0x8a9
+let xk_botrightsqbracket                           = 0x8aa
+let xk_topleftparens                               = 0x8ab
+let xk_botleftparens                               = 0x8ac
+let xk_toprightparens                              = 0x8ad
+let xk_botrightparens                              = 0x8ae
+let xk_leftmiddlecurlybrace                        = 0x8af
+let xk_rightmiddlecurlybrace                       = 0x8b0
+let xk_topleftsummation                            = 0x8b1
+let xk_botleftsummation                            = 0x8b2
+let xk_topvertsummationconnector                   = 0x8b3
+let xk_botvertsummationconnector                   = 0x8b4
+let xk_toprightsummation                           = 0x8b5
+let xk_botrightsummation                           = 0x8b6
+let xk_rightmiddlesummation                        = 0x8b7
+let xk_lessthanequal                               = 0x8bc
+let xk_notequal                                    = 0x8bd
+let xk_greaterthanequal                            = 0x8be
+let xk_integral                                    = 0x8bf
+let xk_therefore                                   = 0x8c0
+let xk_variation                                   = 0x8c1
+let xk_infinity                                    = 0x8c2
+let xk_nabla                                       = 0x8c5
+let xk_approximate                                 = 0x8c8
+let xk_similarequal                                = 0x8c9
+let xk_ifonlyif                                    = 0x8cd
+let xk_implies                                     = 0x8ce
+let xk_identical                                   = 0x8cf
+let xk_radical                                     = 0x8d6
+let xk_includedin                                  = 0x8da
+let xk_includes                                    = 0x8db
+let xk_intersection                                = 0x8dc
+let xk_union                                       = 0x8dd
+let xk_logicaland                                  = 0x8de
+let xk_logicalor                                   = 0x8df
+let xk_partialderivative                           = 0x8ef
+let xk_function                                    = 0x8f6
+let xk_leftarrow                                   = 0x8fb
+let xk_uparrow                                     = 0x8fc
+let xk_rightarrow                                  = 0x8fd
+let xk_downarrow                                   = 0x8fe
+
+
+(*
+ *  Special
+ *  Byte 3 = 9
+ *)
+
+
+let xk_blank                                       = 0x9df
+let xk_soliddiamond                                = 0x9e0
+let xk_checkerboard                                = 0x9e1
+let xk_ht                                          = 0x9e2
+let xk_ff                                          = 0x9e3
+let xk_cr                                          = 0x9e4
+let xk_lf                                          = 0x9e5
+let xk_nl                                          = 0x9e8
+let xk_vt                                          = 0x9e9
+let xk_lowrightcorner                              = 0x9ea
+let xk_uprightcorner                               = 0x9eb
+let xk_upleftcorner                                = 0x9ec
+let xk_lowleftcorner                               = 0x9ed
+let xk_crossinglines                               = 0x9ee
+let xk_horizlinescan1                              = 0x9ef
+let xk_horizlinescan3                              = 0x9f0
+let xk_horizlinescan5                              = 0x9f1
+let xk_horizlinescan7                              = 0x9f2
+let xk_horizlinescan9                              = 0x9f3
+let xk_leftt                                       = 0x9f4
+let xk_rightt                                      = 0x9f5
+let xk_bott                                        = 0x9f6
+let xk_topt                                        = 0x9f7
+let xk_vertbar                                     = 0x9f8
+
+
+(*
+ *  Publishing
+ *  Byte 3 = a
+ *)
+
+
+let xk_emspace                                     = 0xaa1
+let xk_enspace                                     = 0xaa2
+let xk_em3space                                    = 0xaa3
+let xk_em4space                                    = 0xaa4
+let xk_digitspace                                  = 0xaa5
+let xk_punctspace                                  = 0xaa6
+let xk_thinspace                                   = 0xaa7
+let xk_hairspace                                   = 0xaa8
+let xk_emdash                                      = 0xaa9
+let xk_endash                                      = 0xaaa
+let xk_signifblank                                 = 0xaac
+let xk_ellipsis                                    = 0xaae
+let xk_doubbaselinedot                             = 0xaaf
+let xk_onethird                                    = 0xab0
+let xk_twothirds                                   = 0xab1
+let xk_onefifth                                    = 0xab2
+let xk_twofifths                                   = 0xab3
+let xk_threefifths                                 = 0xab4
+let xk_fourfifths                                  = 0xab5
+let xk_onesixth                                    = 0xab6
+let xk_fivesixths                                  = 0xab7
+let xk_careof                                      = 0xab8
+let xk_figdash                                     = 0xabb
+let xk_leftanglebracket                            = 0xabc
+let xk_decimalpoint                                = 0xabd
+let xk_rightanglebracket                           = 0xabe
+let xk_marker                                      = 0xabf
+let xk_oneeighth                                   = 0xac3
+let xk_threeeighths                                = 0xac4
+let xk_fiveeighths                                 = 0xac5
+let xk_seveneighths                                = 0xac6
+let xk_trademark                                   = 0xac9
+let xk_signaturemark                               = 0xaca
+let xk_trademarkincircle                           = 0xacb
+let xk_leftopentriangle                            = 0xacc
+let xk_rightopentriangle                           = 0xacd
+let xk_emopencircle                                = 0xace
+let xk_emopenrectangle                             = 0xacf
+let xk_leftsinglequotemark                         = 0xad0
+let xk_rightsinglequotemark                        = 0xad1
+let xk_leftdoublequotemark                         = 0xad2
+let xk_rightdoublequotemark                        = 0xad3
+let xk_prescription                                = 0xad4
+let xk_minutes                                     = 0xad6
+let xk_seconds                                     = 0xad7
+let xk_latincross                                  = 0xad9
+let xk_hexagram                                    = 0xada
+let xk_filledrectbullet                            = 0xadb
+let xk_filledlefttribullet                         = 0xadc
+let xk_filledrighttribullet                        = 0xadd
+let xk_emfilledcircle                              = 0xade
+let xk_emfilledrect                                = 0xadf
+let xk_enopencircbullet                            = 0xae0
+let xk_enopensquarebullet                          = 0xae1
+let xk_openrectbullet                              = 0xae2
+let xk_opentribulletup                             = 0xae3
+let xk_opentribulletdown                           = 0xae4
+let xk_openstar                                    = 0xae5
+let xk_enfilledcircbullet                          = 0xae6
+let xk_enfilledsqbullet                            = 0xae7
+let xk_filledtribulletup                           = 0xae8
+let xk_filledtribulletdown                         = 0xae9
+let xk_leftpointer                                 = 0xaea
+let xk_rightpointer                                = 0xaeb
+let xk_club                                        = 0xaec
+let xk_diamond                                     = 0xaed
+let xk_heart                                       = 0xaee
+let xk_maltesecross                                = 0xaf0
+let xk_dagger                                      = 0xaf1
+let xk_doubledagger                                = 0xaf2
+let xk_checkmark                                   = 0xaf3
+let xk_ballotcross                                 = 0xaf4
+let xk_musicalsharp                                = 0xaf5
+let xk_musicalflat                                 = 0xaf6
+let xk_malesymbol                                  = 0xaf7
+let xk_femalesymbol                                = 0xaf8
+let xk_telephone                                   = 0xaf9
+let xk_telephonerecorder                           = 0xafa
+let xk_phonographcopyright                         = 0xafb
+let xk_caret                                       = 0xafc
+let xk_singlelowquotemark                          = 0xafd
+let xk_doublelowquotemark                          = 0xafe
+let xk_cursor                                      = 0xaff
+
+
+(*
+ *  APL
+ *  Byte 3 = b
+ *)
+
+
+let xk_leftcaret                                   = 0xba3
+let xk_rightcaret                                  = 0xba6
+let xk_downcaret                                   = 0xba8
+let xk_upcaret                                     = 0xba9
+let xk_overbar                                     = 0xbc0
+let xk_downtack                                    = 0xbc2
+let xk_upshoe                                      = 0xbc3
+let xk_downstile                                   = 0xbc4
+let xk_underbar                                    = 0xbc6
+let xk_jot                                         = 0xbca
+let xk_quad                                        = 0xbcc
+let xk_uptack                                      = 0xbce
+let xk_circle                                      = 0xbcf
+let xk_upstile                                     = 0xbd3
+let xk_downshoe                                    = 0xbd6
+let xk_rightshoe                                   = 0xbd8
+let xk_leftshoe                                    = 0xbda
+let xk_lefttack                                    = 0xbdc
+let xk_righttack                                   = 0xbfc
+
+
+(*
+ * Hebrew
+ * Byte 3 = c
+ *)
+
+
+let xk_hebrew_doublelowline                        = 0xcdf
+let xk_hebrew_aleph                                = 0xce0
+let xk_hebrew_bet                                  = 0xce1
+let xk_hebrew_beth                                 = 0xce1  (** deprecated *)
+let xk_hebrew_gimel                                = 0xce2
+let xk_hebrew_gimmel                               = 0xce2  (** deprecated *)
+let xk_hebrew_dalet                                = 0xce3
+let xk_hebrew_daleth                               = 0xce3  (** deprecated *)
+let xk_hebrew_he                                   = 0xce4
+let xk_hebrew_waw                                  = 0xce5
+let xk_hebrew_zain                                 = 0xce6
+let xk_hebrew_zayin                                = 0xce6  (** deprecated *)
+let xk_hebrew_chet                                 = 0xce7
+let xk_hebrew_het                                  = 0xce7  (** deprecated *)
+let xk_hebrew_tet                                  = 0xce8
+let xk_hebrew_teth                                 = 0xce8  (** deprecated *)
+let xk_hebrew_yod                                  = 0xce9
+let xk_hebrew_finalkaph                            = 0xcea
+let xk_hebrew_kaph                                 = 0xceb
+let xk_hebrew_lamed                                = 0xcec
+let xk_hebrew_finalmem                             = 0xced
+let xk_hebrew_mem                                  = 0xcee
+let xk_hebrew_finalnun                             = 0xcef
+let xk_hebrew_nun                                  = 0xcf0
+let xk_hebrew_samech                               = 0xcf1
+let xk_hebrew_samekh                               = 0xcf1  (** deprecated *)
+let xk_hebrew_ayin                                 = 0xcf2
+let xk_hebrew_finalpe                              = 0xcf3
+let xk_hebrew_pe                                   = 0xcf4
+let xk_hebrew_finalzade                            = 0xcf5
+let xk_hebrew_finalzadi                            = 0xcf5  (** deprecated *)
+let xk_hebrew_zade                                 = 0xcf6
+let xk_hebrew_zadi                                 = 0xcf6  (** deprecated *)
+let xk_hebrew_qoph                                 = 0xcf7
+let xk_hebrew_kuf                                  = 0xcf7  (** deprecated *)
+let xk_hebrew_resh                                 = 0xcf8
+let xk_hebrew_shin                                 = 0xcf9
+let xk_hebrew_taw                                  = 0xcfa
+let xk_hebrew_taf                                  = 0xcfa  (** deprecated *)
+let xk_Hebrew_switch        = 0xFF7E  (** Alias for mode_switch *)
+
+
+(*
+ * Thai
+ * Byte 3 = d
+ *)
+
+
+let xk_Thai_kokai					= 0xda1
+let xk_Thai_khokhai					= 0xda2
+let xk_Thai_khokhuat				= 0xda3
+let xk_Thai_khokhwai				= 0xda4
+let xk_Thai_khokhon					= 0xda5
+let xk_Thai_khorakhang			        = 0xda6  
+let xk_Thai_ngongu					= 0xda7  
+let xk_Thai_chochan					= 0xda8  
+let xk_Thai_choching				= 0xda9   
+let xk_Thai_chochang				= 0xdaa  
+let xk_Thai_soso					= 0xdab
+let xk_Thai_chochoe					= 0xdac
+let xk_Thai_yoying					= 0xdad
+let xk_Thai_dochada					= 0xdae
+let xk_Thai_topatak					= 0xdaf
+let xk_Thai_thothan					= 0xdb0
+let xk_Thai_thonangmontho			        = 0xdb1
+let xk_Thai_thophuthao			        = 0xdb2
+let xk_Thai_nonen					= 0xdb3
+let xk_Thai_dodek					= 0xdb4
+let xk_Thai_totao					= 0xdb5
+let xk_Thai_thothung				= 0xdb6
+let xk_Thai_thothahan				= 0xdb7
+let xk_Thai_thothong	 			= 0xdb8
+let xk_Thai_nonu					= 0xdb9
+let xk_Thai_bobaimai				= 0xdba
+let xk_Thai_popla					= 0xdbb
+let xk_Thai_phophung				= 0xdbc
+let xk_Thai_fofa					= 0xdbd
+let xk_Thai_phophan					= 0xdbe
+let xk_Thai_fofan					= 0xdbf
+let xk_Thai_phosamphao			        = 0xdc0
+let xk_Thai_moma					= 0xdc1
+let xk_Thai_yoyak					= 0xdc2
+let xk_Thai_rorua					= 0xdc3
+let xk_Thai_ru					= 0xdc4
+let xk_Thai_loling					= 0xdc5
+let xk_Thai_lu					= 0xdc6
+let xk_Thai_wowaen					= 0xdc7
+let xk_Thai_sosala					= 0xdc8
+let xk_Thai_sorusi					= 0xdc9
+let xk_Thai_sosua					= 0xdca
+let xk_Thai_hohip					= 0xdcb
+let xk_Thai_lochula					= 0xdcc
+let xk_Thai_oang					= 0xdcd
+let xk_Thai_honokhuk				= 0xdce
+let xk_Thai_paiyannoi				= 0xdcf
+let xk_Thai_saraa					= 0xdd0
+let xk_Thai_maihanakat				= 0xdd1
+let xk_Thai_saraaa					= 0xdd2
+let xk_Thai_saraam					= 0xdd3
+let xk_Thai_sarai					= 0xdd4   
+let xk_Thai_saraii					= 0xdd5   
+let xk_Thai_saraue					= 0xdd6    
+let xk_Thai_sarauee					= 0xdd7    
+let xk_Thai_sarau					= 0xdd8    
+let xk_Thai_sarauu					= 0xdd9   
+let xk_Thai_phinthu					= 0xdda
+let xk_Thai_maihanakat_maitho   			= 0xdde
+let xk_Thai_baht					= 0xddf
+let xk_Thai_sarae					= 0xde0    
+let xk_Thai_saraae					= 0xde1
+let xk_Thai_sarao					= 0xde2
+let xk_Thai_saraaimaimuan				= 0xde3   
+let xk_Thai_saraaimaimalai				= 0xde4  
+let xk_Thai_lakkhangyao				= 0xde5
+let xk_Thai_maiyamok				= 0xde6
+let xk_Thai_maitaikhu				= 0xde7
+let xk_Thai_maiek					= 0xde8   
+let xk_Thai_maitho					= 0xde9
+let xk_Thai_maitri					= 0xdea
+let xk_Thai_maichattawa				= 0xdeb
+let xk_Thai_thanthakhat				= 0xdec
+let xk_Thai_nikhahit				= 0xded
+let xk_Thai_leksun					= 0xdf0 
+let xk_Thai_leknung					= 0xdf1  
+let xk_Thai_leksong					= 0xdf2 
+let xk_Thai_leksam					= 0xdf3
+let xk_Thai_leksi					= 0xdf4  
+let xk_Thai_lekha					= 0xdf5  
+let xk_Thai_lekhok					= 0xdf6  
+let xk_Thai_lekchet					= 0xdf7  
+let xk_Thai_lekpaet					= 0xdf8  
+let xk_Thai_lekkao					= 0xdf9 
+
+
+(*
+ *   Korean
+ *   Byte 3 = e
+ *)
+
+
+
+let xk_Hangul		= 0xff31    (** Hangul start/stop(toggle) *)
+let xk_Hangul_Start		= 0xff32    (** Hangul start *)
+let xk_Hangul_End		= 0xff33    (** Hangul end, English start *)
+let xk_Hangul_Hanja		= 0xff34    (** Start Hangul->Hanja Conversion *)
+let xk_Hangul_Jamo		= 0xff35    (** Hangul Jamo mode *)
+let xk_Hangul_Romaja	= 0xff36    (** Hangul Romaja mode *)
+let xk_Hangul_Codeinput	= 0xff37    (** Hangul code input mode *)
+let xk_Hangul_Jeonja	= 0xff38    (** Jeonja mode *)
+let xk_Hangul_Banja		= 0xff39    (** Banja mode *)
+let xk_Hangul_PreHanja	= 0xff3a    (** Pre Hanja conversion *)
+let xk_Hangul_PostHanja	= 0xff3b    (** Post Hanja conversion *)
+let xk_Hangul_SingleCandidate	= 0xff3c    (** Single candidate *)
+let xk_Hangul_MultipleCandidate	= 0xff3d    (** Multiple candidate *)
+let xk_Hangul_PreviousCandidate	= 0xff3e    (** Previous candidate *)
+let xk_Hangul_Special	= 0xff3f    (** Special symbols *)
+let xk_Hangul_switch	= 0xFF7E    (** Alias for mode_switch *)
+
+(** Hangul Consonant Characters *)
+let xk_Hangul_Kiyeog				= 0xea1
+let xk_Hangul_SsangKiyeog				= 0xea2
+let xk_Hangul_KiyeogSios				= 0xea3
+let xk_Hangul_Nieun					= 0xea4
+let xk_Hangul_NieunJieuj				= 0xea5
+let xk_Hangul_NieunHieuh				= 0xea6
+let xk_Hangul_Dikeud				= 0xea7
+let xk_Hangul_SsangDikeud				= 0xea8
+let xk_Hangul_Rieul					= 0xea9
+let xk_Hangul_RieulKiyeog				= 0xeaa
+let xk_Hangul_RieulMieum				= 0xeab
+let xk_Hangul_RieulPieub				= 0xeac
+let xk_Hangul_RieulSios				= 0xead
+let xk_Hangul_RieulTieut				= 0xeae
+let xk_Hangul_RieulPhieuf				= 0xeaf
+let xk_Hangul_RieulHieuh				= 0xeb0
+let xk_Hangul_Mieum					= 0xeb1
+let xk_Hangul_Pieub					= 0xeb2
+let xk_Hangul_SsangPieub				= 0xeb3
+let xk_Hangul_PieubSios				= 0xeb4
+let xk_Hangul_Sios					= 0xeb5
+let xk_Hangul_SsangSios				= 0xeb6
+let xk_Hangul_Ieung					= 0xeb7
+let xk_Hangul_Jieuj					= 0xeb8
+let xk_Hangul_SsangJieuj				= 0xeb9
+let xk_Hangul_Cieuc					= 0xeba
+let xk_Hangul_Khieuq				= 0xebb
+let xk_Hangul_Tieut					= 0xebc
+let xk_Hangul_Phieuf				= 0xebd
+let xk_Hangul_Hieuh					= 0xebe
+
+(** Hangul Vowel Characters *)
+let xk_Hangul_A					= 0xebf
+let xk_Hangul_AE					= 0xec0
+let xk_Hangul_YA					= 0xec1
+let xk_Hangul_YAE					= 0xec2
+let xk_Hangul_EO					= 0xec3
+let xk_Hangul_E					= 0xec4
+let xk_Hangul_YEO					= 0xec5
+let xk_Hangul_YE					= 0xec6
+let xk_Hangul_O					= 0xec7
+let xk_Hangul_WA					= 0xec8
+let xk_Hangul_WAE					= 0xec9
+let xk_Hangul_OE					= 0xeca
+let xk_Hangul_YO					= 0xecb
+let xk_Hangul_U					= 0xecc
+let xk_Hangul_WEO					= 0xecd
+let xk_Hangul_WE					= 0xece
+let xk_Hangul_WI					= 0xecf
+let xk_Hangul_YU					= 0xed0
+let xk_Hangul_EU					= 0xed1
+let xk_Hangul_YI					= 0xed2
+let xk_Hangul_I					= 0xed3
+
+(** Hangul syllable-final (JongSeong) Characters *)
+let xk_Hangul_J_Kiyeog				= 0xed4
+let xk_Hangul_J_SsangKiyeog				= 0xed5
+let xk_Hangul_J_KiyeogSios				= 0xed6
+let xk_Hangul_J_Nieun				= 0xed7
+let xk_Hangul_J_NieunJieuj				= 0xed8
+let xk_Hangul_J_NieunHieuh				= 0xed9
+let xk_Hangul_J_Dikeud				= 0xeda
+let xk_Hangul_J_Rieul				= 0xedb
+let xk_Hangul_J_RieulKiyeog				= 0xedc
+let xk_Hangul_J_RieulMieum				= 0xedd
+let xk_Hangul_J_RieulPieub				= 0xede
+let xk_Hangul_J_RieulSios				= 0xedf
+let xk_Hangul_J_RieulTieut				= 0xee0
+let xk_Hangul_J_RieulPhieuf				= 0xee1
+let xk_Hangul_J_RieulHieuh				= 0xee2
+let xk_Hangul_J_Mieum				= 0xee3
+let xk_Hangul_J_Pieub				= 0xee4
+let xk_Hangul_J_PieubSios				= 0xee5
+let xk_Hangul_J_Sios				= 0xee6
+let xk_Hangul_J_SsangSios				= 0xee7
+let xk_Hangul_J_Ieung				= 0xee8
+let xk_Hangul_J_Jieuj				= 0xee9
+let xk_Hangul_J_Cieuc				= 0xeea
+let xk_Hangul_J_Khieuq				= 0xeeb
+let xk_Hangul_J_Tieut				= 0xeec
+let xk_Hangul_J_Phieuf				= 0xeed
+let xk_Hangul_J_Hieuh				= 0xeee
+
+(** Ancient Hangul Consonant Characters *)
+let xk_Hangul_RieulYeorinHieuh			= 0xeef
+let xk_Hangul_SunkyeongeumMieum			= 0xef0
+let xk_Hangul_SunkyeongeumPieub			= 0xef1
+let xk_Hangul_PanSios				= 0xef2
+let xk_Hangul_KkogjiDalrinIeung			= 0xef3
+let xk_Hangul_SunkyeongeumPhieuf			= 0xef4
+let xk_Hangul_YeorinHieuh				= 0xef5
+
+(** Ancient Hangul Vowel Characters *)
+let xk_Hangul_AraeA					= 0xef6
+let xk_Hangul_AraeAE				= 0xef7
+
+(** Ancient Hangul syllable-final (JongSeong) Characters *)
+let xk_Hangul_J_PanSios				= 0xef8
+let xk_Hangul_J_KkogjiDalrinIeung			= 0xef9
+let xk_Hangul_J_YeorinHieuh				= 0xefa
+
+(** Korean currency symbol *)
+let xk_Korean_Won					= 0xeff
+
+
+
+let name_to_keysym = [
+"VoidSymbol",0xFFFFFF;
+"BackSpace",0xFF08;
+"Tab",0xFF09;
+"Linefeed",0xFF0A;
+"Clear",0xFF0B;
+"Return",0xFF0D;
+"Pause",0xFF13;
+"Scroll_Lock",0xFF14;
+"Sys_Req",0xFF15;
+"Escape",0xFF1B;
+"Delete",0xFFFF;
+"Multi_key",0xFF20;
+"Kanji",0xFF21;
+"Muhenkan",0xFF22;
+"Henkan_Mode",0xFF23;
+"Henkan",0xFF23;
+"Romaji",0xFF24;
+"Hiragana",0xFF25;
+"Katakana",0xFF26;
+"Hiragana_Katakana",0xFF27;
+"Zenkaku",0xFF28;
+"Hankaku",0xFF29;
+"Zenkaku_Hankaku",0xFF2A;
+"Touroku",0xFF2B;
+"Massyo",0xFF2C;
+"Kana_Lock",0xFF2D;
+"Kana_Shift",0xFF2E;
+"Eisu_Shift",0xFF2F;
+"Eisu_toggle",0xFF30;
+"Home",0xFF50;
+"Left",0xFF51;
+"Up",0xFF52;
+"Right",0xFF53;
+"Down",0xFF54;
+"Prior",0xFF55;
+"Page_Up",0xFF55;
+"Next",0xFF56;
+"Page_Down",0xFF56;
+"End",0xFF57;
+"Begin",0xFF58;
+"Select",0xFF60;
+"Print",0xFF61;
+"Execute",0xFF62;
+"Insert",0xFF63;
+"Undo",0xFF65;
+"Redo",0xFF66;
+"Menu",0xFF67;
+"Find",0xFF68;
+"Cancel",0xFF69;
+"Help",0xFF6A;
+"Break",0xFF6B;
+"Mode_switch",0xFF7E;
+"script_switch",0xFF7E;
+"Num_Lock",0xFF7F;
+"KP_Space",0xFF80;
+"KP_Tab",0xFF89;
+"KP_Enter",0xFF8D;
+"KP_F1",0xFF91;
+"KP_F2",0xFF92;
+"KP_F3",0xFF93;
+"KP_F4",0xFF94;
+"KP_Home",0xFF95;
+"KP_Left",0xFF96;
+"KP_Up",0xFF97;
+"KP_Right",0xFF98;
+"KP_Down",0xFF99;
+"KP_Prior",0xFF9A;
+"KP_Page_Up",0xFF9A;
+"KP_Next",0xFF9B;
+"KP_Page_Down",0xFF9B;
+"KP_End",0xFF9C;
+"KP_Begin",0xFF9D;
+"KP_Insert",0xFF9E;
+"KP_Delete",0xFF9F;
+"KP_Equal",0xFFBD;
+"KP_Multiply",0xFFAA;
+"KP_Add",0xFFAB;
+"KP_Separator",0xFFAC;
+"KP_Subtract",0xFFAD;
+"KP_Decimal",0xFFAE;
+"KP_Divide",0xFFAF;
+"KP_0",0xFFB0;
+"KP_1",0xFFB1;
+"KP_2",0xFFB2;
+"KP_3",0xFFB3;
+"KP_4",0xFFB4;
+"KP_5",0xFFB5;
+"KP_6",0xFFB6;
+"KP_7",0xFFB7;
+"KP_8",0xFFB8;
+"KP_9",0xFFB9;
+"F1",0xFFBE;
+"F2",0xFFBF;
+"F3",0xFFC0;
+"F4",0xFFC1;
+"F5",0xFFC2;
+"F6",0xFFC3;
+"F7",0xFFC4;
+"F8",0xFFC5;
+"F9",0xFFC6;
+"F10",0xFFC7;
+"F11",0xFFC8;
+"L1",0xFFC8;
+"F12",0xFFC9;
+"L2",0xFFC9;
+"F13",0xFFCA;
+"L3",0xFFCA;
+"F14",0xFFCB;
+"L4",0xFFCB;
+"F15",0xFFCC;
+"L5",0xFFCC;
+"F16",0xFFCD;
+"L6",0xFFCD;
+"F17",0xFFCE;
+"L7",0xFFCE;
+"F18",0xFFCF;
+"L8",0xFFCF;
+"F19",0xFFD0;
+"L9",0xFFD0;
+"F20",0xFFD1;
+"L10",0xFFD1;
+"F21",0xFFD2;
+"R1",0xFFD2;
+"F22",0xFFD3;
+"R2",0xFFD3;
+"F23",0xFFD4;
+"R3",0xFFD4;
+"F24",0xFFD5;
+"R4",0xFFD5;
+"F25",0xFFD6;
+"R5",0xFFD6;
+"F26",0xFFD7;
+"R6",0xFFD7;
+"F27",0xFFD8;
+"R7",0xFFD8;
+"F28",0xFFD9;
+"R8",0xFFD9;
+"F29",0xFFDA;
+"R9",0xFFDA;
+"F30",0xFFDB;
+"R10",0xFFDB;
+"F31",0xFFDC;
+"R11",0xFFDC;
+"F32",0xFFDD;
+"R12",0xFFDD;
+"F33",0xFFDE;
+"R13",0xFFDE;
+"F34",0xFFDF;
+"R14",0xFFDF;
+"F35",0xFFE0;
+"R15",0xFFE0;
+"Shift_L",0xFFE1;
+"Shift_R",0xFFE2;
+"Control_L",0xFFE3;
+"Control_R",0xFFE4;
+"Caps_Lock",0xFFE5;
+"Shift_Lock",0xFFE6;
+"Meta_L",0xFFE7;
+"Meta_R",0xFFE8;
+"Alt_L",0xFFE9;
+"Alt_R",0xFFEA;
+"Super_L",0xFFEB;
+"Super_R",0xFFEC;
+"Hyper_L",0xFFED;
+"Hyper_R",0xFFEE;
+"ISO_Lock",0xFE01;
+"ISO_Level2_Latch",0xFE02;
+"ISO_Level3_Shift",0xFE03;
+"ISO_Level3_Latch",0xFE04;
+"ISO_Level3_Lock",0xFE05;
+"ISO_Group_Shift",0xFF7E;
+"ISO_Group_Latch",0xFE06;
+"ISO_Group_Lock",0xFE07;
+"ISO_Next_Group",0xFE08;
+"ISO_Next_Group_Lock",0xFE09;
+"ISO_Prev_Group",0xFE0A;
+"ISO_Prev_Group_Lock",0xFE0B;
+"ISO_First_Group",0xFE0C;
+"ISO_First_Group_Lock",0xFE0D;
+"ISO_Last_Group",0xFE0E;
+"ISO_Last_Group_Lock",0xFE0F;
+"ISO_Left_Tab",0xFE20;
+"ISO_Move_Line_Up",0xFE21;
+"ISO_Move_Line_Down",0xFE22;
+"ISO_Partial_Line_Up",0xFE23;
+"ISO_Partial_Line_Down",0xFE24;
+"ISO_Partial_Space_Left",0xFE25;
+"ISO_Partial_Space_Right",0xFE26;
+"ISO_Set_Margin_Left",0xFE27;
+"ISO_Set_Margin_Right",0xFE28;
+"ISO_Release_Margin_Left",0xFE29;
+"ISO_Release_Margin_Right",0xFE2A;
+"ISO_Release_Both_Margins",0xFE2B;
+"ISO_Fast_Cursor_Left",0xFE2C;
+"ISO_Fast_Cursor_Right",0xFE2D;
+"ISO_Fast_Cursor_Up",0xFE2E;
+"ISO_Fast_Cursor_Down",0xFE2F;
+"ISO_Continuous_Underline",0xFE30;
+"ISO_Discontinuous_Underline",0xFE31;
+"ISO_Emphasize",0xFE32;
+"ISO_Center_Object",0xFE33;
+"ISO_Enter",0xFE34;
+"dead_grave",0xFE50;
+"dead_acute",0xFE51;
+"dead_circumflex",0xFE52;
+"dead_tilde",0xFE53;
+"dead_macron",0xFE54;
+"dead_breve",0xFE55;
+"dead_abovedot",0xFE56;
+"dead_diaeresis",0xFE57;
+"dead_abovering",0xFE58;
+"dead_doubleacute",0xFE59;
+"dead_caron",0xFE5A;
+"dead_cedilla",0xFE5B;
+"dead_ogonek",0xFE5C;
+"dead_iota",0xFE5D;
+"dead_voiced_sound",0xFE5E;
+"dead_semivoiced_sound",0xFE5F;
+"dead_belowdot",0xFE60;
+"First_Virtual_Screen",0xFED0;
+"Prev_Virtual_Screen",0xFED1;
+"Next_Virtual_Screen",0xFED2;
+"Last_Virtual_Screen",0xFED4;
+"Terminate_Server",0xFED5;
+"AccessX_Enable",0xFE70;
+"AccessX_Feedback_Enable",0xFE71;
+"RepeatKeys_Enable",0xFE72;
+"SlowKeys_Enable",0xFE73;
+"BounceKeys_Enable",0xFE74;
+"StickyKeys_Enable",0xFE75;
+"MouseKeys_Enable",0xFE76;
+"MouseKeys_Accel_Enable",0xFE77;
+"Overlay1_Enable",0xFE78;
+"Overlay2_Enable",0xFE79;
+"AudibleBell_Enable",0xFE7A;
+"Pointer_Left",0xFEE0;
+"Pointer_Right",0xFEE1;
+"Pointer_Up",0xFEE2;
+"Pointer_Down",0xFEE3;
+"Pointer_UpLeft",0xFEE4;
+"Pointer_UpRight",0xFEE5;
+"Pointer_DownLeft",0xFEE6;
+"Pointer_DownRight",0xFEE7;
+"Pointer_Button_Dflt",0xFEE8;
+"Pointer_Button1",0xFEE9;
+"Pointer_Button2",0xFEEA;
+"Pointer_Button3",0xFEEB;
+"Pointer_Button4",0xFEEC;
+"Pointer_Button5",0xFEED;
+"Pointer_DblClick_Dflt",0xFEEE;
+"Pointer_DblClick1",0xFEEF;
+"Pointer_DblClick2",0xFEF0;
+"Pointer_DblClick3",0xFEF1;
+"Pointer_DblClick4",0xFEF2;
+"Pointer_DblClick5",0xFEF3;
+"Pointer_Drag_Dflt",0xFEF4;
+"Pointer_Drag1",0xFEF5;
+"Pointer_Drag2",0xFEF6;
+"Pointer_Drag3",0xFEF7;
+"Pointer_Drag4",0xFEF8;
+"Pointer_Drag5",0xFEFD;
+"Pointer_EnableKeys",0xFEF9;
+"Pointer_Accelerate",0xFEFA;
+"Pointer_DfltBtnNext",0xFEFB;
+"Pointer_DfltBtnPrev",0xFEFC;
+"3270_Duplicate",0xFD01;
+"3270_FieldMark",0xFD02;
+"3270_Right2",0xFD03;
+"3270_Left2",0xFD04;
+"3270_BackTab",0xFD05;
+"3270_EraseEOF",0xFD06;
+"3270_EraseInput",0xFD07;
+"3270_Reset",0xFD08;
+"3270_Quit",0xFD09;
+"3270_PA1",0xFD0A;
+"3270_PA2",0xFD0B;
+"3270_PA3",0xFD0C;
+"3270_Test",0xFD0D;
+"3270_Attn",0xFD0E;
+"3270_CursorBlink",0xFD0F;
+"3270_AltCursor",0xFD10;
+"3270_KeyClick",0xFD11;
+"3270_Jump",0xFD12;
+"3270_Ident",0xFD13;
+"3270_Rule",0xFD14;
+"3270_Copy",0xFD15;
+"3270_Play",0xFD16;
+"3270_Setup",0xFD17;
+"3270_Record",0xFD18;
+"3270_ChangeScreen",0xFD19;
+"3270_DeleteWord",0xFD1A;
+"3270_ExSelect",0xFD1B;
+"3270_CursorSelect",0xFD1C;
+"3270_PrintScreen",0xFD1D;
+"3270_Enter",0xFD1E;
+"space",0x020;
+"exclam",0x021;
+"quotedbl",0x022;
+"numbersign",0x023;
+"dollar",0x024;
+"percent",0x025;
+"ampersand",0x026;
+"apostrophe",0x027;
+"quoteright",0x027;
+"parenleft",0x028;
+"parenright",0x029;
+"asterisk",0x02a;
+"plus",0x02b;
+"comma",0x02c;
+"minus",0x02d;
+"period",0x02e;
+"slash",0x02f;
+"0",0x030;
+"1",0x031;
+"2",0x032;
+"3",0x033;
+"4",0x034;
+"5",0x035;
+"6",0x036;
+"7",0x037;
+"8",0x038;
+"9",0x039;
+"colon",0x03a;
+"semicolon",0x03b;
+"less",0x03c;
+"equal",0x03d;
+"greater",0x03e;
+"question",0x03f;
+"at",0x040;
+"A",0x041;
+"B",0x042;
+"C",0x043;
+"D",0x044;
+"E",0x045;
+"F",0x046;
+"G",0x047;
+"H",0x048;
+"I",0x049;
+"J",0x04a;
+"K",0x04b;
+"L",0x04c;
+"M",0x04d;
+"N",0x04e;
+"O",0x04f;
+"P",0x050;
+"Q",0x051;
+"R",0x052;
+"S",0x053;
+"T",0x054;
+"U",0x055;
+"V",0x056;
+"W",0x057;
+"X",0x058;
+"Y",0x059;
+"Z",0x05a;
+"bracketleft",0x05b;
+"backslash",0x05c;
+"bracketright",0x05d;
+"asciicircum",0x05e;
+"underscore",0x05f;
+"grave",0x060;
+"quoteleft",0x060;
+"a",0x061;
+"b",0x062;
+"c",0x063;
+"d",0x064;
+"e",0x065;
+"f",0x066;
+"g",0x067;
+"h",0x068;
+"i",0x069;
+"j",0x06a;
+"k",0x06b;
+"l",0x06c;
+"m",0x06d;
+"n",0x06e;
+"o",0x06f;
+"p",0x070;
+"q",0x071;
+"r",0x072;
+"s",0x073;
+"t",0x074;
+"u",0x075;
+"v",0x076;
+"w",0x077;
+"x",0x078;
+"y",0x079;
+"z",0x07a;
+"braceleft",0x07b;
+"bar",0x07c;
+"braceright",0x07d;
+"asciitilde",0x07e;
+"nobreakspace",0x0a0;
+"exclamdown",0x0a1;
+"cent",0x0a2;
+"sterling",0x0a3;
+"currency",0x0a4;
+"yen",0x0a5;
+"brokenbar",0x0a6;
+"section",0x0a7;
+"diaeresis",0x0a8;
+"copyright",0x0a9;
+"ordfeminine",0x0aa;
+"guillemotleft",0x0ab;
+"notsign",0x0ac;
+"hyphen",0x0ad;
+"registered",0x0ae;
+"macron",0x0af;
+"degree",0x0b0;
+"plusminus",0x0b1;
+"twosuperior",0x0b2;
+"threesuperior",0x0b3;
+"acute",0x0b4;
+"mu",0x0b5;
+"paragraph",0x0b6;
+"periodcentered",0x0b7;
+"cedilla",0x0b8;
+"onesuperior",0x0b9;
+"masculine",0x0ba;
+"guillemotright",0x0bb;
+"onequarter",0x0bc;
+"onehalf",0x0bd;
+"threequarters",0x0be;
+"questiondown",0x0bf;
+"Agrave",0x0c0;
+"Aacute",0x0c1;
+"Acircumflex",0x0c2;
+"Atilde",0x0c3;
+"Adiaeresis",0x0c4;
+"Aring",0x0c5;
+"AE",0x0c6;
+"Ccedilla",0x0c7;
+"Egrave",0x0c8;
+"Eacute",0x0c9;
+"Ecircumflex",0x0ca;
+"Ediaeresis",0x0cb;
+"Igrave",0x0cc;
+"Iacute",0x0cd;
+"Icircumflex",0x0ce;
+"Idiaeresis",0x0cf;
+"ETH",0x0d0;
+"Eth",0x0d0;
+"Ntilde",0x0d1;
+"Ograve",0x0d2;
+"Oacute",0x0d3;
+"Ocircumflex",0x0d4;
+"Otilde",0x0d5;
+"Odiaeresis",0x0d6;
+"multiply",0x0d7;
+"Ooblique",0x0d8;
+"Ugrave",0x0d9;
+"Uacute",0x0da;
+"Ucircumflex",0x0db;
+"Udiaeresis",0x0dc;
+"Yacute",0x0dd;
+"THORN",0x0de;
+"Thorn",0x0de;
+"ssharp",0x0df;
+"agrave",0x0e0;
+"aacute",0x0e1;
+"acircumflex",0x0e2;
+"atilde",0x0e3;
+"adiaeresis",0x0e4;
+"aring",0x0e5;
+"ae",0x0e6;
+"ccedilla",0x0e7;
+"egrave",0x0e8;
+"eacute",0x0e9;
+"ecircumflex",0x0ea;
+"ediaeresis",0x0eb;
+"igrave",0x0ec;
+"iacute",0x0ed;
+"icircumflex",0x0ee;
+"idiaeresis",0x0ef;
+"eth",0x0f0;
+"ntilde",0x0f1;
+"ograve",0x0f2;
+"oacute",0x0f3;
+"ocircumflex",0x0f4;
+"otilde",0x0f5;
+"odiaeresis",0x0f6;
+"division",0x0f7;
+"oslash",0x0f8;
+"ugrave",0x0f9;
+"uacute",0x0fa;
+"ucircumflex",0x0fb;
+"udiaeresis",0x0fc;
+"yacute",0x0fd;
+"thorn",0x0fe;
+"ydiaeresis",0x0ff;
+"Aogonek",0x1a1;
+"breve",0x1a2;
+"Lstroke",0x1a3;
+"Lcaron",0x1a5;
+"Sacute",0x1a6;
+"Scaron",0x1a9;
+"Scedilla",0x1aa;
+"Tcaron",0x1ab;
+"Zacute",0x1ac;
+"Zcaron",0x1ae;
+"Zabovedot",0x1af;
+"aogonek",0x1b1;
+"ogonek",0x1b2;
+"lstroke",0x1b3;
+"lcaron",0x1b5;
+"sacute",0x1b6;
+"caron",0x1b7;
+"scaron",0x1b9;
+"scedilla",0x1ba;
+"tcaron",0x1bb;
+"zacute",0x1bc;
+"doubleacute",0x1bd;
+"zcaron",0x1be;
+"zabovedot",0x1bf;
+"Racute",0x1c0;
+"Abreve",0x1c3;
+"Lacute",0x1c5;
+"Cacute",0x1c6;
+"Ccaron",0x1c8;
+"Eogonek",0x1ca;
+"Ecaron",0x1cc;
+"Dcaron",0x1cf;
+"Dstroke",0x1d0;
+"Nacute",0x1d1;
+"Ncaron",0x1d2;
+"Odoubleacute",0x1d5;
+"Rcaron",0x1d8;
+"Uring",0x1d9;
+"Udoubleacute",0x1db;
+"Tcedilla",0x1de;
+"racute",0x1e0;
+"abreve",0x1e3;
+"lacute",0x1e5;
+"cacute",0x1e6;
+"ccaron",0x1e8;
+"eogonek",0x1ea;
+"ecaron",0x1ec;
+"dcaron",0x1ef;
+"dstroke",0x1f0;
+"nacute",0x1f1;
+"ncaron",0x1f2;
+"odoubleacute",0x1f5;
+"udoubleacute",0x1fb;
+"rcaron",0x1f8;
+"uring",0x1f9;
+"tcedilla",0x1fe;
+"abovedot",0x1ff;
+"Hstroke",0x2a1;
+"Hcircumflex",0x2a6;
+"Iabovedot",0x2a9;
+"Gbreve",0x2ab;
+"Jcircumflex",0x2ac;
+"hstroke",0x2b1;
+"hcircumflex",0x2b6;
+"idotless",0x2b9;
+"gbreve",0x2bb;
+"jcircumflex",0x2bc;
+"Cabovedot",0x2c5;
+"Ccircumflex",0x2c6;
+"Gabovedot",0x2d5;
+"Gcircumflex",0x2d8;
+"Ubreve",0x2dd;
+"Scircumflex",0x2de;
+"cabovedot",0x2e5;
+"ccircumflex",0x2e6;
+"gabovedot",0x2f5;
+"gcircumflex",0x2f8;
+"ubreve",0x2fd;
+"scircumflex",0x2fe;
+"kra",0x3a2;
+"kappa",0x3a2;
+"Rcedilla",0x3a3;
+"Itilde",0x3a5;
+"Lcedilla",0x3a6;
+"Emacron",0x3aa;
+"Gcedilla",0x3ab;
+"Tslash",0x3ac;
+"rcedilla",0x3b3;
+"itilde",0x3b5;
+"lcedilla",0x3b6;
+"emacron",0x3ba;
+"gcedilla",0x3bb;
+"tslash",0x3bc;
+"ENG",0x3bd;
+"eng",0x3bf;
+"Amacron",0x3c0;
+"Iogonek",0x3c7;
+"Eabovedot",0x3cc;
+"Imacron",0x3cf;
+"Ncedilla",0x3d1;
+"Omacron",0x3d2;
+"Kcedilla",0x3d3;
+"Uogonek",0x3d9;
+"Utilde",0x3dd;
+"Umacron",0x3de;
+"amacron",0x3e0;
+"iogonek",0x3e7;
+"eabovedot",0x3ec;
+"imacron",0x3ef;
+"ncedilla",0x3f1;
+"omacron",0x3f2;
+"kcedilla",0x3f3;
+"uogonek",0x3f9;
+"utilde",0x3fd;
+"umacron",0x3fe;
+"overline",0x47e;
+"kana_fullstop",0x4a1;
+"kana_openingbracket",0x4a2;
+"kana_closingbracket",0x4a3;
+"kana_comma",0x4a4;
+"kana_conjunctive",0x4a5;
+"kana_middledot",0x4a5;
+"kana_WO",0x4a6;
+"kana_a",0x4a7;
+"kana_i",0x4a8;
+"kana_u",0x4a9;
+"kana_e",0x4aa;
+"kana_o",0x4ab;
+"kana_ya",0x4ac;
+"kana_yu",0x4ad;
+"kana_yo",0x4ae;
+"kana_tsu",0x4af;
+"kana_tu",0x4af;
+"prolongedsound",0x4b0;
+"kana_A",0x4b1;
+"kana_I",0x4b2;
+"kana_U",0x4b3;
+"kana_E",0x4b4;
+"kana_O",0x4b5;
+"kana_KA",0x4b6;
+"kana_KI",0x4b7;
+"kana_KU",0x4b8;
+"kana_KE",0x4b9;
+"kana_KO",0x4ba;
+"kana_SA",0x4bb;
+"kana_SHI",0x4bc;
+"kana_SU",0x4bd;
+"kana_SE",0x4be;
+"kana_SO",0x4bf;
+"kana_TA",0x4c0;
+"kana_CHI",0x4c1;
+"kana_TI",0x4c1;
+"kana_TSU",0x4c2;
+"kana_TU",0x4c2;
+"kana_TE",0x4c3;
+"kana_TO",0x4c4;
+"kana_NA",0x4c5;
+"kana_NI",0x4c6;
+"kana_NU",0x4c7;
+"kana_NE",0x4c8;
+"kana_NO",0x4c9;
+"kana_HA",0x4ca;
+"kana_HI",0x4cb;
+"kana_FU",0x4cc;
+"kana_HU",0x4cc;
+"kana_HE",0x4cd;
+"kana_HO",0x4ce;
+"kana_MA",0x4cf;
+"kana_MI",0x4d0;
+"kana_MU",0x4d1;
+"kana_ME",0x4d2;
+"kana_MO",0x4d3;
+"kana_YA",0x4d4;
+"kana_YU",0x4d5;
+"kana_YO",0x4d6;
+"kana_RA",0x4d7;
+"kana_RI",0x4d8;
+"kana_RU",0x4d9;
+"kana_RE",0x4da;
+"kana_RO",0x4db;
+"kana_WA",0x4dc;
+"kana_N",0x4dd;
+"voicedsound",0x4de;
+"semivoicedsound",0x4df;
+"kana_switch",0xFF7E;
+"Arabic_comma",0x5ac;
+"Arabic_semicolon",0x5bb;
+"Arabic_question_mark",0x5bf;
+"Arabic_hamza",0x5c1;
+"Arabic_maddaonalef",0x5c2;
+"Arabic_hamzaonalef",0x5c3;
+"Arabic_hamzaonwaw",0x5c4;
+"Arabic_hamzaunderalef",0x5c5;
+"Arabic_hamzaonyeh",0x5c6;
+"Arabic_alef",0x5c7;
+"Arabic_beh",0x5c8;
+"Arabic_tehmarbuta",0x5c9;
+"Arabic_teh",0x5ca;
+"Arabic_theh",0x5cb;
+"Arabic_jeem",0x5cc;
+"Arabic_hah",0x5cd;
+"Arabic_khah",0x5ce;
+"Arabic_dal",0x5cf;
+"Arabic_thal",0x5d0;
+"Arabic_ra",0x5d1;
+"Arabic_zain",0x5d2;
+"Arabic_seen",0x5d3;
+"Arabic_sheen",0x5d4;
+"Arabic_sad",0x5d5;
+"Arabic_dad",0x5d6;
+"Arabic_tah",0x5d7;
+"Arabic_zah",0x5d8;
+"Arabic_ain",0x5d9;
+"Arabic_ghain",0x5da;
+"Arabic_tatweel",0x5e0;
+"Arabic_feh",0x5e1;
+"Arabic_qaf",0x5e2;
+"Arabic_kaf",0x5e3;
+"Arabic_lam",0x5e4;
+"Arabic_meem",0x5e5;
+"Arabic_noon",0x5e6;
+"Arabic_ha",0x5e7;
+"Arabic_heh",0x5e7;
+"Arabic_waw",0x5e8;
+"Arabic_alefmaksura",0x5e9;
+"Arabic_yeh",0x5ea;
+"Arabic_fathatan",0x5eb;
+"Arabic_dammatan",0x5ec;
+"Arabic_kasratan",0x5ed;
+"Arabic_fatha",0x5ee;
+"Arabic_damma",0x5ef;
+"Arabic_kasra",0x5f0;
+"Arabic_shadda",0x5f1;
+"Arabic_sukun",0x5f2;
+"Arabic_switch",0xFF7E;
+"Serbian_dje",0x6a1;
+"Macedonia_gje",0x6a2;
+"Cyrillic_io",0x6a3;
+"Ukrainian_ie",0x6a4;
+"Ukranian_je",0x6a4;
+"Macedonia_dse",0x6a5;
+"Ukrainian_i",0x6a6;
+"Ukranian_i",0x6a6;
+"Ukrainian_yi",0x6a7;
+"Ukranian_yi",0x6a7;
+"Cyrillic_je",0x6a8;
+"Serbian_je",0x6a8;
+"Cyrillic_lje",0x6a9;
+"Serbian_lje",0x6a9;
+"Cyrillic_nje",0x6aa;
+"Serbian_nje",0x6aa;
+"Serbian_tshe",0x6ab;
+"Macedonia_kje",0x6ac;
+"Byelorussian_shortu",0x6ae;
+"Cyrillic_dzhe",0x6af;
+"Serbian_dze",0x6af;
+"numerosign",0x6b0;
+"Serbian_DJE",0x6b1;
+"Macedonia_GJE",0x6b2;
+"Cyrillic_IO",0x6b3;
+"Ukrainian_IE",0x6b4;
+"Ukranian_JE",0x6b4;
+"Macedonia_DSE",0x6b5;
+"Ukrainian_I",0x6b6;
+"Ukranian_I",0x6b6;
+"Ukrainian_YI",0x6b7;
+"Ukranian_YI",0x6b7;
+"Cyrillic_JE",0x6b8;
+"Serbian_JE",0x6b8;
+"Cyrillic_LJE",0x6b9;
+"Serbian_LJE",0x6b9;
+"Cyrillic_NJE",0x6ba;
+"Serbian_NJE",0x6ba;
+"Serbian_TSHE",0x6bb;
+"Macedonia_KJE",0x6bc;
+"Byelorussian_SHORTU",0x6be;
+"Cyrillic_DZHE",0x6bf;
+"Serbian_DZE",0x6bf;
+"Cyrillic_yu",0x6c0;
+"Cyrillic_a",0x6c1;
+"Cyrillic_be",0x6c2;
+"Cyrillic_tse",0x6c3;
+"Cyrillic_de",0x6c4;
+"Cyrillic_ie",0x6c5;
+"Cyrillic_ef",0x6c6;
+"Cyrillic_ghe",0x6c7;
+"Cyrillic_ha",0x6c8;
+"Cyrillic_i",0x6c9;
+"Cyrillic_shorti",0x6ca;
+"Cyrillic_ka",0x6cb;
+"Cyrillic_el",0x6cc;
+"Cyrillic_em",0x6cd;
+"Cyrillic_en",0x6ce;
+"Cyrillic_o",0x6cf;
+"Cyrillic_pe",0x6d0;
+"Cyrillic_ya",0x6d1;
+"Cyrillic_er",0x6d2;
+"Cyrillic_es",0x6d3;
+"Cyrillic_te",0x6d4;
+"Cyrillic_u",0x6d5;
+"Cyrillic_zhe",0x6d6;
+"Cyrillic_ve",0x6d7;
+"Cyrillic_softsign",0x6d8;
+"Cyrillic_yeru",0x6d9;
+"Cyrillic_ze",0x6da;
+"Cyrillic_sha",0x6db;
+"Cyrillic_e",0x6dc;
+"Cyrillic_shcha",0x6dd;
+"Cyrillic_che",0x6de;
+"Cyrillic_hardsign",0x6df;
+"Cyrillic_YU",0x6e0;
+"Cyrillic_A",0x6e1;
+"Cyrillic_BE",0x6e2;
+"Cyrillic_TSE",0x6e3;
+"Cyrillic_DE",0x6e4;
+"Cyrillic_IE",0x6e5;
+"Cyrillic_EF",0x6e6;
+"Cyrillic_GHE",0x6e7;
+"Cyrillic_HA",0x6e8;
+"Cyrillic_I",0x6e9;
+"Cyrillic_SHORTI",0x6ea;
+"Cyrillic_KA",0x6eb;
+"Cyrillic_EL",0x6ec;
+"Cyrillic_EM",0x6ed;
+"Cyrillic_EN",0x6ee;
+"Cyrillic_O",0x6ef;
+"Cyrillic_PE",0x6f0;
+"Cyrillic_YA",0x6f1;
+"Cyrillic_ER",0x6f2;
+"Cyrillic_ES",0x6f3;
+"Cyrillic_TE",0x6f4;
+"Cyrillic_U",0x6f5;
+"Cyrillic_ZHE",0x6f6;
+"Cyrillic_VE",0x6f7;
+"Cyrillic_SOFTSIGN",0x6f8;
+"Cyrillic_YERU",0x6f9;
+"Cyrillic_ZE",0x6fa;
+"Cyrillic_SHA",0x6fb;
+"Cyrillic_E",0x6fc;
+"Cyrillic_SHCHA",0x6fd;
+"Cyrillic_CHE",0x6fe;
+"Cyrillic_HARDSIGN",0x6ff;
+"Greek_ALPHAaccent",0x7a1;
+"Greek_EPSILONaccent",0x7a2;
+"Greek_ETAaccent",0x7a3;
+"Greek_IOTAaccent",0x7a4;
+"Greek_IOTAdiaeresis",0x7a5;
+"Greek_OMICRONaccent",0x7a7;
+"Greek_UPSILONaccent",0x7a8;
+"Greek_UPSILONdieresis",0x7a9;
+"Greek_OMEGAaccent",0x7ab;
+"Greek_accentdieresis",0x7ae;
+"Greek_horizbar",0x7af;
+"Greek_alphaaccent",0x7b1;
+"Greek_epsilonaccent",0x7b2;
+"Greek_etaaccent",0x7b3;
+"Greek_iotaaccent",0x7b4;
+"Greek_iotadieresis",0x7b5;
+"Greek_iotaaccentdieresis",0x7b6;
+"Greek_omicronaccent",0x7b7;
+"Greek_upsilonaccent",0x7b8;
+"Greek_upsilondieresis",0x7b9;
+"Greek_upsilonaccentdieresis",0x7ba;
+"Greek_omegaaccent",0x7bb;
+"Greek_ALPHA",0x7c1;
+"Greek_BETA",0x7c2;
+"Greek_GAMMA",0x7c3;
+"Greek_DELTA",0x7c4;
+"Greek_EPSILON",0x7c5;
+"Greek_ZETA",0x7c6;
+"Greek_ETA",0x7c7;
+"Greek_THETA",0x7c8;
+"Greek_IOTA",0x7c9;
+"Greek_KAPPA",0x7ca;
+"Greek_LAMDA",0x7cb;
+"Greek_LAMBDA",0x7cb;
+"Greek_MU",0x7cc;
+"Greek_NU",0x7cd;
+"Greek_XI",0x7ce;
+"Greek_OMICRON",0x7cf;
+"Greek_PI",0x7d0;
+"Greek_RHO",0x7d1;
+"Greek_SIGMA",0x7d2;
+"Greek_TAU",0x7d4;
+"Greek_UPSILON",0x7d5;
+"Greek_PHI",0x7d6;
+"Greek_CHI",0x7d7;
+"Greek_PSI",0x7d8;
+"Greek_OMEGA",0x7d9;
+"Greek_alpha",0x7e1;
+"Greek_beta",0x7e2;
+"Greek_gamma",0x7e3;
+"Greek_delta",0x7e4;
+"Greek_epsilon",0x7e5;
+"Greek_zeta",0x7e6;
+"Greek_eta",0x7e7;
+"Greek_theta",0x7e8;
+"Greek_iota",0x7e9;
+"Greek_kappa",0x7ea;
+"Greek_lamda",0x7eb;
+"Greek_lambda",0x7eb;
+"Greek_mu",0x7ec;
+"Greek_nu",0x7ed;
+"Greek_xi",0x7ee;
+"Greek_omicron",0x7ef;
+"Greek_pi",0x7f0;
+"Greek_rho",0x7f1;
+"Greek_sigma",0x7f2;
+"Greek_finalsmallsigma",0x7f3;
+"Greek_tau",0x7f4;
+"Greek_upsilon",0x7f5;
+"Greek_phi",0x7f6;
+"Greek_chi",0x7f7;
+"Greek_psi",0x7f8;
+"Greek_omega",0x7f9;
+"Greek_switch",0xFF7E;
+"leftradical",0x8a1;
+"topleftradical",0x8a2;
+"horizconnector",0x8a3;
+"topintegral",0x8a4;
+"botintegral",0x8a5;
+"vertconnector",0x8a6;
+"topleftsqbracket",0x8a7;
+"botleftsqbracket",0x8a8;
+"toprightsqbracket",0x8a9;
+"botrightsqbracket",0x8aa;
+"topleftparens",0x8ab;
+"botleftparens",0x8ac;
+"toprightparens",0x8ad;
+"botrightparens",0x8ae;
+"leftmiddlecurlybrace",0x8af;
+"rightmiddlecurlybrace",0x8b0;
+"topleftsummation",0x8b1;
+"botleftsummation",0x8b2;
+"topvertsummationconnector",0x8b3;
+"botvertsummationconnector",0x8b4;
+"toprightsummation",0x8b5;
+"botrightsummation",0x8b6;
+"rightmiddlesummation",0x8b7;
+"lessthanequal",0x8bc;
+"notequal",0x8bd;
+"greaterthanequal",0x8be;
+"integral",0x8bf;
+"therefore",0x8c0;
+"variation",0x8c1;
+"infinity",0x8c2;
+"nabla",0x8c5;
+"approximate",0x8c8;
+"similarequal",0x8c9;
+"ifonlyif",0x8cd;
+"implies",0x8ce;
+"identical",0x8cf;
+"radical",0x8d6;
+"includedin",0x8da;
+"includes",0x8db;
+"intersection",0x8dc;
+"union",0x8dd;
+"logicaland",0x8de;
+"logicalor",0x8df;
+"partialderivative",0x8ef;
+"function",0x8f6;
+"leftarrow",0x8fb;
+"uparrow",0x8fc;
+"rightarrow",0x8fd;
+"downarrow",0x8fe;
+"blank",0x9df;
+"soliddiamond",0x9e0;
+"checkerboard",0x9e1;
+"ht",0x9e2;
+"ff",0x9e3;
+"cr",0x9e4;
+"lf",0x9e5;
+"nl",0x9e8;
+"vt",0x9e9;
+"lowrightcorner",0x9ea;
+"uprightcorner",0x9eb;
+"upleftcorner",0x9ec;
+"lowleftcorner",0x9ed;
+"crossinglines",0x9ee;
+"horizlinescan1",0x9ef;
+"horizlinescan3",0x9f0;
+"horizlinescan5",0x9f1;
+"horizlinescan7",0x9f2;
+"horizlinescan9",0x9f3;
+"leftt",0x9f4;
+"rightt",0x9f5;
+"bott",0x9f6;
+"topt",0x9f7;
+"vertbar",0x9f8;
+"emspace",0xaa1;
+"enspace",0xaa2;
+"em3space",0xaa3;
+"em4space",0xaa4;
+"digitspace",0xaa5;
+"punctspace",0xaa6;
+"thinspace",0xaa7;
+"hairspace",0xaa8;
+"emdash",0xaa9;
+"endash",0xaaa;
+"signifblank",0xaac;
+"ellipsis",0xaae;
+"doubbaselinedot",0xaaf;
+"onethird",0xab0;
+"twothirds",0xab1;
+"onefifth",0xab2;
+"twofifths",0xab3;
+"threefifths",0xab4;
+"fourfifths",0xab5;
+"onesixth",0xab6;
+"fivesixths",0xab7;
+"careof",0xab8;
+"figdash",0xabb;
+"leftanglebracket",0xabc;
+"decimalpoint",0xabd;
+"rightanglebracket",0xabe;
+"marker",0xabf;
+"oneeighth",0xac3;
+"threeeighths",0xac4;
+"fiveeighths",0xac5;
+"seveneighths",0xac6;
+"trademark",0xac9;
+"signaturemark",0xaca;
+"trademarkincircle",0xacb;
+"leftopentriangle",0xacc;
+"rightopentriangle",0xacd;
+"emopencircle",0xace;
+"emopenrectangle",0xacf;
+"leftsinglequotemark",0xad0;
+"rightsinglequotemark",0xad1;
+"leftdoublequotemark",0xad2;
+"rightdoublequotemark",0xad3;
+"prescription",0xad4;
+"minutes",0xad6;
+"seconds",0xad7;
+"latincross",0xad9;
+"hexagram",0xada;
+"filledrectbullet",0xadb;
+"filledlefttribullet",0xadc;
+"filledrighttribullet",0xadd;
+"emfilledcircle",0xade;
+"emfilledrect",0xadf;
+"enopencircbullet",0xae0;
+"enopensquarebullet",0xae1;
+"openrectbullet",0xae2;
+"opentribulletup",0xae3;
+"opentribulletdown",0xae4;
+"openstar",0xae5;
+"enfilledcircbullet",0xae6;
+"enfilledsqbullet",0xae7;
+"filledtribulletup",0xae8;
+"filledtribulletdown",0xae9;
+"leftpointer",0xaea;
+"rightpointer",0xaeb;
+"club",0xaec;
+"diamond",0xaed;
+"heart",0xaee;
+"maltesecross",0xaf0;
+"dagger",0xaf1;
+"doubledagger",0xaf2;
+"checkmark",0xaf3;
+"ballotcross",0xaf4;
+"musicalsharp",0xaf5;
+"musicalflat",0xaf6;
+"malesymbol",0xaf7;
+"femalesymbol",0xaf8;
+"telephone",0xaf9;
+"telephonerecorder",0xafa;
+"phonographcopyright",0xafb;
+"caret",0xafc;
+"singlelowquotemark",0xafd;
+"doublelowquotemark",0xafe;
+"cursor",0xaff;
+"leftcaret",0xba3;
+"rightcaret",0xba6;
+"downcaret",0xba8;
+"upcaret",0xba9;
+"overbar",0xbc0;
+"downtack",0xbc2;
+"upshoe",0xbc3;
+"downstile",0xbc4;
+"underbar",0xbc6;
+"jot",0xbca;
+"quad",0xbcc;
+"uptack",0xbce;
+"circle",0xbcf;
+"upstile",0xbd3;
+"downshoe",0xbd6;
+"rightshoe",0xbd8;
+"leftshoe",0xbda;
+"lefttack",0xbdc;
+"righttack",0xbfc;
+"hebrew_doublelowline",0xcdf;
+"hebrew_aleph",0xce0;
+"hebrew_bet",0xce1;
+"hebrew_beth",0xce1;
+"hebrew_gimel",0xce2;
+"hebrew_gimmel",0xce2;
+"hebrew_dalet",0xce3;
+"hebrew_daleth",0xce3;
+"hebrew_he",0xce4;
+"hebrew_waw",0xce5;
+"hebrew_zain",0xce6;
+"hebrew_zayin",0xce6;
+"hebrew_chet",0xce7;
+"hebrew_het",0xce7;
+"hebrew_tet",0xce8;
+"hebrew_teth",0xce8;
+"hebrew_yod",0xce9;
+"hebrew_finalkaph",0xcea;
+"hebrew_kaph",0xceb;
+"hebrew_lamed",0xcec;
+"hebrew_finalmem",0xced;
+"hebrew_mem",0xcee;
+"hebrew_finalnun",0xcef;
+"hebrew_nun",0xcf0;
+"hebrew_samech",0xcf1;
+"hebrew_samekh",0xcf1;
+"hebrew_ayin",0xcf2;
+"hebrew_finalpe",0xcf3;
+"hebrew_pe",0xcf4;
+"hebrew_finalzade",0xcf5;
+"hebrew_finalzadi",0xcf5;
+"hebrew_zade",0xcf6;
+"hebrew_zadi",0xcf6;
+"hebrew_qoph",0xcf7;
+"hebrew_kuf",0xcf7;
+"hebrew_resh",0xcf8;
+"hebrew_shin",0xcf9;
+"hebrew_taw",0xcfa;
+"hebrew_taf",0xcfa;
+"Hebrew_switch",0xFF7E;
+"Thai_kokai",0xda1;
+"Thai_khokhai",0xda2;
+"Thai_khokhuat",0xda3;
+"Thai_khokhwai",0xda4;
+"Thai_khokhon",0xda5;
+"Thai_khorakhang",0xda6;
+"Thai_ngongu",0xda7;
+"Thai_chochan",0xda8;
+"Thai_choching",0xda9;
+"Thai_chochang",0xdaa;
+"Thai_soso",0xdab;
+"Thai_chochoe",0xdac;
+"Thai_yoying",0xdad;
+"Thai_dochada",0xdae;
+"Thai_topatak",0xdaf;
+"Thai_thothan",0xdb0;
+"Thai_thonangmontho",0xdb1;
+"Thai_thophuthao",0xdb2;
+"Thai_nonen",0xdb3;
+"Thai_dodek",0xdb4;
+"Thai_totao",0xdb5;
+"Thai_thothung",0xdb6;
+"Thai_thothahan",0xdb7;
+"Thai_thothong",0xdb8;
+"Thai_nonu",0xdb9;
+"Thai_bobaimai",0xdba;
+"Thai_popla",0xdbb;
+"Thai_phophung",0xdbc;
+"Thai_fofa",0xdbd;
+"Thai_phophan",0xdbe;
+"Thai_fofan",0xdbf;
+"Thai_phosamphao",0xdc0;
+"Thai_moma",0xdc1;
+"Thai_yoyak",0xdc2;
+"Thai_rorua",0xdc3;
+"Thai_ru",0xdc4;
+"Thai_loling",0xdc5;
+"Thai_lu",0xdc6;
+"Thai_wowaen",0xdc7;
+"Thai_sosala",0xdc8;
+"Thai_sorusi",0xdc9;
+"Thai_sosua",0xdca;
+"Thai_hohip",0xdcb;
+"Thai_lochula",0xdcc;
+"Thai_oang",0xdcd;
+"Thai_honokhuk",0xdce;
+"Thai_paiyannoi",0xdcf;
+"Thai_saraa",0xdd0;
+"Thai_maihanakat",0xdd1;
+"Thai_saraaa",0xdd2;
+"Thai_saraam",0xdd3;
+"Thai_sarai",0xdd4;
+"Thai_saraii",0xdd5;
+"Thai_saraue",0xdd6;
+"Thai_sarauee",0xdd7;
+"Thai_sarau",0xdd8;
+"Thai_sarauu",0xdd9;
+"Thai_phinthu",0xdda;
+"Thai_maihanakat_maitho",0xdde;
+"Thai_baht",0xddf;
+"Thai_sarae",0xde0;
+"Thai_saraae",0xde1;
+"Thai_sarao",0xde2;
+"Thai_saraaimaimuan",0xde3;
+"Thai_saraaimaimalai",0xde4;
+"Thai_lakkhangyao",0xde5;
+"Thai_maiyamok",0xde6;
+"Thai_maitaikhu",0xde7;
+"Thai_maiek",0xde8;
+"Thai_maitho",0xde9;
+"Thai_maitri",0xdea;
+"Thai_maichattawa",0xdeb;
+"Thai_thanthakhat",0xdec;
+"Thai_nikhahit",0xded;
+"Thai_leksun",0xdf0;
+"Thai_leknung",0xdf1;
+"Thai_leksong",0xdf2;
+"Thai_leksam",0xdf3;
+"Thai_leksi",0xdf4;
+"Thai_lekha",0xdf5;
+"Thai_lekhok",0xdf6;
+"Thai_lekchet",0xdf7;
+"Thai_lekpaet",0xdf8;
+"Thai_lekkao",0xdf9;
+"Hangul",0xff31;
+"Hangul_Start",0xff32;
+"Hangul_End",0xff33;
+"Hangul_Hanja",0xff34;
+"Hangul_Jamo",0xff35;
+"Hangul_Romaja",0xff36;
+"Hangul_Codeinput",0xff37;
+"Hangul_Jeonja",0xff38;
+"Hangul_Banja",0xff39;
+"Hangul_PreHanja",0xff3a;
+"Hangul_PostHanja",0xff3b;
+"Hangul_SingleCandidate",0xff3c;
+"Hangul_MultipleCandidate",0xff3d;
+"Hangul_PreviousCandidate",0xff3e;
+"Hangul_Special",0xff3f;
+"Hangul_switch",0xFF7E;
+"Hangul_Kiyeog",0xea1;
+"Hangul_SsangKiyeog",0xea2;
+"Hangul_KiyeogSios",0xea3;
+"Hangul_Nieun",0xea4;
+"Hangul_NieunJieuj",0xea5;
+"Hangul_NieunHieuh",0xea6;
+"Hangul_Dikeud",0xea7;
+"Hangul_SsangDikeud",0xea8;
+"Hangul_Rieul",0xea9;
+"Hangul_RieulKiyeog",0xeaa;
+"Hangul_RieulMieum",0xeab;
+"Hangul_RieulPieub",0xeac;
+"Hangul_RieulSios",0xead;
+"Hangul_RieulTieut",0xeae;
+"Hangul_RieulPhieuf",0xeaf;
+"Hangul_RieulHieuh",0xeb0;
+"Hangul_Mieum",0xeb1;
+"Hangul_Pieub",0xeb2;
+"Hangul_SsangPieub",0xeb3;
+"Hangul_PieubSios",0xeb4;
+"Hangul_Sios",0xeb5;
+"Hangul_SsangSios",0xeb6;
+"Hangul_Ieung",0xeb7;
+"Hangul_Jieuj",0xeb8;
+"Hangul_SsangJieuj",0xeb9;
+"Hangul_Cieuc",0xeba;
+"Hangul_Khieuq",0xebb;
+"Hangul_Tieut",0xebc;
+"Hangul_Phieuf",0xebd;
+"Hangul_Hieuh",0xebe;
+"Hangul_A",0xebf;
+"Hangul_AE",0xec0;
+"Hangul_YA",0xec1;
+"Hangul_YAE",0xec2;
+"Hangul_EO",0xec3;
+"Hangul_E",0xec4;
+"Hangul_YEO",0xec5;
+"Hangul_YE",0xec6;
+"Hangul_O",0xec7;
+"Hangul_WA",0xec8;
+"Hangul_WAE",0xec9;
+"Hangul_OE",0xeca;
+"Hangul_YO",0xecb;
+"Hangul_U",0xecc;
+"Hangul_WEO",0xecd;
+"Hangul_WE",0xece;
+"Hangul_WI",0xecf;
+"Hangul_YU",0xed0;
+"Hangul_EU",0xed1;
+"Hangul_YI",0xed2;
+"Hangul_I",0xed3;
+"Hangul_J_Kiyeog",0xed4;
+"Hangul_J_SsangKiyeog",0xed5;
+"Hangul_J_KiyeogSios",0xed6;
+"Hangul_J_Nieun",0xed7;
+"Hangul_J_NieunJieuj",0xed8;
+"Hangul_J_NieunHieuh",0xed9;
+"Hangul_J_Dikeud",0xeda;
+"Hangul_J_Rieul",0xedb;
+"Hangul_J_RieulKiyeog",0xedc;
+"Hangul_J_RieulMieum",0xedd;
+"Hangul_J_RieulPieub",0xede;
+"Hangul_J_RieulSios",0xedf;
+"Hangul_J_RieulTieut",0xee0;
+"Hangul_J_RieulPhieuf",0xee1;
+"Hangul_J_RieulHieuh",0xee2;
+"Hangul_J_Mieum",0xee3;
+"Hangul_J_Pieub",0xee4;
+"Hangul_J_PieubSios",0xee5;
+"Hangul_J_Sios",0xee6;
+"Hangul_J_SsangSios",0xee7;
+"Hangul_J_Ieung",0xee8;
+"Hangul_J_Jieuj",0xee9;
+"Hangul_J_Cieuc",0xeea;
+"Hangul_J_Khieuq",0xeeb;
+"Hangul_J_Tieut",0xeec;
+"Hangul_J_Phieuf",0xeed;
+"Hangul_J_Hieuh",0xeee;
+"Hangul_RieulYeorinHieuh",0xeef;
+"Hangul_SunkyeongeumMieum",0xef0;
+"Hangul_SunkyeongeumPieub",0xef1;
+"Hangul_PanSios",0xef2;
+"Hangul_KkogjiDalrinIeung",0xef3;
+"Hangul_SunkyeongeumPhieuf",0xef4;
+"Hangul_YeorinHieuh",0xef5;
+"Hangul_AraeA",0xef6;
+"Hangul_AraeAE",0xef7;
+"Hangul_J_PanSios",0xef8;
+"Hangul_J_KkogjiDalrinIeung",0xef9;
+"Hangul_J_YeorinHieuh",0xefa;
+"Korean_Won",0xeff;
+]
+let keysym_to_name = [
+0xFFFFFF,"VoidSymbol";
+0xFF08,"BackSpace";
+0xFF09,"Tab";
+0xFF0A,"Linefeed";
+0xFF0B,"Clear";
+0xFF0D,"Return";
+0xFF13,"Pause";
+0xFF14,"Scroll_Lock";
+0xFF15,"Sys_Req";
+0xFF1B,"Escape";
+0xFFFF,"Delete";
+0xFF20,"Multi_key";
+0xFF21,"Kanji";
+0xFF22,"Muhenkan";
+0xFF23,"Henkan_Mode";
+0xFF23,"Henkan";
+0xFF24,"Romaji";
+0xFF25,"Hiragana";
+0xFF26,"Katakana";
+0xFF27,"Hiragana_Katakana";
+0xFF28,"Zenkaku";
+0xFF29,"Hankaku";
+0xFF2A,"Zenkaku_Hankaku";
+0xFF2B,"Touroku";
+0xFF2C,"Massyo";
+0xFF2D,"Kana_Lock";
+0xFF2E,"Kana_Shift";
+0xFF2F,"Eisu_Shift";
+0xFF30,"Eisu_toggle";
+0xFF50,"Home";
+0xFF51,"Left";
+0xFF52,"Up";
+0xFF53,"Right";
+0xFF54,"Down";
+0xFF55,"Prior";
+0xFF55,"Page_Up";
+0xFF56,"Next";
+0xFF56,"Page_Down";
+0xFF57,"End";
+0xFF58,"Begin";
+0xFF60,"Select";
+0xFF61,"Print";
+0xFF62,"Execute";
+0xFF63,"Insert";
+0xFF65,"Undo";
+0xFF66,"Redo";
+0xFF67,"Menu";
+0xFF68,"Find";
+0xFF69,"Cancel";
+0xFF6A,"Help";
+0xFF6B,"Break";
+0xFF7E,"Mode_switch";
+0xFF7E,"script_switch";
+0xFF7F,"Num_Lock";
+0xFF80,"KP_Space";
+0xFF89,"KP_Tab";
+0xFF8D,"KP_Enter";
+0xFF91,"KP_F1";
+0xFF92,"KP_F2";
+0xFF93,"KP_F3";
+0xFF94,"KP_F4";
+0xFF95,"KP_Home";
+0xFF96,"KP_Left";
+0xFF97,"KP_Up";
+0xFF98,"KP_Right";
+0xFF99,"KP_Down";
+0xFF9A,"KP_Prior";
+0xFF9A,"KP_Page_Up";
+0xFF9B,"KP_Next";
+0xFF9B,"KP_Page_Down";
+0xFF9C,"KP_End";
+0xFF9D,"KP_Begin";
+0xFF9E,"KP_Insert";
+0xFF9F,"KP_Delete";
+0xFFBD,"KP_Equal";
+0xFFAA,"KP_Multiply";
+0xFFAB,"KP_Add";
+0xFFAC,"KP_Separator";
+0xFFAD,"KP_Subtract";
+0xFFAE,"KP_Decimal";
+0xFFAF,"KP_Divide";
+0xFFB0,"KP_0";
+0xFFB1,"KP_1";
+0xFFB2,"KP_2";
+0xFFB3,"KP_3";
+0xFFB4,"KP_4";
+0xFFB5,"KP_5";
+0xFFB6,"KP_6";
+0xFFB7,"KP_7";
+0xFFB8,"KP_8";
+0xFFB9,"KP_9";
+0xFFBE,"F1";
+0xFFBF,"F2";
+0xFFC0,"F3";
+0xFFC1,"F4";
+0xFFC2,"F5";
+0xFFC3,"F6";
+0xFFC4,"F7";
+0xFFC5,"F8";
+0xFFC6,"F9";
+0xFFC7,"F10";
+0xFFC8,"F11";
+0xFFC8,"L1";
+0xFFC9,"F12";
+0xFFC9,"L2";
+0xFFCA,"F13";
+0xFFCA,"L3";
+0xFFCB,"F14";
+0xFFCB,"L4";
+0xFFCC,"F15";
+0xFFCC,"L5";
+0xFFCD,"F16";
+0xFFCD,"L6";
+0xFFCE,"F17";
+0xFFCE,"L7";
+0xFFCF,"F18";
+0xFFCF,"L8";
+0xFFD0,"F19";
+0xFFD0,"L9";
+0xFFD1,"F20";
+0xFFD1,"L10";
+0xFFD2,"F21";
+0xFFD2,"R1";
+0xFFD3,"F22";
+0xFFD3,"R2";
+0xFFD4,"F23";
+0xFFD4,"R3";
+0xFFD5,"F24";
+0xFFD5,"R4";
+0xFFD6,"F25";
+0xFFD6,"R5";
+0xFFD7,"F26";
+0xFFD7,"R6";
+0xFFD8,"F27";
+0xFFD8,"R7";
+0xFFD9,"F28";
+0xFFD9,"R8";
+0xFFDA,"F29";
+0xFFDA,"R9";
+0xFFDB,"F30";
+0xFFDB,"R10";
+0xFFDC,"F31";
+0xFFDC,"R11";
+0xFFDD,"F32";
+0xFFDD,"R12";
+0xFFDE,"F33";
+0xFFDE,"R13";
+0xFFDF,"F34";
+0xFFDF,"R14";
+0xFFE0,"F35";
+0xFFE0,"R15";
+0xFFE1,"Shift_L";
+0xFFE2,"Shift_R";
+0xFFE3,"Control_L";
+0xFFE4,"Control_R";
+0xFFE5,"Caps_Lock";
+0xFFE6,"Shift_Lock";
+0xFFE7,"Meta_L";
+0xFFE8,"Meta_R";
+0xFFE9,"Alt_L";
+0xFFEA,"Alt_R";
+0xFFEB,"Super_L";
+0xFFEC,"Super_R";
+0xFFED,"Hyper_L";
+0xFFEE,"Hyper_R";
+0xFE01,"ISO_Lock";
+0xFE02,"ISO_Level2_Latch";
+0xFE03,"ISO_Level3_Shift";
+0xFE04,"ISO_Level3_Latch";
+0xFE05,"ISO_Level3_Lock";
+0xFF7E,"ISO_Group_Shift";
+0xFE06,"ISO_Group_Latch";
+0xFE07,"ISO_Group_Lock";
+0xFE08,"ISO_Next_Group";
+0xFE09,"ISO_Next_Group_Lock";
+0xFE0A,"ISO_Prev_Group";
+0xFE0B,"ISO_Prev_Group_Lock";
+0xFE0C,"ISO_First_Group";
+0xFE0D,"ISO_First_Group_Lock";
+0xFE0E,"ISO_Last_Group";
+0xFE0F,"ISO_Last_Group_Lock";
+0xFE20,"ISO_Left_Tab";
+0xFE21,"ISO_Move_Line_Up";
+0xFE22,"ISO_Move_Line_Down";
+0xFE23,"ISO_Partial_Line_Up";
+0xFE24,"ISO_Partial_Line_Down";
+0xFE25,"ISO_Partial_Space_Left";
+0xFE26,"ISO_Partial_Space_Right";
+0xFE27,"ISO_Set_Margin_Left";
+0xFE28,"ISO_Set_Margin_Right";
+0xFE29,"ISO_Release_Margin_Left";
+0xFE2A,"ISO_Release_Margin_Right";
+0xFE2B,"ISO_Release_Both_Margins";
+0xFE2C,"ISO_Fast_Cursor_Left";
+0xFE2D,"ISO_Fast_Cursor_Right";
+0xFE2E,"ISO_Fast_Cursor_Up";
+0xFE2F,"ISO_Fast_Cursor_Down";
+0xFE30,"ISO_Continuous_Underline";
+0xFE31,"ISO_Discontinuous_Underline";
+0xFE32,"ISO_Emphasize";
+0xFE33,"ISO_Center_Object";
+0xFE34,"ISO_Enter";
+0xFE50,"dead_grave";
+0xFE51,"dead_acute";
+0xFE52,"dead_circumflex";
+0xFE53,"dead_tilde";
+0xFE54,"dead_macron";
+0xFE55,"dead_breve";
+0xFE56,"dead_abovedot";
+0xFE57,"dead_diaeresis";
+0xFE58,"dead_abovering";
+0xFE59,"dead_doubleacute";
+0xFE5A,"dead_caron";
+0xFE5B,"dead_cedilla";
+0xFE5C,"dead_ogonek";
+0xFE5D,"dead_iota";
+0xFE5E,"dead_voiced_sound";
+0xFE5F,"dead_semivoiced_sound";
+0xFE60,"dead_belowdot";
+0xFED0,"First_Virtual_Screen";
+0xFED1,"Prev_Virtual_Screen";
+0xFED2,"Next_Virtual_Screen";
+0xFED4,"Last_Virtual_Screen";
+0xFED5,"Terminate_Server";
+0xFE70,"AccessX_Enable";
+0xFE71,"AccessX_Feedback_Enable";
+0xFE72,"RepeatKeys_Enable";
+0xFE73,"SlowKeys_Enable";
+0xFE74,"BounceKeys_Enable";
+0xFE75,"StickyKeys_Enable";
+0xFE76,"MouseKeys_Enable";
+0xFE77,"MouseKeys_Accel_Enable";
+0xFE78,"Overlay1_Enable";
+0xFE79,"Overlay2_Enable";
+0xFE7A,"AudibleBell_Enable";
+0xFEE0,"Pointer_Left";
+0xFEE1,"Pointer_Right";
+0xFEE2,"Pointer_Up";
+0xFEE3,"Pointer_Down";
+0xFEE4,"Pointer_UpLeft";
+0xFEE5,"Pointer_UpRight";
+0xFEE6,"Pointer_DownLeft";
+0xFEE7,"Pointer_DownRight";
+0xFEE8,"Pointer_Button_Dflt";
+0xFEE9,"Pointer_Button1";
+0xFEEA,"Pointer_Button2";
+0xFEEB,"Pointer_Button3";
+0xFEEC,"Pointer_Button4";
+0xFEED,"Pointer_Button5";
+0xFEEE,"Pointer_DblClick_Dflt";
+0xFEEF,"Pointer_DblClick1";
+0xFEF0,"Pointer_DblClick2";
+0xFEF1,"Pointer_DblClick3";
+0xFEF2,"Pointer_DblClick4";
+0xFEF3,"Pointer_DblClick5";
+0xFEF4,"Pointer_Drag_Dflt";
+0xFEF5,"Pointer_Drag1";
+0xFEF6,"Pointer_Drag2";
+0xFEF7,"Pointer_Drag3";
+0xFEF8,"Pointer_Drag4";
+0xFEFD,"Pointer_Drag5";
+0xFEF9,"Pointer_EnableKeys";
+0xFEFA,"Pointer_Accelerate";
+0xFEFB,"Pointer_DfltBtnNext";
+0xFEFC,"Pointer_DfltBtnPrev";
+0xFD01,"3270_Duplicate";
+0xFD02,"3270_FieldMark";
+0xFD03,"3270_Right2";
+0xFD04,"3270_Left2";
+0xFD05,"3270_BackTab";
+0xFD06,"3270_EraseEOF";
+0xFD07,"3270_EraseInput";
+0xFD08,"3270_Reset";
+0xFD09,"3270_Quit";
+0xFD0A,"3270_PA1";
+0xFD0B,"3270_PA2";
+0xFD0C,"3270_PA3";
+0xFD0D,"3270_Test";
+0xFD0E,"3270_Attn";
+0xFD0F,"3270_CursorBlink";
+0xFD10,"3270_AltCursor";
+0xFD11,"3270_KeyClick";
+0xFD12,"3270_Jump";
+0xFD13,"3270_Ident";
+0xFD14,"3270_Rule";
+0xFD15,"3270_Copy";
+0xFD16,"3270_Play";
+0xFD17,"3270_Setup";
+0xFD18,"3270_Record";
+0xFD19,"3270_ChangeScreen";
+0xFD1A,"3270_DeleteWord";
+0xFD1B,"3270_ExSelect";
+0xFD1C,"3270_CursorSelect";
+0xFD1D,"3270_PrintScreen";
+0xFD1E,"3270_Enter";
+0x020,"space";
+0x021,"exclam";
+0x022,"quotedbl";
+0x023,"numbersign";
+0x024,"dollar";
+0x025,"percent";
+0x026,"ampersand";
+0x027,"apostrophe";
+0x027,"quoteright";
+0x028,"parenleft";
+0x029,"parenright";
+0x02a,"asterisk";
+0x02b,"plus";
+0x02c,"comma";
+0x02d,"minus";
+0x02e,"period";
+0x02f,"slash";
+0x030,"0";
+0x031,"1";
+0x032,"2";
+0x033,"3";
+0x034,"4";
+0x035,"5";
+0x036,"6";
+0x037,"7";
+0x038,"8";
+0x039,"9";
+0x03a,"colon";
+0x03b,"semicolon";
+0x03c,"less";
+0x03d,"equal";
+0x03e,"greater";
+0x03f,"question";
+0x040,"at";
+0x041,"A";
+0x042,"B";
+0x043,"C";
+0x044,"D";
+0x045,"E";
+0x046,"F";
+0x047,"G";
+0x048,"H";
+0x049,"I";
+0x04a,"J";
+0x04b,"K";
+0x04c,"L";
+0x04d,"M";
+0x04e,"N";
+0x04f,"O";
+0x050,"P";
+0x051,"Q";
+0x052,"R";
+0x053,"S";
+0x054,"T";
+0x055,"U";
+0x056,"V";
+0x057,"W";
+0x058,"X";
+0x059,"Y";
+0x05a,"Z";
+0x05b,"bracketleft";
+0x05c,"backslash";
+0x05d,"bracketright";
+0x05e,"asciicircum";
+0x05f,"underscore";
+0x060,"grave";
+0x060,"quoteleft";
+0x061,"a";
+0x062,"b";
+0x063,"c";
+0x064,"d";
+0x065,"e";
+0x066,"f";
+0x067,"g";
+0x068,"h";
+0x069,"i";
+0x06a,"j";
+0x06b,"k";
+0x06c,"l";
+0x06d,"m";
+0x06e,"n";
+0x06f,"o";
+0x070,"p";
+0x071,"q";
+0x072,"r";
+0x073,"s";
+0x074,"t";
+0x075,"u";
+0x076,"v";
+0x077,"w";
+0x078,"x";
+0x079,"y";
+0x07a,"z";
+0x07b,"braceleft";
+0x07c,"bar";
+0x07d,"braceright";
+0x07e,"asciitilde";
+0x0a0,"nobreakspace";
+0x0a1,"exclamdown";
+0x0a2,"cent";
+0x0a3,"sterling";
+0x0a4,"currency";
+0x0a5,"yen";
+0x0a6,"brokenbar";
+0x0a7,"section";
+0x0a8,"diaeresis";
+0x0a9,"copyright";
+0x0aa,"ordfeminine";
+0x0ab,"guillemotleft";
+0x0ac,"notsign";
+0x0ad,"hyphen";
+0x0ae,"registered";
+0x0af,"macron";
+0x0b0,"degree";
+0x0b1,"plusminus";
+0x0b2,"twosuperior";
+0x0b3,"threesuperior";
+0x0b4,"acute";
+0x0b5,"mu";
+0x0b6,"paragraph";
+0x0b7,"periodcentered";
+0x0b8,"cedilla";
+0x0b9,"onesuperior";
+0x0ba,"masculine";
+0x0bb,"guillemotright";
+0x0bc,"onequarter";
+0x0bd,"onehalf";
+0x0be,"threequarters";
+0x0bf,"questiondown";
+0x0c0,"Agrave";
+0x0c1,"Aacute";
+0x0c2,"Acircumflex";
+0x0c3,"Atilde";
+0x0c4,"Adiaeresis";
+0x0c5,"Aring";
+0x0c6,"AE";
+0x0c7,"Ccedilla";
+0x0c8,"Egrave";
+0x0c9,"Eacute";
+0x0ca,"Ecircumflex";
+0x0cb,"Ediaeresis";
+0x0cc,"Igrave";
+0x0cd,"Iacute";
+0x0ce,"Icircumflex";
+0x0cf,"Idiaeresis";
+0x0d0,"ETH";
+0x0d0,"Eth";
+0x0d1,"Ntilde";
+0x0d2,"Ograve";
+0x0d3,"Oacute";
+0x0d4,"Ocircumflex";
+0x0d5,"Otilde";
+0x0d6,"Odiaeresis";
+0x0d7,"multiply";
+0x0d8,"Ooblique";
+0x0d9,"Ugrave";
+0x0da,"Uacute";
+0x0db,"Ucircumflex";
+0x0dc,"Udiaeresis";
+0x0dd,"Yacute";
+0x0de,"THORN";
+0x0de,"Thorn";
+0x0df,"ssharp";
+0x0e0,"agrave";
+0x0e1,"aacute";
+0x0e2,"acircumflex";
+0x0e3,"atilde";
+0x0e4,"adiaeresis";
+0x0e5,"aring";
+0x0e6,"ae";
+0x0e7,"ccedilla";
+0x0e8,"egrave";
+0x0e9,"eacute";
+0x0ea,"ecircumflex";
+0x0eb,"ediaeresis";
+0x0ec,"igrave";
+0x0ed,"iacute";
+0x0ee,"icircumflex";
+0x0ef,"idiaeresis";
+0x0f0,"eth";
+0x0f1,"ntilde";
+0x0f2,"ograve";
+0x0f3,"oacute";
+0x0f4,"ocircumflex";
+0x0f5,"otilde";
+0x0f6,"odiaeresis";
+0x0f7,"division";
+0x0f8,"oslash";
+0x0f9,"ugrave";
+0x0fa,"uacute";
+0x0fb,"ucircumflex";
+0x0fc,"udiaeresis";
+0x0fd,"yacute";
+0x0fe,"thorn";
+0x0ff,"ydiaeresis";
+0x1a1,"Aogonek";
+0x1a2,"breve";
+0x1a3,"Lstroke";
+0x1a5,"Lcaron";
+0x1a6,"Sacute";
+0x1a9,"Scaron";
+0x1aa,"Scedilla";
+0x1ab,"Tcaron";
+0x1ac,"Zacute";
+0x1ae,"Zcaron";
+0x1af,"Zabovedot";
+0x1b1,"aogonek";
+0x1b2,"ogonek";
+0x1b3,"lstroke";
+0x1b5,"lcaron";
+0x1b6,"sacute";
+0x1b7,"caron";
+0x1b9,"scaron";
+0x1ba,"scedilla";
+0x1bb,"tcaron";
+0x1bc,"zacute";
+0x1bd,"doubleacute";
+0x1be,"zcaron";
+0x1bf,"zabovedot";
+0x1c0,"Racute";
+0x1c3,"Abreve";
+0x1c5,"Lacute";
+0x1c6,"Cacute";
+0x1c8,"Ccaron";
+0x1ca,"Eogonek";
+0x1cc,"Ecaron";
+0x1cf,"Dcaron";
+0x1d0,"Dstroke";
+0x1d1,"Nacute";
+0x1d2,"Ncaron";
+0x1d5,"Odoubleacute";
+0x1d8,"Rcaron";
+0x1d9,"Uring";
+0x1db,"Udoubleacute";
+0x1de,"Tcedilla";
+0x1e0,"racute";
+0x1e3,"abreve";
+0x1e5,"lacute";
+0x1e6,"cacute";
+0x1e8,"ccaron";
+0x1ea,"eogonek";
+0x1ec,"ecaron";
+0x1ef,"dcaron";
+0x1f0,"dstroke";
+0x1f1,"nacute";
+0x1f2,"ncaron";
+0x1f5,"odoubleacute";
+0x1fb,"udoubleacute";
+0x1f8,"rcaron";
+0x1f9,"uring";
+0x1fe,"tcedilla";
+0x1ff,"abovedot";
+0x2a1,"Hstroke";
+0x2a6,"Hcircumflex";
+0x2a9,"Iabovedot";
+0x2ab,"Gbreve";
+0x2ac,"Jcircumflex";
+0x2b1,"hstroke";
+0x2b6,"hcircumflex";
+0x2b9,"idotless";
+0x2bb,"gbreve";
+0x2bc,"jcircumflex";
+0x2c5,"Cabovedot";
+0x2c6,"Ccircumflex";
+0x2d5,"Gabovedot";
+0x2d8,"Gcircumflex";
+0x2dd,"Ubreve";
+0x2de,"Scircumflex";
+0x2e5,"cabovedot";
+0x2e6,"ccircumflex";
+0x2f5,"gabovedot";
+0x2f8,"gcircumflex";
+0x2fd,"ubreve";
+0x2fe,"scircumflex";
+0x3a2,"kra";
+0x3a2,"kappa";
+0x3a3,"Rcedilla";
+0x3a5,"Itilde";
+0x3a6,"Lcedilla";
+0x3aa,"Emacron";
+0x3ab,"Gcedilla";
+0x3ac,"Tslash";
+0x3b3,"rcedilla";
+0x3b5,"itilde";
+0x3b6,"lcedilla";
+0x3ba,"emacron";
+0x3bb,"gcedilla";
+0x3bc,"tslash";
+0x3bd,"ENG";
+0x3bf,"eng";
+0x3c0,"Amacron";
+0x3c7,"Iogonek";
+0x3cc,"Eabovedot";
+0x3cf,"Imacron";
+0x3d1,"Ncedilla";
+0x3d2,"Omacron";
+0x3d3,"Kcedilla";
+0x3d9,"Uogonek";
+0x3dd,"Utilde";
+0x3de,"Umacron";
+0x3e0,"amacron";
+0x3e7,"iogonek";
+0x3ec,"eabovedot";
+0x3ef,"imacron";
+0x3f1,"ncedilla";
+0x3f2,"omacron";
+0x3f3,"kcedilla";
+0x3f9,"uogonek";
+0x3fd,"utilde";
+0x3fe,"umacron";
+0x47e,"overline";
+0x4a1,"kana_fullstop";
+0x4a2,"kana_openingbracket";
+0x4a3,"kana_closingbracket";
+0x4a4,"kana_comma";
+0x4a5,"kana_conjunctive";
+0x4a5,"kana_middledot";
+0x4a6,"kana_WO";
+0x4a7,"kana_a";
+0x4a8,"kana_i";
+0x4a9,"kana_u";
+0x4aa,"kana_e";
+0x4ab,"kana_o";
+0x4ac,"kana_ya";
+0x4ad,"kana_yu";
+0x4ae,"kana_yo";
+0x4af,"kana_tsu";
+0x4af,"kana_tu";
+0x4b0,"prolongedsound";
+0x4b1,"kana_A";
+0x4b2,"kana_I";
+0x4b3,"kana_U";
+0x4b4,"kana_E";
+0x4b5,"kana_O";
+0x4b6,"kana_KA";
+0x4b7,"kana_KI";
+0x4b8,"kana_KU";
+0x4b9,"kana_KE";
+0x4ba,"kana_KO";
+0x4bb,"kana_SA";
+0x4bc,"kana_SHI";
+0x4bd,"kana_SU";
+0x4be,"kana_SE";
+0x4bf,"kana_SO";
+0x4c0,"kana_TA";
+0x4c1,"kana_CHI";
+0x4c1,"kana_TI";
+0x4c2,"kana_TSU";
+0x4c2,"kana_TU";
+0x4c3,"kana_TE";
+0x4c4,"kana_TO";
+0x4c5,"kana_NA";
+0x4c6,"kana_NI";
+0x4c7,"kana_NU";
+0x4c8,"kana_NE";
+0x4c9,"kana_NO";
+0x4ca,"kana_HA";
+0x4cb,"kana_HI";
+0x4cc,"kana_FU";
+0x4cc,"kana_HU";
+0x4cd,"kana_HE";
+0x4ce,"kana_HO";
+0x4cf,"kana_MA";
+0x4d0,"kana_MI";
+0x4d1,"kana_MU";
+0x4d2,"kana_ME";
+0x4d3,"kana_MO";
+0x4d4,"kana_YA";
+0x4d5,"kana_YU";
+0x4d6,"kana_YO";
+0x4d7,"kana_RA";
+0x4d8,"kana_RI";
+0x4d9,"kana_RU";
+0x4da,"kana_RE";
+0x4db,"kana_RO";
+0x4dc,"kana_WA";
+0x4dd,"kana_N";
+0x4de,"voicedsound";
+0x4df,"semivoicedsound";
+0xFF7E,"kana_switch";
+0x5ac,"Arabic_comma";
+0x5bb,"Arabic_semicolon";
+0x5bf,"Arabic_question_mark";
+0x5c1,"Arabic_hamza";
+0x5c2,"Arabic_maddaonalef";
+0x5c3,"Arabic_hamzaonalef";
+0x5c4,"Arabic_hamzaonwaw";
+0x5c5,"Arabic_hamzaunderalef";
+0x5c6,"Arabic_hamzaonyeh";
+0x5c7,"Arabic_alef";
+0x5c8,"Arabic_beh";
+0x5c9,"Arabic_tehmarbuta";
+0x5ca,"Arabic_teh";
+0x5cb,"Arabic_theh";
+0x5cc,"Arabic_jeem";
+0x5cd,"Arabic_hah";
+0x5ce,"Arabic_khah";
+0x5cf,"Arabic_dal";
+0x5d0,"Arabic_thal";
+0x5d1,"Arabic_ra";
+0x5d2,"Arabic_zain";
+0x5d3,"Arabic_seen";
+0x5d4,"Arabic_sheen";
+0x5d5,"Arabic_sad";
+0x5d6,"Arabic_dad";
+0x5d7,"Arabic_tah";
+0x5d8,"Arabic_zah";
+0x5d9,"Arabic_ain";
+0x5da,"Arabic_ghain";
+0x5e0,"Arabic_tatweel";
+0x5e1,"Arabic_feh";
+0x5e2,"Arabic_qaf";
+0x5e3,"Arabic_kaf";
+0x5e4,"Arabic_lam";
+0x5e5,"Arabic_meem";
+0x5e6,"Arabic_noon";
+0x5e7,"Arabic_ha";
+0x5e7,"Arabic_heh";
+0x5e8,"Arabic_waw";
+0x5e9,"Arabic_alefmaksura";
+0x5ea,"Arabic_yeh";
+0x5eb,"Arabic_fathatan";
+0x5ec,"Arabic_dammatan";
+0x5ed,"Arabic_kasratan";
+0x5ee,"Arabic_fatha";
+0x5ef,"Arabic_damma";
+0x5f0,"Arabic_kasra";
+0x5f1,"Arabic_shadda";
+0x5f2,"Arabic_sukun";
+0xFF7E,"Arabic_switch";
+0x6a1,"Serbian_dje";
+0x6a2,"Macedonia_gje";
+0x6a3,"Cyrillic_io";
+0x6a4,"Ukrainian_ie";
+0x6a4,"Ukranian_je";
+0x6a5,"Macedonia_dse";
+0x6a6,"Ukrainian_i";
+0x6a6,"Ukranian_i";
+0x6a7,"Ukrainian_yi";
+0x6a7,"Ukranian_yi";
+0x6a8,"Cyrillic_je";
+0x6a8,"Serbian_je";
+0x6a9,"Cyrillic_lje";
+0x6a9,"Serbian_lje";
+0x6aa,"Cyrillic_nje";
+0x6aa,"Serbian_nje";
+0x6ab,"Serbian_tshe";
+0x6ac,"Macedonia_kje";
+0x6ae,"Byelorussian_shortu";
+0x6af,"Cyrillic_dzhe";
+0x6af,"Serbian_dze";
+0x6b0,"numerosign";
+0x6b1,"Serbian_DJE";
+0x6b2,"Macedonia_GJE";
+0x6b3,"Cyrillic_IO";
+0x6b4,"Ukrainian_IE";
+0x6b4,"Ukranian_JE";
+0x6b5,"Macedonia_DSE";
+0x6b6,"Ukrainian_I";
+0x6b6,"Ukranian_I";
+0x6b7,"Ukrainian_YI";
+0x6b7,"Ukranian_YI";
+0x6b8,"Cyrillic_JE";
+0x6b8,"Serbian_JE";
+0x6b9,"Cyrillic_LJE";
+0x6b9,"Serbian_LJE";
+0x6ba,"Cyrillic_NJE";
+0x6ba,"Serbian_NJE";
+0x6bb,"Serbian_TSHE";
+0x6bc,"Macedonia_KJE";
+0x6be,"Byelorussian_SHORTU";
+0x6bf,"Cyrillic_DZHE";
+0x6bf,"Serbian_DZE";
+0x6c0,"Cyrillic_yu";
+0x6c1,"Cyrillic_a";
+0x6c2,"Cyrillic_be";
+0x6c3,"Cyrillic_tse";
+0x6c4,"Cyrillic_de";
+0x6c5,"Cyrillic_ie";
+0x6c6,"Cyrillic_ef";
+0x6c7,"Cyrillic_ghe";
+0x6c8,"Cyrillic_ha";
+0x6c9,"Cyrillic_i";
+0x6ca,"Cyrillic_shorti";
+0x6cb,"Cyrillic_ka";
+0x6cc,"Cyrillic_el";
+0x6cd,"Cyrillic_em";
+0x6ce,"Cyrillic_en";
+0x6cf,"Cyrillic_o";
+0x6d0,"Cyrillic_pe";
+0x6d1,"Cyrillic_ya";
+0x6d2,"Cyrillic_er";
+0x6d3,"Cyrillic_es";
+0x6d4,"Cyrillic_te";
+0x6d5,"Cyrillic_u";
+0x6d6,"Cyrillic_zhe";
+0x6d7,"Cyrillic_ve";
+0x6d8,"Cyrillic_softsign";
+0x6d9,"Cyrillic_yeru";
+0x6da,"Cyrillic_ze";
+0x6db,"Cyrillic_sha";
+0x6dc,"Cyrillic_e";
+0x6dd,"Cyrillic_shcha";
+0x6de,"Cyrillic_che";
+0x6df,"Cyrillic_hardsign";
+0x6e0,"Cyrillic_YU";
+0x6e1,"Cyrillic_A";
+0x6e2,"Cyrillic_BE";
+0x6e3,"Cyrillic_TSE";
+0x6e4,"Cyrillic_DE";
+0x6e5,"Cyrillic_IE";
+0x6e6,"Cyrillic_EF";
+0x6e7,"Cyrillic_GHE";
+0x6e8,"Cyrillic_HA";
+0x6e9,"Cyrillic_I";
+0x6ea,"Cyrillic_SHORTI";
+0x6eb,"Cyrillic_KA";
+0x6ec,"Cyrillic_EL";
+0x6ed,"Cyrillic_EM";
+0x6ee,"Cyrillic_EN";
+0x6ef,"Cyrillic_O";
+0x6f0,"Cyrillic_PE";
+0x6f1,"Cyrillic_YA";
+0x6f2,"Cyrillic_ER";
+0x6f3,"Cyrillic_ES";
+0x6f4,"Cyrillic_TE";
+0x6f5,"Cyrillic_U";
+0x6f6,"Cyrillic_ZHE";
+0x6f7,"Cyrillic_VE";
+0x6f8,"Cyrillic_SOFTSIGN";
+0x6f9,"Cyrillic_YERU";
+0x6fa,"Cyrillic_ZE";
+0x6fb,"Cyrillic_SHA";
+0x6fc,"Cyrillic_E";
+0x6fd,"Cyrillic_SHCHA";
+0x6fe,"Cyrillic_CHE";
+0x6ff,"Cyrillic_HARDSIGN";
+0x7a1,"Greek_ALPHAaccent";
+0x7a2,"Greek_EPSILONaccent";
+0x7a3,"Greek_ETAaccent";
+0x7a4,"Greek_IOTAaccent";
+0x7a5,"Greek_IOTAdiaeresis";
+0x7a7,"Greek_OMICRONaccent";
+0x7a8,"Greek_UPSILONaccent";
+0x7a9,"Greek_UPSILONdieresis";
+0x7ab,"Greek_OMEGAaccent";
+0x7ae,"Greek_accentdieresis";
+0x7af,"Greek_horizbar";
+0x7b1,"Greek_alphaaccent";
+0x7b2,"Greek_epsilonaccent";
+0x7b3,"Greek_etaaccent";
+0x7b4,"Greek_iotaaccent";
+0x7b5,"Greek_iotadieresis";
+0x7b6,"Greek_iotaaccentdieresis";
+0x7b7,"Greek_omicronaccent";
+0x7b8,"Greek_upsilonaccent";
+0x7b9,"Greek_upsilondieresis";
+0x7ba,"Greek_upsilonaccentdieresis";
+0x7bb,"Greek_omegaaccent";
+0x7c1,"Greek_ALPHA";
+0x7c2,"Greek_BETA";
+0x7c3,"Greek_GAMMA";
+0x7c4,"Greek_DELTA";
+0x7c5,"Greek_EPSILON";
+0x7c6,"Greek_ZETA";
+0x7c7,"Greek_ETA";
+0x7c8,"Greek_THETA";
+0x7c9,"Greek_IOTA";
+0x7ca,"Greek_KAPPA";
+0x7cb,"Greek_LAMDA";
+0x7cb,"Greek_LAMBDA";
+0x7cc,"Greek_MU";
+0x7cd,"Greek_NU";
+0x7ce,"Greek_XI";
+0x7cf,"Greek_OMICRON";
+0x7d0,"Greek_PI";
+0x7d1,"Greek_RHO";
+0x7d2,"Greek_SIGMA";
+0x7d4,"Greek_TAU";
+0x7d5,"Greek_UPSILON";
+0x7d6,"Greek_PHI";
+0x7d7,"Greek_CHI";
+0x7d8,"Greek_PSI";
+0x7d9,"Greek_OMEGA";
+0x7e1,"Greek_alpha";
+0x7e2,"Greek_beta";
+0x7e3,"Greek_gamma";
+0x7e4,"Greek_delta";
+0x7e5,"Greek_epsilon";
+0x7e6,"Greek_zeta";
+0x7e7,"Greek_eta";
+0x7e8,"Greek_theta";
+0x7e9,"Greek_iota";
+0x7ea,"Greek_kappa";
+0x7eb,"Greek_lamda";
+0x7eb,"Greek_lambda";
+0x7ec,"Greek_mu";
+0x7ed,"Greek_nu";
+0x7ee,"Greek_xi";
+0x7ef,"Greek_omicron";
+0x7f0,"Greek_pi";
+0x7f1,"Greek_rho";
+0x7f2,"Greek_sigma";
+0x7f3,"Greek_finalsmallsigma";
+0x7f4,"Greek_tau";
+0x7f5,"Greek_upsilon";
+0x7f6,"Greek_phi";
+0x7f7,"Greek_chi";
+0x7f8,"Greek_psi";
+0x7f9,"Greek_omega";
+0xFF7E,"Greek_switch";
+0x8a1,"leftradical";
+0x8a2,"topleftradical";
+0x8a3,"horizconnector";
+0x8a4,"topintegral";
+0x8a5,"botintegral";
+0x8a6,"vertconnector";
+0x8a7,"topleftsqbracket";
+0x8a8,"botleftsqbracket";
+0x8a9,"toprightsqbracket";
+0x8aa,"botrightsqbracket";
+0x8ab,"topleftparens";
+0x8ac,"botleftparens";
+0x8ad,"toprightparens";
+0x8ae,"botrightparens";
+0x8af,"leftmiddlecurlybrace";
+0x8b0,"rightmiddlecurlybrace";
+0x8b1,"topleftsummation";
+0x8b2,"botleftsummation";
+0x8b3,"topvertsummationconnector";
+0x8b4,"botvertsummationconnector";
+0x8b5,"toprightsummation";
+0x8b6,"botrightsummation";
+0x8b7,"rightmiddlesummation";
+0x8bc,"lessthanequal";
+0x8bd,"notequal";
+0x8be,"greaterthanequal";
+0x8bf,"integral";
+0x8c0,"therefore";
+0x8c1,"variation";
+0x8c2,"infinity";
+0x8c5,"nabla";
+0x8c8,"approximate";
+0x8c9,"similarequal";
+0x8cd,"ifonlyif";
+0x8ce,"implies";
+0x8cf,"identical";
+0x8d6,"radical";
+0x8da,"includedin";
+0x8db,"includes";
+0x8dc,"intersection";
+0x8dd,"union";
+0x8de,"logicaland";
+0x8df,"logicalor";
+0x8ef,"partialderivative";
+0x8f6,"function";
+0x8fb,"leftarrow";
+0x8fc,"uparrow";
+0x8fd,"rightarrow";
+0x8fe,"downarrow";
+0x9df,"blank";
+0x9e0,"soliddiamond";
+0x9e1,"checkerboard";
+0x9e2,"ht";
+0x9e3,"ff";
+0x9e4,"cr";
+0x9e5,"lf";
+0x9e8,"nl";
+0x9e9,"vt";
+0x9ea,"lowrightcorner";
+0x9eb,"uprightcorner";
+0x9ec,"upleftcorner";
+0x9ed,"lowleftcorner";
+0x9ee,"crossinglines";
+0x9ef,"horizlinescan1";
+0x9f0,"horizlinescan3";
+0x9f1,"horizlinescan5";
+0x9f2,"horizlinescan7";
+0x9f3,"horizlinescan9";
+0x9f4,"leftt";
+0x9f5,"rightt";
+0x9f6,"bott";
+0x9f7,"topt";
+0x9f8,"vertbar";
+0xaa1,"emspace";
+0xaa2,"enspace";
+0xaa3,"em3space";
+0xaa4,"em4space";
+0xaa5,"digitspace";
+0xaa6,"punctspace";
+0xaa7,"thinspace";
+0xaa8,"hairspace";
+0xaa9,"emdash";
+0xaaa,"endash";
+0xaac,"signifblank";
+0xaae,"ellipsis";
+0xaaf,"doubbaselinedot";
+0xab0,"onethird";
+0xab1,"twothirds";
+0xab2,"onefifth";
+0xab3,"twofifths";
+0xab4,"threefifths";
+0xab5,"fourfifths";
+0xab6,"onesixth";
+0xab7,"fivesixths";
+0xab8,"careof";
+0xabb,"figdash";
+0xabc,"leftanglebracket";
+0xabd,"decimalpoint";
+0xabe,"rightanglebracket";
+0xabf,"marker";
+0xac3,"oneeighth";
+0xac4,"threeeighths";
+0xac5,"fiveeighths";
+0xac6,"seveneighths";
+0xac9,"trademark";
+0xaca,"signaturemark";
+0xacb,"trademarkincircle";
+0xacc,"leftopentriangle";
+0xacd,"rightopentriangle";
+0xace,"emopencircle";
+0xacf,"emopenrectangle";
+0xad0,"leftsinglequotemark";
+0xad1,"rightsinglequotemark";
+0xad2,"leftdoublequotemark";
+0xad3,"rightdoublequotemark";
+0xad4,"prescription";
+0xad6,"minutes";
+0xad7,"seconds";
+0xad9,"latincross";
+0xada,"hexagram";
+0xadb,"filledrectbullet";
+0xadc,"filledlefttribullet";
+0xadd,"filledrighttribullet";
+0xade,"emfilledcircle";
+0xadf,"emfilledrect";
+0xae0,"enopencircbullet";
+0xae1,"enopensquarebullet";
+0xae2,"openrectbullet";
+0xae3,"opentribulletup";
+0xae4,"opentribulletdown";
+0xae5,"openstar";
+0xae6,"enfilledcircbullet";
+0xae7,"enfilledsqbullet";
+0xae8,"filledtribulletup";
+0xae9,"filledtribulletdown";
+0xaea,"leftpointer";
+0xaeb,"rightpointer";
+0xaec,"club";
+0xaed,"diamond";
+0xaee,"heart";
+0xaf0,"maltesecross";
+0xaf1,"dagger";
+0xaf2,"doubledagger";
+0xaf3,"checkmark";
+0xaf4,"ballotcross";
+0xaf5,"musicalsharp";
+0xaf6,"musicalflat";
+0xaf7,"malesymbol";
+0xaf8,"femalesymbol";
+0xaf9,"telephone";
+0xafa,"telephonerecorder";
+0xafb,"phonographcopyright";
+0xafc,"caret";
+0xafd,"singlelowquotemark";
+0xafe,"doublelowquotemark";
+0xaff,"cursor";
+0xba3,"leftcaret";
+0xba6,"rightcaret";
+0xba8,"downcaret";
+0xba9,"upcaret";
+0xbc0,"overbar";
+0xbc2,"downtack";
+0xbc3,"upshoe";
+0xbc4,"downstile";
+0xbc6,"underbar";
+0xbca,"jot";
+0xbcc,"quad";
+0xbce,"uptack";
+0xbcf,"circle";
+0xbd3,"upstile";
+0xbd6,"downshoe";
+0xbd8,"rightshoe";
+0xbda,"leftshoe";
+0xbdc,"lefttack";
+0xbfc,"righttack";
+0xcdf,"hebrew_doublelowline";
+0xce0,"hebrew_aleph";
+0xce1,"hebrew_bet";
+0xce1,"hebrew_beth";
+0xce2,"hebrew_gimel";
+0xce2,"hebrew_gimmel";
+0xce3,"hebrew_dalet";
+0xce3,"hebrew_daleth";
+0xce4,"hebrew_he";
+0xce5,"hebrew_waw";
+0xce6,"hebrew_zain";
+0xce6,"hebrew_zayin";
+0xce7,"hebrew_chet";
+0xce7,"hebrew_het";
+0xce8,"hebrew_tet";
+0xce8,"hebrew_teth";
+0xce9,"hebrew_yod";
+0xcea,"hebrew_finalkaph";
+0xceb,"hebrew_kaph";
+0xcec,"hebrew_lamed";
+0xced,"hebrew_finalmem";
+0xcee,"hebrew_mem";
+0xcef,"hebrew_finalnun";
+0xcf0,"hebrew_nun";
+0xcf1,"hebrew_samech";
+0xcf1,"hebrew_samekh";
+0xcf2,"hebrew_ayin";
+0xcf3,"hebrew_finalpe";
+0xcf4,"hebrew_pe";
+0xcf5,"hebrew_finalzade";
+0xcf5,"hebrew_finalzadi";
+0xcf6,"hebrew_zade";
+0xcf6,"hebrew_zadi";
+0xcf7,"hebrew_qoph";
+0xcf7,"hebrew_kuf";
+0xcf8,"hebrew_resh";
+0xcf9,"hebrew_shin";
+0xcfa,"hebrew_taw";
+0xcfa,"hebrew_taf";
+0xFF7E,"Hebrew_switch";
+0xda1,"Thai_kokai";
+0xda2,"Thai_khokhai";
+0xda3,"Thai_khokhuat";
+0xda4,"Thai_khokhwai";
+0xda5,"Thai_khokhon";
+0xda6,"Thai_khorakhang";
+0xda7,"Thai_ngongu";
+0xda8,"Thai_chochan";
+0xda9,"Thai_choching";
+0xdaa,"Thai_chochang";
+0xdab,"Thai_soso";
+0xdac,"Thai_chochoe";
+0xdad,"Thai_yoying";
+0xdae,"Thai_dochada";
+0xdaf,"Thai_topatak";
+0xdb0,"Thai_thothan";
+0xdb1,"Thai_thonangmontho";
+0xdb2,"Thai_thophuthao";
+0xdb3,"Thai_nonen";
+0xdb4,"Thai_dodek";
+0xdb5,"Thai_totao";
+0xdb6,"Thai_thothung";
+0xdb7,"Thai_thothahan";
+0xdb8,"Thai_thothong";
+0xdb9,"Thai_nonu";
+0xdba,"Thai_bobaimai";
+0xdbb,"Thai_popla";
+0xdbc,"Thai_phophung";
+0xdbd,"Thai_fofa";
+0xdbe,"Thai_phophan";
+0xdbf,"Thai_fofan";
+0xdc0,"Thai_phosamphao";
+0xdc1,"Thai_moma";
+0xdc2,"Thai_yoyak";
+0xdc3,"Thai_rorua";
+0xdc4,"Thai_ru";
+0xdc5,"Thai_loling";
+0xdc6,"Thai_lu";
+0xdc7,"Thai_wowaen";
+0xdc8,"Thai_sosala";
+0xdc9,"Thai_sorusi";
+0xdca,"Thai_sosua";
+0xdcb,"Thai_hohip";
+0xdcc,"Thai_lochula";
+0xdcd,"Thai_oang";
+0xdce,"Thai_honokhuk";
+0xdcf,"Thai_paiyannoi";
+0xdd0,"Thai_saraa";
+0xdd1,"Thai_maihanakat";
+0xdd2,"Thai_saraaa";
+0xdd3,"Thai_saraam";
+0xdd4,"Thai_sarai";
+0xdd5,"Thai_saraii";
+0xdd6,"Thai_saraue";
+0xdd7,"Thai_sarauee";
+0xdd8,"Thai_sarau";
+0xdd9,"Thai_sarauu";
+0xdda,"Thai_phinthu";
+0xdde,"Thai_maihanakat_maitho";
+0xddf,"Thai_baht";
+0xde0,"Thai_sarae";
+0xde1,"Thai_saraae";
+0xde2,"Thai_sarao";
+0xde3,"Thai_saraaimaimuan";
+0xde4,"Thai_saraaimaimalai";
+0xde5,"Thai_lakkhangyao";
+0xde6,"Thai_maiyamok";
+0xde7,"Thai_maitaikhu";
+0xde8,"Thai_maiek";
+0xde9,"Thai_maitho";
+0xdea,"Thai_maitri";
+0xdeb,"Thai_maichattawa";
+0xdec,"Thai_thanthakhat";
+0xded,"Thai_nikhahit";
+0xdf0,"Thai_leksun";
+0xdf1,"Thai_leknung";
+0xdf2,"Thai_leksong";
+0xdf3,"Thai_leksam";
+0xdf4,"Thai_leksi";
+0xdf5,"Thai_lekha";
+0xdf6,"Thai_lekhok";
+0xdf7,"Thai_lekchet";
+0xdf8,"Thai_lekpaet";
+0xdf9,"Thai_lekkao";
+0xff31,"Hangul";
+0xff32,"Hangul_Start";
+0xff33,"Hangul_End";
+0xff34,"Hangul_Hanja";
+0xff35,"Hangul_Jamo";
+0xff36,"Hangul_Romaja";
+0xff37,"Hangul_Codeinput";
+0xff38,"Hangul_Jeonja";
+0xff39,"Hangul_Banja";
+0xff3a,"Hangul_PreHanja";
+0xff3b,"Hangul_PostHanja";
+0xff3c,"Hangul_SingleCandidate";
+0xff3d,"Hangul_MultipleCandidate";
+0xff3e,"Hangul_PreviousCandidate";
+0xff3f,"Hangul_Special";
+0xFF7E,"Hangul_switch";
+0xea1,"Hangul_Kiyeog";
+0xea2,"Hangul_SsangKiyeog";
+0xea3,"Hangul_KiyeogSios";
+0xea4,"Hangul_Nieun";
+0xea5,"Hangul_NieunJieuj";
+0xea6,"Hangul_NieunHieuh";
+0xea7,"Hangul_Dikeud";
+0xea8,"Hangul_SsangDikeud";
+0xea9,"Hangul_Rieul";
+0xeaa,"Hangul_RieulKiyeog";
+0xeab,"Hangul_RieulMieum";
+0xeac,"Hangul_RieulPieub";
+0xead,"Hangul_RieulSios";
+0xeae,"Hangul_RieulTieut";
+0xeaf,"Hangul_RieulPhieuf";
+0xeb0,"Hangul_RieulHieuh";
+0xeb1,"Hangul_Mieum";
+0xeb2,"Hangul_Pieub";
+0xeb3,"Hangul_SsangPieub";
+0xeb4,"Hangul_PieubSios";
+0xeb5,"Hangul_Sios";
+0xeb6,"Hangul_SsangSios";
+0xeb7,"Hangul_Ieung";
+0xeb8,"Hangul_Jieuj";
+0xeb9,"Hangul_SsangJieuj";
+0xeba,"Hangul_Cieuc";
+0xebb,"Hangul_Khieuq";
+0xebc,"Hangul_Tieut";
+0xebd,"Hangul_Phieuf";
+0xebe,"Hangul_Hieuh";
+0xebf,"Hangul_A";
+0xec0,"Hangul_AE";
+0xec1,"Hangul_YA";
+0xec2,"Hangul_YAE";
+0xec3,"Hangul_EO";
+0xec4,"Hangul_E";
+0xec5,"Hangul_YEO";
+0xec6,"Hangul_YE";
+0xec7,"Hangul_O";
+0xec8,"Hangul_WA";
+0xec9,"Hangul_WAE";
+0xeca,"Hangul_OE";
+0xecb,"Hangul_YO";
+0xecc,"Hangul_U";
+0xecd,"Hangul_WEO";
+0xece,"Hangul_WE";
+0xecf,"Hangul_WI";
+0xed0,"Hangul_YU";
+0xed1,"Hangul_EU";
+0xed2,"Hangul_YI";
+0xed3,"Hangul_I";
+0xed4,"Hangul_J_Kiyeog";
+0xed5,"Hangul_J_SsangKiyeog";
+0xed6,"Hangul_J_KiyeogSios";
+0xed7,"Hangul_J_Nieun";
+0xed8,"Hangul_J_NieunJieuj";
+0xed9,"Hangul_J_NieunHieuh";
+0xeda,"Hangul_J_Dikeud";
+0xedb,"Hangul_J_Rieul";
+0xedc,"Hangul_J_RieulKiyeog";
+0xedd,"Hangul_J_RieulMieum";
+0xede,"Hangul_J_RieulPieub";
+0xedf,"Hangul_J_RieulSios";
+0xee0,"Hangul_J_RieulTieut";
+0xee1,"Hangul_J_RieulPhieuf";
+0xee2,"Hangul_J_RieulHieuh";
+0xee3,"Hangul_J_Mieum";
+0xee4,"Hangul_J_Pieub";
+0xee5,"Hangul_J_PieubSios";
+0xee6,"Hangul_J_Sios";
+0xee7,"Hangul_J_SsangSios";
+0xee8,"Hangul_J_Ieung";
+0xee9,"Hangul_J_Jieuj";
+0xeea,"Hangul_J_Cieuc";
+0xeeb,"Hangul_J_Khieuq";
+0xeec,"Hangul_J_Tieut";
+0xeed,"Hangul_J_Phieuf";
+0xeee,"Hangul_J_Hieuh";
+0xeef,"Hangul_RieulYeorinHieuh";
+0xef0,"Hangul_SunkyeongeumMieum";
+0xef1,"Hangul_SunkyeongeumPieub";
+0xef2,"Hangul_PanSios";
+0xef3,"Hangul_KkogjiDalrinIeung";
+0xef4,"Hangul_SunkyeongeumPhieuf";
+0xef5,"Hangul_YeorinHieuh";
+0xef6,"Hangul_AraeA";
+0xef7,"Hangul_AraeAE";
+0xef8,"Hangul_J_PanSios";
+0xef9,"Hangul_J_KkogjiDalrinIeung";
+0xefa,"Hangul_J_YeorinHieuh";
+0xeff,"Korean_Won";
+]
diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml
new file mode 100644
index 00000000..a6085138
--- /dev/null
+++ b/ide/utils/configwin_messages.ml
@@ -0,0 +1,51 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+(** Module containing the messages of Configwin.*)
+
+let software = "Configwin";;
+let version = "1.3";;
+
+let html_config = "Configwin bindings configurator for html parameters"
+
+let home =
+  try Sys.getenv "HOME"
+  with Not_found -> ""
+
+let mCapture = "Capture";;
+let mType_key = "Type key" ;;
+let mAdd = "Add";;
+let mRemove = "Remove";;
+let mUp = "Up";;
+let mEdit = "Edit";;
+let mOk = "Ok";;
+let mCancel = "Cancel";;
+let mApply = "Apply";;
+let mValue = "Value"
+let mKey = "Key"
+
+let shortcuts = "Shortcuts"
+let html_end = "End with"
+let html_begin = "Begin with"
+
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
new file mode 100644
index 00000000..ee8ec70c
--- /dev/null
+++ b/ide/utils/configwin_types.ml
@@ -0,0 +1,299 @@
+(**************************************************************************)
+(*                   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 types used in Configwin. *)
+
+open Uoptions
+
+(** 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 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
+
+(** This type represents a string or filename parameter. *)
+type string_param = {
+    string_label : string; (** the label of the parameter *)
+    mutable string_value : string; (** 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_help : string option ; (** optional help string *)
+    string_expand : bool ; (** expand or not *)
+  } ;;
+
+(** This type represents a boolean parameter. *)
+type bool_param = {
+    bool_label : string; (** the label of the parameter *)
+    mutable bool_value : bool; (** the current value of the parameter *)
+    bool_editable : bool ; (** indicates if the value can be changed *)
+    bool_f_apply : (bool -> unit) ; (** the function to call to apply the new value of the parameter *)
+    bool_help : string option ; (** optional help string *)
+  } ;;
+
+(** This type represents a parameter whose value is a list of ['a]. *)
+type 'a list_param = {
+    list_label : string; (** the label of the parameter *)
+    mutable list_value : 'a list; (** the current value of the parameter *)
+    list_titles : string list option; (** the titles of columns, if they must be displayed *)
+    list_f_edit : ('a -> 'a) option; (** optional edition function *)
+    list_eq : ('a -> 'a -> bool) ; (** the comparison function used to get list without doubles *)
+    list_strings : ('a -> string list); (** the function to get a string list from a ['a]. *)
+    list_color : ('a -> string option) ; (** a function to get the optional color of an element *)
+    list_editable : bool ; (** indicates if the value can be changed *)
+    list_f_add : unit -> 'a list ; (** the function to call to add list *)
+    list_f_apply : ('a list -> unit) ; (** the function to call to apply the new value of the parameter *)
+    list_help : string option ; (** optional help string *)
+  } ;;
+
+type combo_param = {
+    combo_label : string ;
+    mutable combo_value : string ;
+    combo_choices : string list ;
+    combo_editable : bool ;
+    combo_blank_allowed : bool ;
+    combo_new_allowed : bool ;
+    combo_f_apply : (string -> unit);
+    combo_help : string option ; (** optional help string *)
+    combo_expand : bool ; (** expand the entry widget or not *)
+  } ;;
+
+type custom_param = {
+    custom_box : GPack.box ;
+    custom_f_apply : (unit -> unit) ;
+    custom_expand : bool ;
+    custom_framed : string option ; (** optional label for an optional frame *)
+  } ;;
+
+type color_param = {
+    color_label : string; (** the label of the parameter *)
+    mutable color_value : string; (** the current value of the parameter *)
+    color_editable : bool ; (** indicates if the value can be changed *)
+    color_f_apply : (string -> unit) ; (** the function to call to apply the new value of the parameter *)
+    color_help : string option ; (** optional help string *)
+    color_expand : bool ; (** expand the entry widget or not *)
+  } ;;
+
+type date_param = {
+    date_label : string ; (** the label of the parameter *)
+    mutable date_value : int * int * int ; (** day, month, year *)
+    date_editable : bool ; (** indicates if the value can be changed *)
+    date_f_string : (int * int * int) -> string ;
+      (** the function used to display the current value (day, month, year) *)
+    date_f_apply : ((int * int * int) -> unit) ;
+      (** the function to call to apply the new value (day, month, year) of the parameter *)
+    date_help : string option ; (** optional help string *)
+    date_expand : bool ; (** expand the entry widget or not *)
+  } ;;
+
+type font_param = {
+    font_label : string ; (** the label of the parameter *)
+    mutable font_value : string ; (** the font name *)
+    font_editable : bool ; (** indicates if the value can be changed *)
+    font_f_apply : (string -> unit) ;
+      (** the function to call to apply the new value of the parameter *)
+    font_help : string option ; (** optional help string *)
+    font_expand : bool ; (** expand the entry widget or not *)
+  } ;;
+
+
+type hotkey_param = {
+    hk_label : string ; (** the label of the parameter *)
+    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 *)
+    mutable md_value : Gdk.Tags.modifier list ; 
+             (** The value, as a list of modifiers and a key code *)
+    md_editable : bool ; (** indicates if the value can be changed *)
+    md_f_apply : Gdk.Tags.modifier list -> unit ;
+             (** the function to call to apply the new value of the paramter *)
+    md_help : string option ; (** optional help string *)
+    md_expand : bool ; (** expand or not *)
+    md_allow : Gdk.Tags.modifier list
+  } 
+
+(** 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
+  | Bool_param of bool_param
+  | Text_param of string_param
+  | Combo_param of combo_param
+  | Custom_param of custom_param
+  | Color_param of color_param
+  | Date_param of date_param
+  | Font_param of font_param
+  | Hotkey_param of hotkey_param
+  | Modifiers_param of modifiers_param
+  | Html_param of string_param
+;;
+
+(** This type represents the structure of the configuration window. *)
+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 *)
+;;
+
+(** To indicate what button was pushed by the user when the window is closed. *)
+type return_button =
+    Return_apply (** The user clicked on Apply at least once before
+	     closing the window with Cancel or the window manager. *)
+  | Return_ok (** The user closed the window with the ok button. *)
+  | Return_cancel (** The user closed the window with the cancel
+		     button or the window manager but never clicked
+		     on the apply button.*)
+
+(** {2 Bindings in the html editor} *)
+
+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 (t : html_binding option_class) =
+    define_option_class "html_binding" value_to_hb hb_to_value
+end
diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml
new file mode 100644
index 00000000..e6d2f4d4
--- /dev/null
+++ b/ide/utils/editable_cells.ml
@@ -0,0 +1,114 @@
+open GTree
+open Gobject
+
+let create l = 
+  let hbox = GPack.hbox () in
+  let scw = GBin.scrolled_window 
+	      ~hpolicy:`AUTOMATIC 
+	      ~vpolicy:`AUTOMATIC 
+	      ~packing:(hbox#pack ~expand:true) () in
+
+  let columns = new GTree.column_list in
+  let command_col =  columns#add Data.string in
+  let coq_col = columns#add Data.string in
+  let store = GTree.list_store columns
+  in 
+
+(* populate the store *)
+  let _ = List.iter (fun (x,y) -> 
+		       let row = store#append () in
+		       store#set ~row ~column:command_col x;
+		       store#set ~row ~column:coq_col y)
+	    l
+  in
+  let view = GTree.view ~model:store ~packing:scw#add_with_viewport () in
+
+  (* Alternate colors for the rows *)
+  view#set_rules_hint true;
+
+  let renderer_comm = GTree.cell_renderer_text [`EDITABLE true]  in
+  ignore (renderer_comm#connect#edited 
+    ~callback:(fun (path:Gtk.tree_path) (s:string) -> 
+		 store#set 
+		 ~row:(store#get_iter path) 
+		 ~column:command_col s));
+  let first = 
+    GTree.view_column ~title:"Coq Command to try" 
+      ~renderer:(renderer_comm,["text",command_col]) 
+      () 
+  in ignore (view#append_column first);
+
+  let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in
+  ignore(renderer_coq#connect#edited
+	   ~callback:(fun (path:Gtk.tree_path) (s:string) -> 
+			store#set 
+			~row:(store#get_iter path) 
+			~column:coq_col s));
+  let second = 
+    GTree.view_column ~title:"Coq Command to insert" 
+      ~renderer:(renderer_coq,["text",coq_col]) 
+      () 
+  in ignore (view#append_column second);
+
+  let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () 
+  in
+  let up = GButton.button  ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in
+  let down = GButton.button 
+	       ~stock:`GO_DOWN 
+	       ~label:"Down" 
+	       ~packing:(vbox#pack ~expand:true ~fill:false) () 
+  in
+  let add = GButton.button ~stock:`ADD 
+	      ~label:"Add" 
+	      ~packing:(vbox#pack ~expand:true ~fill:false) 
+	      () 
+  in
+  let remove = GButton.button ~stock:`REMOVE 
+		 ~label:"Remove" 
+		 ~packing:(vbox#pack ~expand:true ~fill:false) () 
+  in
+
+  ignore (add#connect#clicked 
+	    ~callback:(fun b ->  
+			 let n = store#append () in
+			 view#selection#select_iter n));
+  ignore (remove#connect#clicked 
+	    ~callback:(fun b -> match view#selection#get_selected_rows with 
+			 | [] -> ()
+			 | path::_ ->
+			     let iter = store#get_iter path in
+		       	     ignore (store#remove iter);
+		      ));
+  ignore (up#connect#clicked 
+	    ~callback:(fun b ->  
+			 match view#selection#get_selected_rows with 
+			   | [] -> ()
+			   | path::_ ->
+			       let iter = store#get_iter path in
+			       GtkTree.TreePath.prev path;
+			       let upiter = store#get_iter path in
+			       ignore (store#swap iter upiter);
+		      ));
+  ignore (down#connect#clicked 
+	    ~callback:(fun b ->  
+			 match view#selection#get_selected_rows with 
+			   | [] -> ()
+			   | path::_ ->
+			       let iter = store#get_iter path in
+			       GtkTree.TreePath.next path;
+			       try let upiter = store#get_iter path in
+			       ignore (store#swap iter upiter)
+			       with _ -> ()
+		      ));
+  let get_data () = 
+    let start_path = GtkTree.TreePath.from_string "0" in
+    let start_iter = store#get_iter start_path in
+    let rec all acc = 
+      let new_acc = (store#get ~row:start_iter ~column:command_col,
+		     store#get ~row:start_iter ~column:coq_col)::acc
+      in      
+      if store#iter_next start_iter then all new_acc else List.rev new_acc
+    in all []
+  in
+  (hbox,get_data)
+
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
new file mode 100644
index 00000000..17e371f5
--- /dev/null
+++ b/ide/utils/okey.ml
@@ -0,0 +1,185 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+type modifier = Gdk.Tags.modifier
+
+type handler = {
+    cond : (unit -> bool) ;
+    cback : (unit -> unit) ;
+  } 
+
+type handler_spec = int * int * Gdk.keysym
+      (** mods * mask * key *)
+
+let int_of_modifier = function
+    `SHIFT -> 1
+  | `LOCK -> 2
+  | `CONTROL -> 4
+  | `MOD1 -> 8
+  | `MOD2 -> 16
+  | `MOD3 -> 32
+  | `MOD4 -> 64
+  | `MOD5 -> 128
+  | `BUTTON1 -> 256
+  | `BUTTON2 -> 512
+  | `BUTTON3 -> 1024
+  | `BUTTON4 -> 2048
+  | `BUTTON5 -> 4096
+
+let print_modifier l =
+  List.iter
+    (fun m -> 
+      print_string
+	(((function 
+	    `SHIFT -> "SHIFT"
+	  | `LOCK -> "LOCK"
+	  | `CONTROL -> "CONTROL"
+	  | `MOD1 -> "MOD1"
+	  | `MOD2 -> "MOD2"
+	  | `MOD3 -> "MOD3"
+	  | `MOD4 -> "MOD4"
+	  | `MOD5 -> "MOD5"
+	  | `BUTTON1 -> "B1"
+	  | `BUTTON2 -> "B2"
+	  | `BUTTON3 -> "B3"
+	  | `BUTTON4 -> "B4"
+	  | `BUTTON5 -> "B5")
+	    m)^" ")
+    )
+    l;
+  print_newline ()
+  
+let int_of_modifiers l =
+  List.fold_left (fun acc -> fun m -> acc + (int_of_modifier m)) 0 l
+
+module H = 
+  struct
+    type t = handler_spec * handler
+    let equal (m,k) (mods, mask, key) =
+      (k = key) && ((m land mask) = mods)
+
+    let filter_with_mask mods mask key l =
+      List.filter (fun a -> (fst a) <> (mods, mask, key)) l
+
+    let find_handlers mods key l =
+      List.map snd
+        (List.filter
+	   (fun ((m,ma,k),_) -> equal (mods,key) (m,ma,k)) 
+	   l
+	)
+
+  end
+
+let (table : (int, H.t list ref) Hashtbl.t) = Hashtbl.create 13
+
+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 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
+  with
+    Not_found ->
+      true
+
+let associate_key_press w = 
+  ignore ((w#event#connect#key_press ~callback: (key_press w)) : GtkSignal.id)
+
+let default_modifiers = ref ([] : modifier list)
+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
+    r := []
+  with 
+    Not_found ->
+      ()
+
+let add1 ?(remove=false) w
+    ?(cond=(fun () -> true)) 
+    ?(mods= !default_modifiers)
+    ?(mask= !default_mask)
+    k callback =
+  let r =
+    try Hashtbl.find table w#get_oid
+    with Not_found -> 
+      let r = ref [] in
+      Hashtbl.add table w#get_oid r;
+      ignore (w#connect#destroy ~callback: (remove_widget w));
+      associate_key_press w;
+      r
+  in
+  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 
+    (
+     let l = H.filter_with_mask n_mods n_mask k !r in
+     r := ((n_mods, n_mask, k), new_h) :: l
+    )
+  else
+    r := ((n_mods, n_mask, k), new_h) :: !r
+
+let add w
+    ?(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)) 
+    ?(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)) 
+    ?(mods= !default_modifiers)
+    ?(mask= !default_mask)
+    k callback =
+  add1 ~remove: true w ~cond ~mods ~mask k callback
+
+let set_list w
+    ?(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
new file mode 100644
index 00000000..a0effe72
--- /dev/null
+++ b/ide/utils/okey.mli
@@ -0,0 +1,114 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+(** Okey interface. 
+
+   Once the lib is compiled and installed, you can use it by referencing
+   it with the [Okey] module. You must add [okey.cmo] or [okey.cmx]
+   on the commande line when you link.
+*)
+
+type modifier = Gdk.Tags.modifier
+
+(** Set the default modifier list. The first default value is [[]].*)
+val set_default_modifiers : modifier list -> unit
+
+(** Set the default modifier mask. The first default value is 
+   [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]].
+   The mask defines the modifiers not taken into account
+   when looking for the handler of a key press event.
+*)
+val set_default_mask : modifier list -> unit
+
+(** [add widget key callback] associates the [callback] function to the event
+   "key_press" with the given [key] for the given [widget].
+
+   @param remove when true, the previous handlers for the given key and modifier
+   list are not kept.
+   @param cond this function is a guard: the [callback] function is not called
+   if the [cond] function returns [false]. 
+   The default [cond] function always returns [true].
+
+   @param mods the list of modifiers. If not given, the default modifiers
+   are used. 
+   You can set the default modifiers with function {!Okey.set_default_modifiers}.
+
+   @param mask the list of modifiers which must not be taken
+   into account to trigger the given handler. [mods]
+   and [mask] must not have common modifiers. If not given, the default mask
+   is used. 
+   You can set the default modifiers mask with function {!Okey.set_default_mask}.
+*)
+val add :
+    < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
+      event : GObj.event_ops; get_oid : int; .. > -> 
+	?cond: (unit -> bool) -> 
+	  ?mods: modifier list -> 
+	    ?mask: modifier list -> 
+	      Gdk.keysym -> 
+		(unit -> unit) -> 
+		  unit
+
+(** It calls {!Okey.add} for each given key.*)
+val add_list : 
+    < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
+      event : GObj.event_ops; get_oid : int; .. > -> 
+	?cond: (unit -> bool) -> 
+	  ?mods: modifier list -> 
+	    ?mask: modifier list -> 
+	      Gdk.keysym list -> 
+		(unit -> unit) -> 
+		  unit
+	      
+(** Like {!Okey.add} but the previous handlers for the
+   given modifiers and key are not kept.*)
+val set :
+    < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
+      event : GObj.event_ops; get_oid : int; .. > -> 
+	?cond: (unit -> bool) -> 
+	  ?mods: modifier list -> 
+	    ?mask: modifier list -> 
+	      Gdk.keysym -> 
+		(unit -> unit) -> 
+		  unit
+
+(** It calls {!Okey.set} for each given key.*)
+val set_list : 
+    < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
+      event : GObj.event_ops; get_oid : int; .. > ->
+	?cond: (unit -> bool) -> 
+	  ?mods: modifier list -> 
+	    ?mask: modifier list -> 
+	      Gdk.keysym list -> 
+		(unit -> unit) -> 
+		  unit
+
+(** Remove the handlers associated to the given widget.
+   This is automatically done when a widget is destroyed but
+   you can do it yourself. *)
+val remove_widget : 
+    < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >;
+      event : GObj.event_ops; get_oid : int; .. > ->
+	unit ->
+	  unit
diff --git a/ide/utils/uoptions.ml b/ide/utils/uoptions.ml
new file mode 100644
index 00000000..416f5769
--- /dev/null
+++ b/ide/utils/uoptions.ml
@@ -0,0 +1,772 @@
+(**************************************************************************)
+(*                   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                                *)
+(**************************************************************************)
+
+(** Simple options:
+  This will enable very simple configuration, by a mouse-based configurator.
+  Options will be defined by a special function, which will also check
+  if a value has been provided  by the user in its .gwmlrc file.
+  The .gwmlrc will be created by a dedicated tool, which could be used
+  to generate both .gwmlrc and .efunsrc files.
+
+Note: this is redundant, since such options could also be better set
+in the .Xdefaults file (using Xrm to load them). Maybe we should merge
+both approaches in a latter release.
+  
+   Code from Fabrice Le Fessant.
+
+    *)
+  
+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
+;;
+
+
+
+type 'a option_class =
+  { class_name : string;
+    from_value : option_value -> 'a;
+    to_value : 'a -> option_value;
+    mutable class_hooks : ('a option_record -> unit) list }
+  
+and 'a option_record =
+  { option_name : string list;
+    option_class : 'a option_class;
+    mutable option_value : 'a;
+    option_help : string;
+    mutable option_hooks : (unit -> unit) list;
+    mutable string_wrappers : (('a -> string) * (string -> 'a)) option;
+    option_file : options_file;
+  }
+  
+and options_file = {
+    mutable file_name : string; 
+    mutable file_options : Obj.t option_record list;
+    mutable file_rc : option_module;
+    mutable file_pruned : bool;
+  }
+;;
+
+let create_options_file name =
+  ignore
+    (
+     if not (Sys.file_exists name) then
+       let oc = open_out name in 
+       close_out oc
+    );
+  {
+    file_name = name;
+    file_options =[];
+    file_rc = [];
+    file_pruned = false;
+  }
+  
+let set_options_file opfile name = opfile.file_name <- name
+
+let
+  define_option_class
+    (class_name : string)
+    (from_value : option_value -> 'a)
+    (to_value : 'a -> option_value) =
+  let c =
+    {class_name = class_name; 
+      from_value = from_value; 
+      to_value = to_value;
+     class_hooks = []}
+  in
+  c
+;;  
+
+(*
+let filename =
+  ref
+    (Filename.concat Sysenv.home
+       ("." ^ Filename.basename Sys.argv.(0) ^ "rc"))
+;;
+let gwmlrc = ref [];;
+
+let options = ref [];;
+*)
+
+let rec find_value list m =
+  match list with
+    [] -> raise Not_found
+  | name :: tail ->
+      let m = List.assoc name m in
+      match m, tail with
+        _, [] -> m
+      | Module m, _ :: _ -> find_value tail m
+      | _ -> raise Not_found
+;;
+
+let prune_file file =
+  file.file_pruned <- true
+
+let
+  define_option
+    (opfile : options_file)
+    (option_name : string list)
+    (option_help : string)
+    (option_class : 'a option_class)
+    (default_value : 'a) =
+  let o =
+    {option_name = option_name; 
+      option_help = option_help;
+      option_class = option_class; 
+      option_value = default_value;
+      string_wrappers = None;
+      option_hooks = []; 
+      option_file = opfile; }
+  in
+  opfile.file_options <- (Obj.magic o : Obj.t option_record) ::
+    opfile.file_options;
+  o.option_value <-
+    begin try o.option_class.from_value (find_value option_name 
+        opfile.file_rc) with
+      Not_found -> default_value
+    | e ->
+        Printf.printf "Options.define_option, for option %s: "
+          (match option_name with
+             [] -> "???"
+           | name :: _ -> name);
+        Printf.printf "%s" (Printexc.to_string e);
+        print_newline ();
+        default_value
+    end;
+  o
+;;
+
+  
+open Genlex;;
+  
+let lexer = make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","; "."];;
+  
+let rec parse_gwmlrc (strm__ : _ Stream.t) =
+  match
+    try Some (parse_id strm__) with
+      Stream.Failure -> None
+  with
+    Some id ->
+      begin match Stream.peek strm__ with
+        Some (Kwd "=") ->
+          Stream.junk strm__;
+          let v =
+            try parse_option strm__ with
+              Stream.Failure -> raise (Stream.Error "")
+          in
+          let eof =
+            try parse_gwmlrc strm__ with
+              Stream.Failure -> raise (Stream.Error "")
+          in
+          (id, v) :: eof
+      | _ -> raise (Stream.Error "")
+      end
+  | _ -> []
+and parse_option (strm__ : _ Stream.t) =
+  match Stream.peek strm__ with
+    Some (Kwd "{") ->
+      Stream.junk strm__;
+      let v =
+        try parse_gwmlrc strm__ with
+          Stream.Failure -> raise (Stream.Error "")
+      in
+      begin match Stream.peek strm__ with
+        Some (Kwd "}") -> Stream.junk strm__; Module v
+      | _ -> raise (Stream.Error "")
+      end
+  | Some (Ident s) -> Stream.junk strm__; StringValue s
+  | Some (String s) -> Stream.junk strm__; StringValue s
+  | Some (Int i) -> Stream.junk strm__; IntValue i
+  | Some (Float f) -> Stream.junk strm__; FloatValue f
+  | Some (Char c) ->
+      Stream.junk strm__;
+      StringValue (let s = String.create 1 in s.[0] <- c; s)
+  | Some (Kwd "[") ->
+      Stream.junk strm__;
+      let v =
+        try parse_list strm__ with
+          Stream.Failure -> raise (Stream.Error "")
+      in
+      List v
+  | Some (Kwd "(") ->
+      Stream.junk strm__;
+      let v =
+        try parse_list strm__ with
+          Stream.Failure -> raise (Stream.Error "")
+      in
+      List v
+  | _ -> raise Stream.Failure
+and parse_id (strm__ : _ Stream.t) =
+  match Stream.peek strm__ with
+    Some (Ident s) -> Stream.junk strm__; s
+  | Some (String s) -> Stream.junk strm__; s
+  | _ -> raise Stream.Failure
+and parse_list (strm__ : _ Stream.t) =
+  match Stream.peek strm__ with
+    Some (Kwd ";") ->
+      Stream.junk strm__;
+      begin try parse_list strm__ with
+        Stream.Failure -> raise (Stream.Error "")
+      end
+  | Some (Kwd ",") ->
+      Stream.junk strm__;
+      begin try parse_list strm__ with
+        Stream.Failure -> raise (Stream.Error "")
+      end
+  | Some (Kwd ".") ->
+      Stream.junk strm__;
+      begin try parse_list strm__ with
+        Stream.Failure -> raise (Stream.Error "")
+      end
+  | _ ->
+      match
+        try Some (parse_option strm__) with
+          Stream.Failure -> None
+      with
+        Some v ->
+          let t =
+            try parse_list strm__ with
+              Stream.Failure -> raise (Stream.Error "")
+          in
+          v :: t
+      | _ ->
+          match Stream.peek strm__ with
+            Some (Kwd "]") -> Stream.junk strm__; []
+          | Some (Kwd ")") -> Stream.junk strm__; []
+          | _ -> raise Stream.Failure
+;;
+
+let exec_hooks o =
+  List.iter
+    (fun f ->
+       try f () with
+         _ -> ())
+    o.option_hooks
+;;  
+
+let exec_chooks o =
+  List.iter
+    (fun f ->
+       try f o with
+         _ -> ())
+    o.option_class.class_hooks
+;;  
+  
+let really_load filename options =
+  let temp_file = filename ^ ".tmp" in
+  if Sys.file_exists temp_file then begin
+      Printf.printf 
+        "File %s exists\n" temp_file;
+      Printf.printf 
+        "An error may have occurred during previous configuration save.\n";
+      Printf.printf 
+        "Please, check your configurations files, and rename/remove this file\n";
+      Printf.printf "before restarting";
+      print_newline ();
+      exit 1
+    end 
+  else
+    let ic = open_in filename in
+    let s = Stream.of_channel ic in
+    try
+      let stream = lexer s in
+      let list =
+	try parse_gwmlrc stream with
+          e ->
+            Printf.printf "At pos %d/%d" (Stream.count s) (Stream.count stream);
+            print_newline ();
+            raise e
+      in
+      List.iter
+	(fun o ->
+          try
+            o.option_value <-
+              o.option_class.from_value (find_value o.option_name list);
+            exec_chooks o;
+            exec_hooks o
+          with
+            e ->
+             ()
+	)
+	options;
+      list
+    with
+      e ->
+	Printf.printf "Error %s in %s" (Printexc.to_string e) filename;
+	print_newline ();
+	[]
+;;
+      
+let load opfile =
+  try opfile.file_rc <- really_load opfile.file_name opfile.file_options with
+    Not_found -> 
+      Printf.printf "No %s found" opfile.file_name; print_newline ()
+;;
+
+let append opfile filename =
+  try opfile.file_rc <-
+    really_load filename opfile.file_options @ opfile.file_rc with
+    Not_found -> 
+      Printf.printf "No %s found" filename; print_newline ()
+;;
+      
+let ( !! ) o = o.option_value;;
+let ( =:= ) o v = o.option_value <- v; exec_chooks o; exec_hooks o;;
+    
+let value_to_string v =
+  match v with
+    StringValue s -> s
+  | IntValue i -> string_of_int i
+  | FloatValue f -> string_of_float f
+  | _ -> failwith "Options: not a string option"
+;;
+      
+let string_to_value s = StringValue s;;
+  
+let value_to_int v =
+  match v with
+    StringValue s -> int_of_string s
+  | IntValue i -> i
+  | _ -> failwith "Options: not an int option"
+;;
+
+let int_to_value i = IntValue i;;
+
+(* The Pervasives version is too restrictive *)
+let bool_of_string s =
+  match String.lowercase s with
+    "true" -> true
+  | "false" -> false
+  | "yes" -> true
+  | "no" -> false
+  | "y" -> true
+  | "n" -> false
+  | _ -> invalid_arg "bool_of_string"
+;;
+
+let value_to_bool v =
+  match v with
+    StringValue s -> bool_of_string s
+  | IntValue v when v = 0 -> false
+  | IntValue v when v = 1 -> true
+  | _ -> failwith "Options: not a bool option"
+;;
+let bool_to_value i = StringValue (string_of_bool i);;
+
+let value_to_float v =
+  match v with
+    StringValue s -> float_of_string s
+  | FloatValue f -> f
+  | _ -> failwith "Options: not a float option"
+;; 
+
+let float_to_value i = FloatValue i;;
+
+let value_to_string2 v =
+  match v with
+    List [s1; s2] | SmallList [s1;s2] -> 
+      value_to_string s1, value_to_string s2
+  | _ -> failwith "Options: not a string2 option"
+;;
+
+let string2_to_value (s1, s2) = SmallList [StringValue s1; StringValue s2];;
+
+let value_to_list v2c v =
+  match v with
+    List l | SmallList l -> List.rev (List.rev_map v2c l)
+  | StringValue s -> failwith (Printf.sprintf 
+        "Options: not a list option (StringValue [%s])" s)
+  | FloatValue _ -> failwith "Options: not a list option (FloatValue)"
+  | IntValue _ -> failwith "Options: not a list option (IntValue)"
+  | Module _ -> failwith "Options: not a list option (Module)"
+;;
+
+let list_to_value c2v l =
+  List
+    (List.fold_right
+      (fun v list ->
+          try c2v v :: list with
+            _ -> list)
+       l [])
+;;
+  
+let smalllist_to_value c2v l =
+  SmallList
+    (List.fold_right
+       (fun v list ->
+          try c2v v :: list with
+            _ -> list)
+       l [])
+;;
+
+let string_option =
+  define_option_class "String" value_to_string string_to_value
+;;
+let color_option =
+  define_option_class "Color" value_to_string string_to_value
+;;
+let font_option = define_option_class "Font" value_to_string string_to_value;;
+
+let int_option = define_option_class "Int" value_to_int int_to_value;;
+
+let bool_option = define_option_class "Bool" value_to_bool bool_to_value;;
+let float_option = define_option_class "Float" value_to_float float_to_value;;
+
+let string2_option =
+  define_option_class "String2" value_to_string2 string2_to_value
+;;
+
+let list_option cl =
+  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
+    (list_to_value cl.to_value)
+;;
+
+let smalllist_option cl =
+  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
+    (smalllist_to_value cl.to_value)
+;;
+
+let to_value cl = cl.to_value;;
+let from_value cl = cl.from_value;;
+  
+let value_to_sum l v =
+  match v with
+    StringValue s -> List.assoc s l
+  | _ -> failwith "Options: not a sum option"
+;;
+  
+let sum_to_value l v = StringValue (List.assq v l);;
+  
+let sum_option l =
+  let ll = List.map (fun (a1, a2) -> a2, a1) l in
+  define_option_class "Sum" (value_to_sum l) (sum_to_value ll)
+;;
+
+let exit_exn = Exit;;
+let safe_string s =
+  if s = "" then "\"\""
+  else
+    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 exit_exn
+          done;
+          s
+      | _ ->
+          if string_of_int (int_of_string s) = s ||
+             string_of_float (float_of_string s) = s then
+            s
+          else raise exit_exn
+    with
+      _ -> Printf.sprintf "\"%s\"" (String.escaped s)
+;;
+
+let with_help = ref false;;
+      
+let rec save_module indent oc list =
+  let subm = ref [] in
+  List.iter
+    (fun (name, help, value) ->
+       match name with
+         [] -> assert false
+       | [name] ->
+           if !with_help && help <> "" then
+             Printf.fprintf oc "(* %s *)\n" help;
+           Printf.fprintf oc "%s %s = " indent (safe_string name);
+           save_value indent oc value;
+           Printf.fprintf oc "\n"
+       | m :: tail ->
+           let p =
+             try List.assoc m !subm with
+               _ -> let p = ref [] in subm := (m, p) :: !subm; p
+           in
+           p := (tail, help, value) :: !p)
+    list;
+  List.iter
+    (fun (m, p) ->
+       Printf.fprintf oc "%s %s = {\n" indent (safe_string m);
+       save_module (indent ^ "  ") oc !p;
+       Printf.fprintf oc "%s}\n" indent)
+    !subm
+and save_list indent oc list =
+  match list with
+    [] -> ()
+  | [v] -> save_value indent oc v
+  | v :: tail ->
+      save_value indent oc v; Printf.fprintf oc ", "; save_list indent oc tail
+and save_list_nl indent oc list =
+  match list with
+    [] -> ()
+  | [v] -> Printf.fprintf oc "\n%s" indent; save_value indent oc v
+  | v :: tail ->
+      Printf.fprintf oc "\n%s" indent;
+      save_value indent oc v;
+      Printf.fprintf oc ";";
+      save_list_nl indent oc tail
+and save_value indent oc v =
+  match v with
+    StringValue s -> Printf.fprintf oc "%s" (safe_string s)
+  | IntValue i -> Printf.fprintf oc "%d" i
+  | FloatValue f -> Printf.fprintf oc "%f" f
+  | List l ->
+      Printf.fprintf oc "[";
+      save_list_nl (indent ^ "  ") oc l;
+      Printf.fprintf oc "]"
+  | SmallList l ->
+      Printf.fprintf oc "(";
+      save_list (indent ^ "  ") oc l;
+      Printf.fprintf oc ")"
+  | Module m -> 
+      Printf.fprintf oc "{";
+      save_module_fields (indent ^ "  ") oc m;
+      Printf.fprintf oc "}"
+      
+and save_module_fields indent oc m =
+  match m with
+    [] -> ()
+  | (name, v) :: tail ->
+      Printf.fprintf oc "%s %s = " indent (safe_string name);
+      save_value indent oc v;
+      Printf.fprintf oc "\n";
+      save_module_fields indent oc tail
+;;
+    
+let save opfile =
+  let filename = opfile.file_name in
+  let temp_file = filename ^ ".tmp" in
+  let old_file = filename ^ ".old" in
+  let oc = open_out temp_file in
+  save_module "" oc
+    (List.map
+      (fun o ->
+        o.option_name, o.option_help,
+        (try 
+            o.option_class.to_value o.option_value 
+          with
+            e ->
+              Printf.printf "Error while saving option \"%s\": %s"
+                (try List.hd o.option_name with
+                  _ -> "???")
+              (Printexc.to_string e);
+              print_newline ();
+              StringValue ""))
+    (List.rev opfile.file_options));
+  if not opfile.file_pruned then begin
+      Printf.fprintf oc
+        "\n(*\n The following options are not used (errors, obsolete, ...) \n*)\n";
+      List.iter
+        (fun (name, value) ->
+          try
+            List.iter
+              (fun o ->
+                match o.option_name with
+                  n :: _ -> if n = name then raise Exit
+                | _ -> ())
+            opfile.file_options;
+            Printf.fprintf oc "%s = " (safe_string name);
+            save_value "  " oc value;
+            Printf.fprintf oc "\n"
+          with
+            _ -> ())
+      opfile.file_rc;
+    end;
+  close_out oc;
+  (try Sys.rename filename old_file with _ -> ());
+  (try Sys.rename temp_file filename with _ -> ())
+;;
+
+let save_with_help opfile =
+  with_help := true;
+  begin try save opfile with
+    _ -> ()
+  end;
+  with_help := false
+;;
+  
+let option_hook option f = option.option_hooks <- f :: option.option_hooks;;
+  
+let class_hook option_class f =
+  option_class.class_hooks <- f :: option_class.class_hooks
+;;
+
+let rec iter_order f list =
+  match list with
+    [] -> ()
+  | v :: tail -> f v; iter_order f tail
+;;
+  
+let help oc opfile =
+  List.iter
+    (fun o ->
+       Printf.fprintf oc "OPTION \"";
+       begin match o.option_name with
+         [] -> Printf.fprintf oc "???"
+       | [name] -> Printf.fprintf oc "%s" name
+       | name :: tail ->
+           Printf.fprintf oc "%s" name;
+           iter_order (fun name -> Printf.fprintf oc ":%s" name) o.option_name
+       end;
+       Printf.fprintf oc "\" (TYPE \"%s\"): %s\n   CURRENT: \n"
+         o.option_class.class_name o.option_help;
+       begin try
+         save_value "" oc (o.option_class.to_value o.option_value)
+       with
+         _ -> ()
+       end;
+       Printf.fprintf oc "\n")
+    opfile.file_options;
+  flush oc
+;;
+  
+    
+let tuple2_to_value (c1, c2) (a1, a2) =
+  SmallList [to_value c1 a1; to_value c2 a2]
+;;
+  
+let value_to_tuple2 (c1, c2) v =
+  match v with
+    List [v1; v2] -> from_value c1 v1, from_value c2 v2
+  | SmallList [v1; v2] -> from_value c1 v1, from_value c2 v2
+  | List l | SmallList l ->
+      Printf.printf "list of %d" (List.length l);
+      print_newline ();
+      failwith "Options: not a tuple2 list option"
+  | _ -> failwith "Options: not a tuple2 option"
+;;
+  
+let tuple2_option p =
+  define_option_class "tuple2_option" (value_to_tuple2 p) (tuple2_to_value p)
+;;
+  
+let tuple3_to_value (c1, c2, c3) (a1, a2, a3) =
+  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3]
+;;
+let value_to_tuple3 (c1, c2, c3) v =
+  match v with
+    List [v1; v2; v3] -> from_value c1 v1, from_value c2 v2, from_value c3 v3
+  | SmallList [v1; v2; v3] ->
+      from_value c1 v1, from_value c2 v2, from_value c3 v3
+  | _ -> failwith "Options: not a tuple3 option"
+;;
+      
+let tuple3_option p =
+  define_option_class "tuple3_option" (value_to_tuple3 p) (tuple3_to_value p)
+;;
+
+let tuple4_to_value (c1, c2, c3, c4) (a1, a2, a3, a4) =
+  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3; to_value c4 a4]
+;;
+let value_to_tuple4 (c1, c2, c3, c4) v =
+  match v with
+    List [v1; v2; v3; v4] -> 
+      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
+  | SmallList [v1; v2; v3; v4] ->
+      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
+  | _ -> failwith "Options: not a tuple4 option"
+;;
+      
+let tuple4_option p =
+  define_option_class "tuple4_option" (value_to_tuple4 p) (tuple4_to_value p)
+;;
+
+
+let shortname o = String.concat ":" o.option_name;;
+let get_class o = o.option_class;;
+let get_help o =
+  let help = o.option_help in if help = "" then "No Help Available" else help
+;;
+
+
+let simple_options opfile =
+  let list = ref [] in
+  List.iter (fun o ->
+      match o.option_name with
+        [] | _ :: _ :: _ -> ()
+      | [name] ->
+          match o.option_class.to_value o.option_value with
+            Module _ | SmallList _ | List _ -> 
+              begin
+                match o.string_wrappers with
+                  None -> ()
+                | Some (to_string, from_string) ->
+                    list := (name, to_string o.option_value) :: !list   
+              end
+          | v -> 
+              list := (name, value_to_string v) :: !list
+  ) opfile.file_options;
+  !list
+
+let get_option opfile name =
+  let rec iter name list = 
+    match list with 
+      [] -> raise Not_found
+    | o :: list ->
+        if o.option_name = name then o
+        else iter name list
+  in
+  iter [name] opfile.file_options
+  
+  
+let set_simple_option opfile name v =
+  let o = get_option opfile name in
+  begin
+    match o.string_wrappers with
+      None ->
+        o.option_value <- o.option_class.from_value (string_to_value v);
+    | Some (_, from_string) -> 
+        o.option_value <- from_string v
+  end;
+  exec_chooks o; exec_hooks o;;
+    
+let get_simple_option opfile name =
+  let o = get_option opfile name in
+  match o.string_wrappers with
+    None ->
+      value_to_string (o.option_class.to_value o.option_value)
+  | Some (to_string, _) -> 
+      to_string o.option_value
+  
+let set_option_hook opfile name hook =
+  let o = get_option opfile name in
+  o.option_hooks <- hook :: o.option_hooks
+  
+let set_string_wrappers o to_string from_string =
+  o.string_wrappers <- Some (to_string, from_string)
+
+let simple_args opfile =
+  List.map (fun (name, v) ->
+      ("-" ^ name), 
+      Arg.String (set_simple_option opfile name), 
+      (Printf.sprintf "<string> : \t%s (current: %s)"
+          (get_option opfile name).option_help
+          v)
+  ) (simple_options opfile)
diff --git a/ide/utils/uoptions.mli b/ide/utils/uoptions.mli
new file mode 100644
index 00000000..a323ac60
--- /dev/null
+++ b/ide/utils/uoptions.mli
@@ -0,0 +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                                *)
+(**************************************************************************)
+
+(**
+ This module implements a simple mechanism to handle program options files.
+  An options file is defined as a set of [variable = value] lines,
+  where value can be a simple string, a list of values (between brackets
+or parentheses) or a set of [variable = value] lines between braces.
+The option file is automatically loaded and saved, and options are
+manipulated inside the program as easily as references. 
+
+   Code from Fabrice Le Fessant.
+*)
+
+type 'a option_class
+(** The abstract type for a class of options. A class is a set of options
+which use the same conversion functions from loading and saving.*)
+  
+type 'a option_record
+(** The abstract type for an option *)
+
+type options_file
+
+val create_options_file : string -> options_file
+val set_options_file : options_file -> string -> unit
+val prune_file : options_file -> unit  
+
+(** {2 Operations on option files} *)
+  
+val load : options_file -> unit
+(** [load file] loads the option file. All options whose value is specified
+   in the option file are updated. *)
+  
+val append : options_file -> string -> unit
+(** [append filename] loads the specified option file. All options whose 
+value is specified in this file are updated. *)
+  
+val save : options_file -> unit
+(** [save file] saves all the options values to the option file. *)
+
+val save_with_help : options_file -> unit
+(** [save_with_help ()] saves all the options values to the option file,
+   with the help provided for each option. *)
+  
+(** {2  Creating options} *)  
+
+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
+  
+  (* parameterized options *)
+val list_option : 'a option_class -> 'a list option_class
+val smalllist_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
+
+(** {2  Using options} *)
+  
+val ( !! ) : 'a option_record -> 'a
+val ( =:= ) : 'a option_record -> 'a -> unit
+
+val shortname : 'a option_record -> string
+val get_help : 'a option_record -> string  
+  
+(** {2 Creating new option classes} *)
+
+val get_class : 'a option_record -> 'a option_class
+
+val class_hook : 'a option_class -> ('a option_record -> unit) -> unit
+
+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
+val smalllist_to_value : ('a -> option_value) -> 'a list -> option_value
+
+val set_simple_option : options_file -> string -> string -> unit
+val simple_options : options_file -> (string * string) list
+val get_simple_option : options_file -> string -> string
+val set_option_hook : options_file -> string -> (unit -> unit) -> unit
+  
+val set_string_wrappers : 'a option_record -> 
+  ('a -> string) -> (string -> 'a) -> unit
+
+(** {2 Other functions} *)
+
+val simple_args : options_file -> (string * Arg.spec * string) list
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
new file mode 100644
index 00000000..6692dca5
--- /dev/null
+++ b/interp/constrextern.ml
@@ -0,0 +1,1855 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: constrextern.ml,v 1.85.2.2 2004/07/16 19:30:22 herbelin Exp $ *)
+
+(*i*)
+open Pp
+open Util
+open Univ
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Sign
+open Environ
+open Libnames
+open Impargs
+open Topconstr
+open Rawterm
+open Pattern
+open Nametab
+open Symbols
+open Reserve
+(*i*)
+
+(* Translation from rawconstr to front constr *)
+
+(**********************************************************************)
+(* Parametrization                                                    *)
+
+(* 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 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
+
+(* This suppresses printing of numeral and symbols *)
+let print_no_symbol = ref false
+
+(* This governs printing of projections using the dot notation symbols *)
+let print_projections = ref false
+
+let print_meta_as_hole = ref false
+
+let with_arguments f = Options.with_option print_arguments f
+let with_implicits f = Options.with_option print_implicits f
+let with_coercions f = Options.with_option print_coercions f
+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 *)
+
+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)
+
+(**********************************************************************)
+(* 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 idopt_of_name = function 
+  | Name id -> Some id
+  | Anonymous -> None
+
+let extern_evar loc n =
+(*
+  msgerrnl (str 
+    "Warning: existential variable turned into meta-variable during externalization");
+  CPatVar (loc,(false,make_ident "META" (Some n)))
+*)
+  CEvar (loc,n)
+
+let raw_string_of_ref = function
+  | ConstRef kn -> 
+      "CONST("^(string_of_kn kn)^")"
+  | IndRef (kn,i) ->
+      "IND("^(string_of_kn kn)^","^(string_of_int i)^")"
+  | ConstructRef ((kn,i),j) -> 
+      "CONSTRUCT("^
+      (string_of_kn kn)^","^(string_of_int i)^","^(string_of_int j)^")"
+  | 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)
+  with Not_found ->
+    (* happens in debugger *)
+    Ident (loc,id_of_string (raw_string_of_ref r))
+
+(************************************************************************)
+(* Equality up to location (useful for translator v8) *)
+
+let rec check_same_pattern p1 p2 =
+  match p1, p2 with
+    | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) when i1=i2 ->
+        check_same_pattern a1 a2
+    | 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 -> ()
+    | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 ->
+        check_same_pattern e1 e2
+    | _ -> failwith "not same pattern"
+
+let check_same_ref r1 r2 =
+  match r1,r2 with
+  | Qualid(_,q1), Qualid(_,q2) when q1=q2 -> ()
+  | Ident(_,i1), Ident(_,i2) when i1=i2 -> ()
+  | _ -> failwith "not same ref"
+
+let rec check_same_type ty1 ty2 =
+  match ty1, ty2 with
+  | CRef r1, CRef r2 -> check_same_ref r1 r2
+  | CFix(_,(_,id1),fl1), CFix(_,(_,id2),fl2) when id1=id2 ->
+      List.iter2 (fun (id1,i1,bl1,a1,b1) (id2,i2,bl2,a2,b2) ->
+        if id1<>id2 || i1<>i2 then failwith "not same fix";
+        check_same_fix_binder bl1 bl2;
+        check_same_type a1 a2;
+        check_same_type b1 b2)
+        fl1 fl2
+  | CCoFix(_,(_,id1),fl1), CCoFix(_,(_,id2),fl2) when id1=id2 ->
+      List.iter2 (fun (id1,bl1,a1,b1) (id2,bl2,a2,b2) ->
+        if id1<>id2 then failwith "not same fix";
+        check_same_fix_binder bl1 bl2;
+        check_same_type a1 a2;
+        check_same_type b1 b2)
+        fl1 fl2
+  | CArrow(_,a1,b1), CArrow(_,a2,b2) ->
+      check_same_type a1 a2;
+      check_same_type b1 b2
+  | CProdN(_,bl1,a1), CProdN(_,bl2,a2) ->
+      List.iter2 check_same_binder bl1 bl2;
+      check_same_type a1 a2
+  | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) ->
+      List.iter2 check_same_binder bl1 bl2;
+      check_same_type a1 a2
+  | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) when na1=na2 ->
+      check_same_type a1 a2;
+      check_same_type b1 b2
+  | CAppExpl(_,r1,al1), CAppExpl(_,r2,al2) when r1=r2 ->
+      List.iter2 check_same_type al1 al2
+  | CApp(_,(_,e1),al1), CApp(_,(_,e2),al2) ->
+      check_same_type e1 e2;
+      List.iter2 (fun (a1,e1) (a2,e2) ->
+                    if e1<>e2 then failwith "not same expl";
+                    check_same_type a1 a2) al1 al2
+  | 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;
+        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) ->
+      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 -> ()
+  | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 ->
+      check_same_type e1 e2
+  | _ when ty1=ty2 -> ()
+  | _ -> failwith "not same type"
+
+and check_same_binder (nal1,e1) (nal2,e2) =
+  List.iter2 (fun (_,na1) (_,na2) ->
+    if na1<>na2 then failwith "not same name") nal1 nal2;
+  check_same_type e1 e2
+
+and check_same_fix_binder bl1 bl2 =
+  List.iter2 (fun b1 b2 ->
+    match b1,b2 with
+        LocalRawAssum(nal1,ty1), LocalRawAssum(nal2,ty2) ->
+          check_same_binder (nal1,ty1) (nal2,ty2)
+      | LocalRawDef(na1,def1), LocalRawDef(na2,def2) ->
+          check_same_binder ([na1],def1) ([na2],def2)          
+      | _ -> failwith "not same binder") bl1 bl2
+
+let same c d = try check_same_type c d; true with _ -> false
+
+(* Idem for rawconstr *)
+let option_iter2 f o1 o2 = 
+  match o1, o2 with
+      Some o1, Some o2 -> f o1 o2
+    | None, None -> ()
+    | _ -> failwith "option"
+
+let array_iter2 f v1 v2 =
+  List.iter2 f (Array.to_list v1) (Array.to_list v2)
+
+let rec same_patt p1 p2 =
+  match p1, p2 with
+      PatVar(_,na1), PatVar(_,na2) -> if na1<>na2 then failwith "PatVar"
+    | PatCstr(_,c1,pl1,al1), PatCstr(_,c2,pl2,al2) ->
+        if c1<>c2 || al1 <> al2 then failwith "PatCstr";
+        List.iter2 same_patt pl1 pl2
+    | _ -> failwith "same_patt"
+
+let rec same_raw c d =
+  match c,d with
+   | RRef(_,gr1), RRef(_,gr2) -> if gr1<>gr2 then failwith "RRef"
+   | RVar(_,id1), RVar(_,id2) -> if id1<>id2 then failwith "RVar"
+   | REvar(_,e1,a1), REvar(_,e2,a2) ->
+       if e1 <> e2 then failwith "REvar";
+       option_iter2(List.iter2 same_raw) a1 a2
+  | RPatVar(_,pv1), RPatVar(_,pv2) -> if pv1<>pv2 then failwith "RPatVar"
+  | RApp(_,f1,a1), RApp(_,f2,a2) ->
+      List.iter2 same_raw (f1::a1) (f2::a2)
+  | RLambda(_,na1,t1,m1), RLambda(_,na2,t2,m2) ->
+      if na1 <> na2 then failwith "RLambda";
+      same_raw t1 t2; same_raw m1 m2
+  | RProd(_,na1,t1,m1), RProd(_,na2,t2,m2) ->
+      if na1 <> na2 then failwith "RProd";
+      same_raw t1 t2; same_raw m1 m2
+  | RLetIn(_,na1,t1,m1), RLetIn(_,na2,t2,m2) ->
+      if na1 <> na2 then failwith "RLetIn";
+      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)}) ->
+          same_raw t1 t2;
+          if al1 <> al2 then failwith "RCases";
+          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;
+      same_raw c1 c2
+  | RIf(_,b1,_,t1,e1),RIf(_,b2,_,t2,e2) ->
+      same_raw b1 b2; same_raw t1 t2; same_raw e1 e2
+  | RRec(_,fk1,na1,bl1,ty1,def1), RRec(_,fk2,na2,bl2,ty2,def2) ->
+      if fk1 <> fk2 || na1 <> na2 then failwith "RRec";
+      array_iter2
+        (List.iter2 (fun (na1,bd1,ty1) (na2,bd2,ty2) ->
+          if na1<>na2 then failwith "RRec";
+          option_iter2 same_raw bd1 bd2;
+          same_raw ty1 ty2)) bl1 bl2;
+      array_iter2 same_raw ty1 ty2;
+      array_iter2 same_raw def1 def2
+  | 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
+  | RDynamic(_,d1), RDynamic(_,d2) -> if d1<>d2 then failwith"RDynamic"
+  | _ -> failwith "same_raw"
+     
+let same_rawconstr c d = 
+  try same_raw c d; true
+  with Failure _ | Invalid_argument _ -> false
+
+(**********************************************************************)
+(* 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
+    string_string_contains ntn " { _ } ")
+
+let rec wildcards ntn n =
+  if n = String.length ntn then []
+  else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l
+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 ntn' = ref ntn in
+  let rec expand_ntn i =
+    function
+    | [] -> []
+    | a::l ->
+        let a' = 
+          let p = List.nth (wildcards !ntn' 0) i - 2 in
+          if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }"
+          then begin
+            ntn' := 
+              String.sub !ntn' 0 p ^ "_" ^ 
+              String.sub !ntn' (p+5) (String.length !ntn' -p-5);
+            make_ntn "{ _ }" [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
+
+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 make_pat_notation loc ntn l =
+  if has_curly_brackets ntn
+  then expand_curly_brackets (fun n l -> CPatNotation (loc,n,l)) ntn l
+  else match ntn,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)
+
+
+(*
+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 bind_env sigma var v =
+  try
+    let vvar = List.assoc var sigma in
+    if v=vvar then sigma else raise No_match
+  with Not_found ->
+    (* TODO: handle the case of multiple occs in different scopes *)
+    (var,v)::sigma
+
+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
+  | PatCstr (loc,(ind,_ as r1),args1,Anonymous), _ ->
+      let nparams =
+	(snd (Global.lookup_inductive ind)).Declarations.mind_nparams in
+      let l2 =
+        match a2 with
+	  | ARef (ConstructRef r2) when r1 = r2 -> []
+	  | AApp (ARef (ConstructRef r2),l2)  when r1 = r2 -> l2
+          | _ -> raise No_match in
+      if List.length l2 <> nparams + List.length args1
+      then raise No_match
+      else
+        let (p2,args2) = list_chop nparams l2 in
+        (* All parameters must be _ *)
+        List.iter (function AHole _ -> () | _ -> raise No_match) p2;
+	List.fold_left2 (match_cases_pattern metas) sigma args1 args2
+  | _ -> raise No_match
+
+let match_aconstr_cases_pattern c (metas_scl,pat) =
+  let subst = match_cases_pattern (List.map fst metas_scl) [] c pat in
+  (* Reorder canonically the substitution *)
+  let find x subst =
+    try List.assoc x subst
+    with Not_found -> anomaly "match_aconstr_cases_pattern" in
+  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 =
+  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
+    | None -> raise No_match
+    | Some key ->
+        let loc = pattern_loc pat in
+        insert_pat_delimiters (CPatNumeral (loc,n)) key
+  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)
+  with No_match ->
+  match pat with
+  | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,v7_to_v8_id 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)
+	
+and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
+  | [] -> raise No_match
+  | (keyrule,pat,n as rule)::rules ->
+      try
+	(* Check the number of arguments expected by the notation *)
+	let loc = match t,n with
+	  | PatCstr (_,f,l,_), Some n when List.length l > n ->
+	      raise No_match
+	  | PatCstr (loc,_,_,_),_ -> loc
+	  | PatVar (loc,_),_ -> loc in
+	(* Try matching ... *)
+	let subst = match_aconstr_cases_pattern t pat in
+	(* 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
+                  (* 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 l =
+		    List.map (fun (c,(scopt,scl)) ->
+		      extern_cases_pattern_in_scope 
+		        (scopt,List.fold_right push_scope scl scopes) vars c)
+                      subst in
+		  insert_pat_delimiters (make_pat_notation loc ntn l) key)
+          | SynDefRule kn ->
+ 	      CPatAtom (loc,Some (Qualid (loc, shortest_qualid_of_syndef kn)))
+      with
+	  No_match -> extern_symbol_pattern allscopes vars t rules
+
+(**********************************************************************)
+(* Externalising applications *)
+
+let occur_name na aty =
+  match na with
+    | Name id -> occur_var_constr_expr id aty
+    | Anonymous -> false
+
+let is_projection nargs = function
+  | Some r when not !Options.raw_print & !print_projections ->
+      (try 
+	let n = Recordops.find_projection_nparams r + 1 in
+	if n <= nargs then Some n else None
+      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 =
+  not (is_hole a) or (tail = [] & not (List.for_all is_status_implicit impl))
+
+(* Implicit args indexes are in ascending order *)
+(* inctx is useful only if there is a last argument to be deduced from ctxt *)
+let explicitize loc inctx impl (cf,f) 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 =
+          !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))))
+	in
+        if visible then (a,Some (explicit_code imp q)) :: 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
+  match is_projection (List.length args) cf with
+    | Some i as ip ->
+	if impl <> [] & is_status_implicit (List.nth impl (i-1)) then
+	  let f' = match f with CRef f -> f | _ -> assert false in
+	  CAppExpl (loc,(ip,f'),args)
+	else
+	  let (args1,args2) = list_chop i args in
+	  let (impl1,impl2) = if impl=[] then [],[] else list_chop i impl in
+	  let args1 = exprec 1 (args1,impl1) in
+	  let args2 = exprec (i+1) (args2,impl2) in
+	  CApp (loc,(Some (List.length args1),f),args1@args2)
+    | None -> 
+	let args = exprec 1 (args,impl) in
+	if args = [] then f else CApp (loc, (None, f), args)
+
+let extern_global loc impl f =
+  if impl <> [] & List.for_all is_status_implicit impl then
+    CAppExpl (loc, (None, f), [])
+  else
+    CRef f
+
+let extern_app loc inctx impl (cf,f) args =
+  if args = [] (* maybe caused by a hidden coercion *) then
+    extern_global loc impl f
+  else
+  if 
+    ((!Options.raw_print or
+      (!print_implicits & not !print_implicits_explicit_args)) &
+     List.exists is_status_implicit impl)
+  then 
+    CAppExpl (loc, (is_projection (List.length args) cf, f), args)
+  else
+    explicitize loc inctx impl (cf,CRef f) args
+
+let rec extern_args extern scopes env args subscopes =
+  match args with
+    | [] -> []
+    | a::args ->
+	let argscopes, subscopes = match subscopes with
+	  | [] -> (None,scopes), []
+	  | scopt::subscopes -> (scopt,scopes), subscopes in
+	extern argscopes env a :: 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 ())
+      ->
+      (try match Classops.hide_coercion r with
+	  | Some n when n < List.length args ->
+	      (* We skip a coercion *) 
+	      let l = list_skipn n args in
+              let (a,l) = match l with a::l -> (a,l) | [] -> assert false in
+              let (a,l) =
+                (* Recursively remove the head coercions *)
+                match remove_coercions inctx a with
+                  | RApp (_,a,l') -> a,l'@l
+                  | a -> a,l in
+              if l = [] then a
+              else
+                (* Recursively remove coercions in arguments *)
+                RApp (loc,a,List.map (remove_coercions true) l)
+	  | _ -> c
+      with Not_found -> c)
+  | c -> c
+
+let rec rename_rawconstr_var id0 id1 = function
+    RRef(loc,VarRef id) when id=id0 -> RRef(loc,VarRef id1)
+  | RVar(loc,id) when id=id0 -> RVar(loc,id1)
+  | c -> map_rawconstr (rename_rawconstr_var id0 id1) c
+
+let rec share_fix_binders n rbl ty def =
+  match ty,def with
+      RProd(_,na0,t0,b), RLambda(_,na1,t1,m) ->
+        if not(same_rawconstr t0 t1) then List.rev rbl, ty, def
+        else
+          let (na,b,m) =
+            match na0, na1 with
+                Name id0, Name id1 ->
+                  if id0=id1 then (na0,b,m)
+                  else if not (occur_rawconstr id1 b) then
+                    (na1,rename_rawconstr_var id0 id1 b,m)
+                  else if not (occur_rawconstr id0 m) then
+                    (na1,b,rename_rawconstr_var id1 id0 m)
+                  else (* vraiment pas de chance! *)
+                    failwith "share_fix_binders: capture"
+              | Name id, Anonymous ->
+                  if not (occur_rawconstr id m) then (na0,b,m)
+                  else
+                    failwith "share_fix_binders: capture"
+              | Anonymous, Name id -> 
+                  if not (occur_rawconstr id b) then (na1,b,m)
+                  else
+                    failwith "share_fix_binders: capture"
+              | _ -> (na1,b,m) in
+          share_fix_binders (n-1) ((na,None,t0)::rbl) b m
+    | _ -> List.rev rbl, ty, def
+
+(**********************************************************************)
+(* mapping rawterms to constr_expr                                    *)
+
+let rec extern inctx scopes vars r =
+  try 
+    if !Options.raw_print or !print_no_symbol then raise No_match;
+    extern_numeral (Rawterm.loc_of_rawconstr r)
+      scopes (Symbols.uninterp_numeral r)
+  with No_match ->
+
+  let r = remove_coercions inctx r in
+
+  try 
+    if !Options.raw_print or !print_no_symbol then raise No_match;
+    extern_symbol scopes vars r (Symbols.uninterp_notations r)
+  with No_match -> match r with
+  | RRef (loc,ref) ->
+      extern_global loc (implicits_of_global_out ref)
+        (extern_reference loc vars ref)
+
+  | RVar (loc,id) -> CRef (Ident (loc,v7_to_v8_id id))
+
+  | REvar (loc,n,_) -> (* we drop args *) extern_evar loc n
+
+  | RPatVar (loc,n) -> if !print_meta_as_hole then CHole loc else CPatVar (loc,n)
+
+  | RApp (loc,f,args) ->
+      (match f with
+	 | RRef (rloc,ref) ->
+	     let subscopes = Symbols.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)
+               (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)
+
+  | 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 (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 (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
+      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 na' = match na,tm with
+            Anonymous, RVar (_,id) when 
+              !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) ->
+	  let args = List.map (function
+	    | Anonymous -> RHole (dummy_loc,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)
+
+  | RLetTuple (loc,nal,(na,typopt),tm,b) ->
+      CLetTuple (loc,nal,
+        (Some na,option_app (extern_type 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,
+        (Some na,option_app (extern_type 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) ->
+      let vars' = Array.fold_right Idset.add idv vars in
+      (match fk with
+	 | 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 (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,
+                  extern false scopes vars1 def)) idv
+	     in 
+	     CFix (loc,(loc,idv.(n)),Array.to_list listdecl)
+	 | RCoFix n -> 
+	     let listdecl =
+               Array.mapi (fun i fi ->
+                 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),
+                  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)
+
+  | RHole (loc,e) -> CHole loc
+
+  | RCast (loc,c,t) ->
+      CCast (loc,sub_extern true scopes vars c,extern_type scopes vars t)
+
+  | RDynamic (loc,d) -> CDynamic (loc,d)
+
+and extern_type (_,scopes) = extern true (Some Symbols.type_scope,scopes)
+
+and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
+
+and factorize_prod scopes vars aty = function
+  | RProd (loc,(Name id as na),ty,c)
+      when same aty (extern_type 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
+           ((loc,Name id)::nal,c)
+  | c -> ([],extern_type scopes vars c)
+
+and factorize_lambda inctx scopes vars aty = function
+  | RLambda (loc,na,ty,c)
+      when same aty (extern_type 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) =
+	     factorize_lambda inctx scopes (add_vname vars na) aty c in
+           ((loc,na)::nal,c)
+  | c -> ([],sub_extern inctx scopes vars c)
+
+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
+      (match extern_local_binder scopes (name_fold Idset.add na vars) l with
+          (ids,LocalRawAssum(nal,ty')::l)
+            when same ty ty' &
+              match na with Name id -> not (occur_var_constr_expr id ty')
+                | _ -> true ->
+              (na::ids,
+               LocalRawAssum((dummy_loc,na)::nal,ty')::l)
+        | (ids,l) ->
+            (na::ids,
+             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,
+   extern inctx scopes vars c)
+
+and extern_numeral loc scopes (sc,n) =
+  match Symbols.availability_of_numeral sc (make_current_scopes scopes) with
+    | None -> raise No_match
+    | Some key -> insert_delimiters (CNumeral (loc,n)) key
+
+and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
+  | [] -> raise No_match
+  | (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 *)
+	let (t,args) = match t,n with
+	  | RApp (_,f,args), Some n when List.length args > n ->
+	      let args1, args2 = list_chop n args in
+	      RApp (dummy_loc,f,args1), args2
+	  | _ -> t,[] in
+	(* Try matching ... *)
+	let subst = match_aconstr t pat in
+	(* Try availability of interpretation ... *)
+        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
+                  (* 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 l =
+		    List.map (fun (c,(scopt,scl)) ->
+		      extern (* assuming no overloading: *) true
+		        (scopt,List.fold_right push_scope scl scopes) vars c)
+                      subst in
+	          insert_delimiters (make_notation loc ntn l) key)
+          | SynDefRule kn ->
+              CRef (Qualid (loc, shortest_qualid_of_syndef kn)) in
+ 	if args = [] then e 
+	else
+	  (* TODO: compute scopt for the extra args, in case, head is a ref *)
+	  explicitize loc false [] (None,e)
+	  (List.map (extern true allscopes vars) args)
+      with
+	  No_match -> extern_symbol allscopes vars t rules
+
+let extern_rawconstr vars c = 
+  extern false (None,Symbols.current_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
+
+(******************************************************************)
+(* Main translation function from constr -> constr_expr *)
+
+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 extern_constr_in_scope at_top scope env t =
+  extern_constr_gen at_top (Some scope) env t
+
+let extern_constr at_top env t =
+  extern_constr_gen at_top None env t
+
+(******************************************************************)
+(* Main translation function from pattern -> constr_expr *)
+
+let rec raw_of_pat tenv 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))
+  | PRel n ->
+      let id = try match lookup_name_of_rel n env with
+	| Name id   -> id
+	| Anonymous ->
+	    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 (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)
+  | PSoApp (n,args) ->
+      RApp (loc,RPatVar (loc,(true,n)),
+        List.map (raw_of_pat tenv env) args)
+  | PProd (na,t,c) ->
+      RProd (loc,na,raw_of_pat tenv env t,raw_of_pat tenv (na::env) c)
+  | PLetIn (na,t,c) ->
+      RLetIn (loc,na,raw_of_pat tenv env t, raw_of_pat tenv (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)
+  | PSort s -> RSort (loc,s)
+
+and raw_of_eqn tenv 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
+    PatVar (dummy_loc,Name id),(Name id)::env,id::ids
+  in
+  let rec buildrec ids patlist env n b =
+    if n=0 then
+      (dummy_loc, ids, 
+       [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
+       raw_of_pat tenv env b)
+    else
+      match b with
+	| PLambda (x,_,b) -> 
+	    let pat,new_env,new_ids = make_pat x env b ids in
+            buildrec new_ids (pat::patlist) new_env (n-1) b
+
+	| PLetIn (x,_,b) -> 
+	    let pat,new_env,new_ids = make_pat x env b ids in
+            buildrec new_ids (pat::patlist) new_env (n-1) b
+
+	| _ ->
+	    error "Unsupported branch in case-analysis while printing pattern"
+  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)
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
new file mode 100644
index 00000000..ad1c4391
--- /dev/null
+++ b/interp/constrextern.mli
@@ -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: constrextern.mli,v 1.11.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Term
+open Termops
+open Sign
+open Environ
+open Libnames
+open Nametab
+open Rawterm
+open Pattern
+open Topconstr
+open Symbols
+(*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
+   trees for printing *)
+
+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
+
+(* 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 *)
+
+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
+
+(* Printing options *)
+val print_implicits : bool ref
+val print_arguments : bool ref
+val print_evar_arguments : bool ref
+val print_coercions : bool ref
+val print_universes : bool ref
+val print_no_symbol : bool ref
+val print_projections : bool ref
+
+(* This governs printing of implicit arguments. If [with_implicits] is
+   on and not [with_arguments] then implicit args are printed prefixed
+   by "!"; if [with_implicits] and [with_arguments] are both on the
+   function and not the arguments is prefixed by "!" *)
+val with_implicits : ('a -> 'b) -> 'a -> 'b
+val with_arguments : ('a -> 'b) -> 'a -> 'b
+
+(* This forces printing of coercions *)
+val with_coercions : ('a -> 'b) -> 'a -> 'b
+
+(* This forces printing universe names of Type{.} *)
+val with_universes : ('a -> 'b) -> 'a -> 'b
+
+(* This suppresses printing of numeral and symbols *)
+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
new file mode 100644
index 00000000..e1b916e1
--- /dev/null
+++ b/interp/constrintern.ml
@@ -0,0 +1,1165 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: constrintern.ml,v 1.58.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Names
+open Nameops
+open Libnames
+open Impargs
+open Rawterm
+open Pattern
+open Pretyping
+open Topconstr
+open Nametab
+open Symbols
+
+(* To interpret implicits and arg scopes of recursive variables in
+   inductive types and recursive definitions *)
+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
+
+let interning_grammar = ref false
+
+(* Historically for parsing grammar rules, but in fact used only for
+   translator, v7 parsing, and unstrict tactic internalisation *)
+let for_grammar f x =
+  interning_grammar := true;
+  let a = f x in
+  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                                             *)
+
+type internalisation_error =
+  | VariableCapture of identifier
+  | WrongExplicitImplicit
+  | NegativeMetavariable
+  | NotAConstructor of reference
+  | UnboundFixName of bool * identifier
+  | NonLinearPattern of identifier
+  | BadPatternsNumber of int * int
+  | BadExplicitationNumber of explicitation * int option
+
+exception InternalisationError of loc * internalisation_error
+
+let explain_variable_capture id =
+  str "The variable " ++ pr_id id ++ str " occurs in its type"
+
+let explain_wrong_explicit_implicit =
+  str "Found an explicitly given implicit argument but was expecting" ++
+  fnl () ++ str "a regular one"
+
+let explain_negative_metavariable =
+  str "Metavariable numbers must be positive"
+
+let explain_not_a_constructor ref =
+  str "Unknown constructor: " ++ pr_reference ref
+
+let explain_unbound_fix_name is_cofix id =
+  str "The name" ++ spc () ++ pr_id id ++ 
+  spc () ++ str "is not bound in the corresponding" ++ spc () ++
+  str (if is_cofix then "co" else "") ++ str "fixpoint definition"
+
+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
+
+let explain_bad_explicitation_number n po =
+  match n with
+  | ExplByPos n ->
+      let s = match po with
+	| None -> str "a regular argument"
+	| Some p -> int p in
+      str "Bad explicitation number: found " ++ int n ++ 
+      str" but was expecting " ++ s
+  | ExplByName id ->
+      let s = match po with
+	| None -> str "a regular argument"
+	| Some p -> (*pr_id (name_of_position p) in*) failwith "" in
+      str "Bad explicitation name: found " ++ pr_id id ++ 
+      str" but was expecting " ++ s
+
+let explain_internalisation_error = function
+  | VariableCapture id -> explain_variable_capture id
+  | WrongExplicitImplicit -> explain_wrong_explicit_implicit
+  | NegativeMetavariable -> explain_negative_metavariable
+  | NotAConstructor ref -> explain_not_a_constructor ref
+  | UnboundFixName (iscofix,id) -> explain_unbound_fix_name iscofix id
+  | NonLinearPattern id -> explain_non_linear_pattern id
+  | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2
+  | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po
+
+let error_unbound_patvar loc n =
+  user_err_loc
+    (loc,"glob_qualid_or_patvar", str "?" ++ pr_patvar n ++ 
+      str " is unbound")
+
+let error_bad_inductive_type loc =
+  user_err_loc (loc,"",str 
+    "This should be an inductive type applied to names or \"_\"")
+
+(**********************************************************************)
+(* Dump of globalization (to be used by coqdoc)                       *)
+let token_number = ref 0
+let last_pos = ref 0
+
+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
+
+let coqdoc_unfreeze (lt,tn,lp) =
+  Lexer.restore_location_table lt;
+  token_number := tn;
+  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 dp = string_of_dirpath (Lib.library_part ref) in
+  dump_string (Printf.sprintf "R%d %s.%s\n" (fst (unloc loc)) dp id)
+
+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 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
+      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
+    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)
+
+(**********************************************************************)
+(* Contracting "{ _ }" in notations *)
+
+let rec wildcards ntn n =
+  if n = String.length ntn then []
+  else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l
+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_notation_string ntn n =
+  let pos = List.nth (wildcards ntn 0) n in
+  let hd = if pos = 0 then "" else String.sub ntn 0 pos in
+  let tl = 
+    if pos = String.length ntn then "" 
+    else String.sub ntn (pos+1) (String.length ntn - pos -1) in
+  hd ^ "{ _ }" ^ tl
+
+(* This contracts the special case of "{ _ }" for sumbool, sumor notations *)
+(* Remark: expansion of squash at definition is done in metasyntax.ml *)
+let contract_notation ntn l =
+  let ntn' = ref ntn in
+  let rec contract_squash n = function
+    | [] -> []
+    | CNotation (_,"{ _ }",[a]) :: l -> 
+        ntn' := expand_notation_string !ntn' n;
+        contract_squash n (a::l)
+    | a :: l ->
+        a::contract_squash (n+1) l in
+  let l = contract_squash 0 l in
+  (* side effect; don't inline *)
+  !ntn',l
+
+let contract_pat_notation ntn l =
+  let ntn' = ref ntn in
+  let rec contract_squash n = function
+    | [] -> []
+    | CPatNotation (_,"{ _ }",[a]) :: l -> 
+        ntn' := expand_notation_string !ntn' n;
+        contract_squash n (a::l)
+    | a :: l ->
+        a::contract_squash (n+1) l in
+  let l = contract_squash 0 l in
+  (* side effect; don't inline *)
+  !ntn',l
+
+(**********************************************************************)
+(* Remembering the parsing scope of variables in notations            *)
+
+let make_current_scope (scopt,scopes) = option_cons scopt scopes
+
+let set_var_scope loc id (_,scopt,scopes) varscopes =
+  let idscopes = List.assoc id varscopes in
+  if !idscopes <> None & 
+    make_current_scope (out_some !idscopes)
+    <> make_current_scope (scopt,scopes) then
+      user_err_loc (loc,"set_var_scope",
+      pr_id id ++ str " already occurs in a different scope")
+  else
+    idscopes := Some (scopt,scopes)
+
+(**********************************************************************)
+(* Discriminating between bound variables and global references       *)
+
+(* [vars1] is a set of name to avoid (used for the tactic language);
+   [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 (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)
+  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
+  then
+      RVar (loc,id), [], [], []
+  (* Is [id] a notation variable *)
+  else if List.mem_assoc id vars3
+  then
+    (set_var_scope loc id genv vars3; RVar (loc,id), [], [], [])
+  else
+
+  (* Is [id] bound to a free name in ltac (this is an ltac error message) *)
+  try
+    match List.assoc id unbndltacvars with
+      | None -> user_err_loc (loc,"intern_var",
+	  pr_id id ++ str " ist not 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 *)
+  let _ = Sign.lookup_named id vars2 in
+  try
+    (* [id] a section variable *)
+    (* Redundant: could be done in intern_qualid *)
+    let ref = VarRef id in
+    RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref, []
+  with _ ->
+    (* [id] a goal variable *)
+    RVar (loc,id), [], [], []
+
+let find_appl_head_data (_,_,_,_,impls) = function
+  | RRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[]
+  | x -> x,[],[],[]
+
+(* Is it a global reference or a syntactic definition? *)
+let intern_qualid loc qid =
+  try match Nametab.extended_locate qid with
+  | TrueGlobal ref ->
+      if !dump then add_glob loc ref;
+      RRef (loc, ref)
+  | SyntacticDef sp ->
+      Syntax_def.search_syntactic_definition loc sp
+  with Not_found ->
+    error_global_not_found_loc loc qid
+
+let intern_inductive r =
+  let loc,qid = qualid_of_reference r in
+  try match Nametab.extended_locate qid with
+  | TrueGlobal (IndRef ind) -> ind, []
+  | TrueGlobal _ -> raise Not_found
+  | SyntacticDef sp ->
+      (match Syntax_def.search_syntactic_definition loc sp with
+	| RApp (_,RRef(_,IndRef ind),l)
+	    when List.for_all (function RHole _ -> true | _ -> false) l ->
+	    (ind, List.map (fun _ -> Anonymous) l)
+	| _ -> raise Not_found)
+  with Not_found ->
+    error_global_not_found_loc loc qid
+
+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))
+      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 
+  in r
+
+let apply_scope_env (ids,_,scopes as env) = function
+  | [] -> (ids,None,scopes), []
+  | sc::scl -> (ids,sc,scopes), scl
+
+let rec adjust_scopes env scopes = function
+  | [] -> []
+  | a::args ->
+      let (enva,scopes) = apply_scope_env env scopes in
+      enva :: adjust_scopes env scopes args
+
+let rec simple_adjust_scopes = function
+  | _,[] -> []
+  | [],_::args -> None :: simple_adjust_scopes ([],args)
+  | sc::scopes,_::args -> sc :: simple_adjust_scopes (scopes,args)
+
+(**********************************************************************)
+(* Cases                                                              *)
+
+(* 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))
+
+let check_linearity lhs ids =
+  match has_duplicate ids with
+    | Some id ->
+	raise (InternalisationError (loc_of_lhs lhs,NonLinearPattern id))
+    | 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)))
+
+(* 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 =
+  ids@[id], if ids=[] then subst else (id, List.hd ids)::subst
+
+let alias_of = function
+  | ([],_) -> Anonymous
+  | (id::_,_) -> Name id
+
+let message_redundant_alias (id1,id2) =
+  if_verbose warning 
+   ("Alias variable "^(string_of_id id1)^" is merged with "^(string_of_id id2))
+
+(* Expanding notations *)
+
+let decode_patlist_value = function
+  | CPatCstr (_,_,l) -> l
+  | _ -> anomaly "Ill-formed list argument of notation"
+
+let rec subst_pat_iterator y t = function
+  | PatVar (_,id) as x ->
+      if id = Name y then t else x
+  | PatCstr (loc,id,l,alias) ->
+      PatCstr (loc,id,List.map (subst_pat_iterator y t) l,alias)
+
+let subst_cases_pattern loc aliases intern subst scopes a =
+  let rec aux aliases subst = function
+  | AVar id ->
+      begin
+	(* subst remembers the delimiters stack in the interpretation *)
+	(* of the notations *)
+	try 
+	  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
+	  anomaly ("Unbound pattern notation variable: "^(string_of_id id))
+	  (*
+	  (* Happens for local notation joint with inductive/fixpoint defs *)
+	  if aliases <> ([],[]) then
+	    anomaly "Pattern notation without constructors";
+	  [[id],[]], PatVar (loc,Name id)
+	  *)
+      end
+  | ARef (ConstructRef c) ->
+      [aliases], 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 _,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)
+  | 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 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
+      with Not_found -> 
+          anomaly "Inconsistent substitution of recursive notation")
+  | t -> user_err_loc (loc,"",str "Invalid notation for pattern")
+  in aux aliases subst a
+
+(* Differentiating between constructors and matching variables *)
+type pattern_qualid_kind =
+  | ConstrPat of (constructor * cases_pattern list)
+  | VarPat of identifier
+
+let rec patt_of_rawterm loc cstr =
+  match cstr with
+    | RRef (_,(ConstructRef c as x)) ->
+	if !dump then add_glob loc x; 
+ 	(c,[])
+    | 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 npar = mib.Declarations.mind_nparams in
+        let (params,args) =
+          if List.length pl <= npar then (pl,[]) else
+            list_chop npar pl in
+        (* All parameters must be _ *)
+        List.iter
+          (function RHole _ -> ()
+            | _ -> raise Not_found) params;
+        let pl' = List.map
+          (fun c ->
+            let (c,pl) = patt_of_rawterm loc c in
+            PatCstr(loc,c,pl,Anonymous)) args in
+        (c,pl')
+    | _ -> raise Not_found
+
+let find_constructor ref =
+  let (loc,qid) = qualid_of_reference ref in
+  let gref =
+    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
+
+let find_pattern_variable = function
+  | Ident (loc,id) -> id
+  | Qualid (loc,_) as x -> raise (InternalisationError(loc,NotAConstructor x))
+
+let maybe_constructor ref =
+  try ConstrPat (find_constructor ref)
+  with
+      (* patt var does not exists globally *)
+    | 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 ++
+              str " is understood as a pattern variable");
+        VarPat (find_pattern_variable ref)
+
+let mustbe_constructor loc ref = 
+  try find_constructor ref
+  with (Environ.NotEvaluableConst _ | Not_found) ->
+    raise (InternalisationError (loc,NotAConstructor ref))
+
+let rec intern_cases_pattern scopes aliases tmp_scope = function
+  | CPatAlias (loc, p, id) ->
+      let aliases' = merge_aliases aliases id in
+      intern_cases_pattern 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)
+  | CPatNotation (_,"( _ )",[a]) ->
+      intern_cases_pattern 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 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)
+  | CPatDelimiters (loc, key, e) ->
+      intern_cases_pattern (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))
+	 | VarPat id ->
+	     let aliases = merge_aliases aliases id in
+	     ([aliases], PatVar (loc,alias_of aliases)))
+  | CPatAtom (loc, None) ->
+      ([aliases], PatVar (loc,alias_of aliases))
+
+(**********************************************************************)
+(* Fix and CoFix                                                      *)
+
+(**********************************************************************)
+(* Utilities for binders                                              *)
+
+let check_capture loc ty = function
+  | Name id when occur_var_constr_expr id ty ->
+      raise (InternalisationError (loc,VariableCapture id))
+  | _ ->
+      ()
+
+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, BinderType na))
+  | x -> x
+
+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 \
+of its constructor")
+
+let push_name_env lvar (ids,tmpsc,scopes as env) = function
+  | Anonymous -> env 
+  | Name id -> 
+      check_hidden_implicit_parameters id lvar;
+      (Idset.add id ids,tmpsc,scopes)
+
+(**********************************************************************)
+(* Utilities for application                                          *)
+
+let merge_impargs l args =
+  List.fold_right (fun a l ->
+    match a with 
+      | (_,Some (_,(ExplByName id as x))) when 
+	  List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l
+      | _ -> a::l)
+    l args 
+
+let check_projection isproj nargs r = 
+  match (r,isproj) with
+  | RRef (loc, ref), Some nth ->
+      (try
+	let n = Recordops.find_projection_nparams ref in
+	if nargs < nth then 
+	  user_err_loc (loc,"",str "Projection has not enough parameters");
+      with Not_found -> 
+	user_err_loc
+	(loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection"))
+  | _, Some _ -> user_err_loc (loc_of_rawconstr r, "", str "Not a projection")
+  | _, None -> ()
+
+let set_hole_implicit i = function
+  | RRef (loc,r) -> (loc,ImplicitArg (r,i))
+  | RVar (loc,id) -> (loc,ImplicitArg (VarRef id,i))
+  | _ -> anomaly "Only refs have implicits"
+
+let exists_implicit_name id =
+  List.exists (fun imp -> is_status_implicit imp & id = name_of_implicit imp)
+
+let extract_explicit_arg imps args =
+  let rec aux = function
+  | [] -> [],[]
+  | (a,e)::l ->
+      let (eargs,rargs) = aux l in
+      match e with
+      | None -> (eargs,a::rargs)
+      | Some (loc,pos) ->
+	  let id = match pos with
+	  | ExplByName id ->
+	      if not (exists_implicit_name id imps) then
+		user_err_loc (loc,"",str "Wrong argument name: " ++ pr_id id);
+	      if List.mem_assoc id eargs then
+		user_err_loc (loc,"",str "Argument name " ++ pr_id id
+		++ str " occurs more than once");
+	      id
+	  | ExplByPos p ->
+	      let id =
+		try 
+		  let imp = List.nth imps (p-1) in
+		  if not (is_status_implicit imp) then failwith "imp";
+		  name_of_implicit imp
+		with Failure _ (* "nth" | "imp" *) ->
+		  user_err_loc (loc,"",str"Wrong argument position: " ++ int p)
+	      in
+	      if List.mem_assoc id eargs then
+		user_err_loc (loc,"",str"Argument at position " ++ int p ++
+		  str " is mentioned more than once");
+	      id in
+	  ((id,(loc,a))::eargs,rargs)
+  in aux 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 id = try coerce_to_id (fst (List.assoc id subst)) with Not_found -> id in
+  id,(Idset.add id ids,tmpsc,scopes)
+
+let decode_constrlist_value = function
+  | CAppExpl (_,_,l) -> l
+  | _ -> anomaly "Ill-formed list argument of notation"
+
+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) =
+  function
+  | AVar id ->
+      begin
+	(* subst remembers the delimiters stack in the interpretation *)
+	(* of the notations *)
+	try 
+	  let (a,(scopt,subscopes)) = List.assoc id subst in
+	  interp (ids,scopt,subscopes@scopes) a
+	with Not_found -> 
+	  (* Happens for local notation joint with inductive/fixpoint defs *)
+	  RVar (loc,id)
+      end
+  | 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 termin = 
+          subst_aconstr_in_rawconstr loc interp subst (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))
+            (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
+
+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 subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
+  subst_aconstr_in_rawconstr loc intern subst env c
+
+let set_type_scope (ids,tmp_scope,scopes) =
+  (ids,Some Symbols.type_scope,scopes)
+
+let reset_tmp_scope (ids,tmp_scope,scopes) =
+  (ids,None,scopes)
+
+(**********************************************************************)
+(* Main loop                                                          *)
+
+let internalise sigma 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
+	(match intern_impargs c env imp subscopes l with
+          | [] -> c
+          | l -> RApp (constr_loc x, c, l))
+    | CFix (loc, (locid,iddef), dl) ->
+        let lf = List.map (fun (id,_,_,_,_) -> id) dl in
+        let dl = Array.of_list dl in
+	let n =
+	  try
+	    (list_index iddef lf) -1
+          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),
+              Array.of_list lf,
+              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
+	let n =
+          try 
+	    (list_index iddef lf) -1
+          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) =
+              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,RCoFix n,
+              Array.of_list lf,
+              Array.map (fun (bl,_,_) -> bl) idl,
+              Array.map (fun (_,ty,_) -> ty) idl,
+              Array.map (fun (_,_,bd) -> bd) idl)
+    | CArrow (loc,c1,c2) ->
+        RProd (loc, Anonymous, intern_type env c1, intern_type env c2)
+    | CProdN (loc,[],c2) ->
+        intern_type env c2
+    | CProdN (loc,(nal,ty)::bll,c2) ->
+        iterate_prod loc env ty (CProdN (loc, bll, c2)) nal
+    | CLambdaN (loc,[],c2) ->
+        intern env c2
+    | CLambdaN (loc,(nal,ty)::bll,c2) ->
+	iterate_lam loc (reset_tmp_scope env) ty (CLambdaN (loc, bll, c2)) nal
+    | 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 (_,"( _ )",[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
+    | CDelimiters (loc, key, e) ->
+	intern (ids,None,find_delimiters_scope loc key::scopes) e
+    | CAppExpl (loc, (isproj,ref), args) ->
+        let (f,_,args_scopes,_) = intern_reference env lvar ref in
+	check_projection isproj (List.length args) f;
+	RApp (loc, f, intern_args env args_scopes args)
+    | CApp (loc, (isproj,f), args) ->
+        let isproj,f,args = match f with
+          (* Compact notations like "t.(f args') args" *)
+          | CApp (_,(Some _,f), args') when isproj=None -> isproj,f,args'@args
+          (* Don't compact "(f args') args" to resolve implicits separately *)
+          | _ -> isproj,f,args in
+	let (c,impargs,args_scopes,l) =
+          match f with
+            | CRef ref -> intern_reference env lvar ref
+            | CNotation (loc,ntn,[]) ->
+                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
+	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) ->
+        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)
+	  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)
+    | 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
+        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
+        RIf (loc, c', (na', p'), intern env b1, intern env b2)
+    | CHole loc -> 
+	RHole (loc, 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, _) ->
+	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)
+
+    | CDynamic (loc,d) -> RDynamic (loc,d)
+
+  and intern_type (ids,_,scopes) =
+    intern (ids,Some Symbols.type_scope,scopes)
+
+  and intern_local_binder ((ids,ts,sc as env),bl) = function
+      LocalRawAssum(nal,ty) ->
+        let ty = 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)
+
+  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 = 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
+    | None -> 
+	[], None in
+    let na = match tm', na with
+      | RVar (_,id), None when Idset.mem id vars & not !Options.v7 -> Name id
+      | _, None -> Anonymous
+      | _, Some na -> na in
+    (tm',(na,typ)), na::ids
+
+  and iterate_prod loc2 env ty body = function
+    | (loc1,na)::nal ->
+	if nal <> [] then check_capture loc1 ty na;
+	let body = iterate_prod loc2 (push_name_env lvar env na) ty body nal in
+	let ty = locate_if_isevar loc1 na (intern_type env ty) in
+	RProd (join_loc loc1 loc2, na, ty, body)
+    | [] -> intern_type env body
+
+  and iterate_lam loc2 env ty body = function
+    | (loc1,na)::nal ->
+	if nal <> [] then check_capture loc1 ty na;
+	let body = iterate_lam loc2 (push_name_env lvar env na) ty body nal in
+	let ty = locate_if_isevar loc1 na (intern_type env ty) in
+	RLambda (join_loc loc1 loc2, na, ty, body)
+    | [] -> intern env body
+
+  and intern_impargs c env l subscopes args =
+    let eargs, rargs = extract_explicit_arg l args in
+    let rec aux n impl subscopes eargs rargs =
+      let (enva,subscopes') = apply_scope_env env subscopes in
+      match (impl,rargs) with
+      | (imp::impl', rargs) when is_status_implicit imp ->
+	  begin try 
+	    let id = name_of_implicit imp in
+	    let (_,a) = List.assoc id eargs in
+	    let eargs' = List.remove_assoc id eargs in
+	    intern enva a :: aux (n+1) impl' subscopes' eargs' rargs
+	  with Not_found ->
+	  if rargs=[] & eargs=[] &
+	    not (List.for_all is_status_implicit impl') then
+	    (* Less regular arguments than expected: don't complete *)
+	    (* with implicit arguments *)
+	    []
+	  else
+	    RHole (set_hole_implicit n c) :: 
+	      aux (n+1) impl' subscopes' eargs rargs
+	  end
+      | (imp::impl', a::rargs') ->
+	  intern enva a :: aux (n+1) impl' subscopes' eargs rargs'
+      | (imp::impl', []) -> 
+	  if eargs <> [] then 
+	    (let (id,(loc,_)) = List.hd eargs in
+	    user_err_loc (loc,"",str "Not enough non implicit
+	    arguments to accept the argument bound to " ++ pr_id id));
+	  []
+      | ([], rargs) ->
+	  assert (eargs = []);
+	  intern_args env subscopes rargs
+    in aux 1 l subscopes eargs rargs
+
+  and intern_args env subscopes = function
+    | [] -> []
+    | a::args ->
+        let (enva,subscopes) = apply_scope_env env subscopes in
+        (intern enva a) :: (intern_args env subscopes args)
+
+  in 
+  try 
+    intern env c
+  with
+      InternalisationError (loc,e) ->
+	user_err_loc (loc,"internalize",explain_internalisation_error e)
+
+(**************************************************************************)
+(* Functions to translate constr_expr into rawconstr                       *)
+(**************************************************************************)
+
+let extract_ids env =
+  List.fold_right Idset.add 
+    (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 interp_rawconstr_gen isarity sigma env allow_soapp ltacvar c =
+  interp_rawconstr_gen_with_implicits isarity sigma env ([],[]) allow_soapp ltacvar 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
+
+(*
+(* 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
+*)
+
+(*********************************************************************)
+(* 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_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 type_judgment_of_rawconstr sigma env c =
+  understand_type_judgment sigma env (interp_rawconstr sigma env 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 []
+
+(*  List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*)
+
+type ltac_sign = 
+  identifier list * (identifier * identifier option) list
+
+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
+
+(*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 sigma env c typ = 
+  understand_gen sigma env [] (Some typ) (interp_rawconstr sigma env 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_constrpattern_gen sigma env ltacvar c =
+  let c = interp_rawconstr_gen false sigma env true (ltacvar,[]) c in
+  pattern_of_rawconstr c
+
+let interp_constrpattern sigma env c =
+  interp_constrpattern_gen sigma env [] 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
+  (* 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 *)
+  (* Variables occurring in binders have no relevant scope since bound *)
+  List.map
+    (fun (id,r) -> (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl,
+  a
+
+(**********************************************************************)
+(* Locating reference, possibly via an abbreviation *)
+
+let locate_reference qid =
+  match Nametab.extended_locate qid with
+    | TrueGlobal ref -> ref
+    | SyntacticDef kn -> 
+	match Syntax_def.search_syntactic_definition dummy_loc kn with
+	  | Rawterm.RRef (_,ref) -> ref
+	  | _ -> raise Not_found
+
+let is_global id =
+  try 
+    let _ = locate_reference (make_short_qualid id) in true
+  with Not_found -> 
+    false
+
+let global_reference id = 
+  constr_of_reference (locate_reference (make_short_qualid id))
+
+let construct_reference ctx id =
+  try
+    Term.mkVar (let _ = Sign.lookup_named id ctx in id)
+  with Not_found ->
+    global_reference id
+
+let global_reference_in_absolute_module dir id = 
+  constr_of_reference (Nametab.absolute_reference (Libnames.make_path dir id))
+
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
new file mode 100644
index 00000000..a65ab6a7
--- /dev/null
+++ b/interp/constrintern.mli
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: constrintern.mli,v 1.15.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Evd
+open Environ
+open Libnames
+open Rawterm
+open Pattern
+open Coqast
+open Topconstr
+open Termops
+(*i*)
+
+(*s Translation from front abstract syntax of term to untyped terms (rawconstr)
+
+   The translation performs:
+
+   - resolution of names :
+      - check all variables are bound
+      - make absolute the references to global objets
+   - resolution of symbolic notations using scopes
+   - insert existential variables for implicit arguments
+*)
+
+(* To interpret implicits and arg scopes of recursive variables in
+   inductive types and recursive definitions *)
+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
+
+val interp_constrpattern : 
+  evar_map -> env -> constr_expr -> patvar list * constr_pattern
+
+val interp_reference : ltac_sign -> reference -> rawconstr
+
+(* Locating references of constructions, possibly via a syntactic definition *)
+
+val locate_reference : qualid -> global_reference
+val is_global : identifier -> bool
+val construct_reference : named_context -> identifier -> constr
+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
+
+(* Globalization leak for Grammar *)
+val for_grammar : ('a -> 'b) -> 'a -> 'b
+
+(* Coqdoc utility functions *)
+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
new file mode 100644
index 00000000..8ce9bfaf
--- /dev/null
+++ b/interp/coqlib.ml
@@ -0,0 +1,294 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqlib.ml,v 1.14.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Term
+open Libnames
+open Pattern
+open Nametab
+
+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
+  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 list_try_find f = 
+  let rec try_find_f = function
+    | [] -> raise Not_found
+    | h::t -> try f h with Not_found -> try_find_f t
+  in 
+  try_find_f
+
+let has_suffix_in_dirs dirs ref =
+  let dir = dirpath (sp_of_global ref) in
+  List.exists (fun d -> is_dirpath_prefix_of d dir) dirs
+
+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 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
+    | [] ->
+	anomalylabstrm "" (str (locstr^": cannot find "^s^
+	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
+	prlist_with_sep pr_coma pr_dirpath dirs)
+    | l ->
+	anomalylabstrm "" 
+	(str (locstr^": found more than once object of name "^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  
+
+let arith_dir = ["Coq";"Arith"]
+let arith_modules = [arith_dir]
+
+let narith_dir = ["Coq";"NArith"]
+
+let zarith_dir = ["Coq";"ZArith"]
+let zarith_base_modules = [narith_dir;zarith_dir]
+
+let init_dir = ["Coq";"Init"]
+let init_modules = [
+  init_dir@["Datatypes"];
+  init_dir@["Logic"];
+  init_dir@["Specif"];
+  init_dir@["Logic_Type"];
+  init_dir@["Peano"];
+  init_dir@["Wf"]
+]
+  
+let coq_id = id_of_string "Coq"
+let init_id = id_of_string "Init"
+let arith_id = id_of_string "Arith"
+let datatypes_id = id_of_string "Datatypes"
+
+let logic_module = make_dir ["Coq";"Init";"Logic"]
+let logic_type_module = make_dir ["Coq";"Init";"Logic_Type"]
+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 nat_path = make_path datatypes_module (id_of_string "nat")
+
+let glob_nat = IndRef (nat_path,0)
+
+let path_of_O = ((nat_path,0),1)
+let path_of_S = ((nat_path,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")
+
+let glob_eq = IndRef (eq_path,0)
+let glob_eqT = IndRef (eqT_path,0)
+
+type coq_sigma_data = {
+  proj1 : constr;
+  proj2 : constr;
+  elim  : constr;
+  intro : constr;
+  typ   : constr }
+
+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_type () =
+  { proj1 = init_constant ["Specif"] "projT1";
+    proj2 = init_constant ["Specif"] "projT2";
+    elim = init_constant ["Specif"] "sigT_rec";
+    intro = init_constant ["Specif"] "existT";
+    typ = init_constant ["Specif"] "sigT" }
+
+(* Equalities *)
+type coq_leibniz_eq_data = {
+  eq   : constr;
+  refl : constr;
+  ind  : constr;
+  rrec : constr option;
+  rect : constr option;
+  congr: constr;
+  sym  : constr }
+
+let lazy_init_constant dir id = lazy (init_constant dir id)
+
+(* Equality on Set *)
+let coq_eq_eq = lazy_init_constant ["Logic"] "eq"
+let coq_eq_refl = lazy_init_constant ["Logic"] "refl_equal"
+let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind"
+let coq_eq_rec = lazy_init_constant ["Logic"] "eq_rec"
+let coq_eq_rect = lazy_init_constant ["Logic"] "eq_rect"
+let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal"
+let coq_eq_sym  = lazy_init_constant ["Logic"] "sym_eq"
+let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2"
+
+let build_coq_eq_data () = {
+  eq = Lazy.force coq_eq_eq;
+  refl = Lazy.force coq_eq_refl;
+  ind = Lazy.force coq_eq_ind;
+  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 }
+
+let build_coq_eq () = Lazy.force coq_eq_eq
+let build_coq_f_equal2 () = Lazy.force coq_f_equal2
+
+(* Specif *)
+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"
+
+(* The False proposition *)
+let coq_False  = lazy_init_constant ["Logic"] "False"
+
+(* The True proposition and its unique proof *)
+let coq_True   = lazy_init_constant ["Logic"] "True"
+let coq_I      = lazy_init_constant ["Logic"] "I"
+
+(* Connectives *)
+let coq_not = lazy_init_constant ["Logic"] "not"
+let coq_and = lazy_init_constant ["Logic"] "and"
+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
+
+let build_coq_False () = Lazy.force coq_False
+let build_coq_not ()   = Lazy.force coq_not
+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_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")
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
new file mode 100644
index 00000000..7ac2a5c9
--- /dev/null
+++ b/interp/coqlib.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: coqlib.mli,v 1.5.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+(*i*)
+open Names
+open Libnames
+open Nametab
+open Term
+open Pattern
+(*i*)
+
+(*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*)
+
+val gen_reference : string->string list -> string -> global_reference
+val gen_constant : string->string list -> string -> constr
+
+(* Search in several modules (not prefixed by "Coq") *)
+val gen_constant_in_modules : string->string list list-> string -> constr
+val arith_modules : string list list
+val zarith_base_modules : string list list
+val init_modules : string list list
+
+(*s Global references *)
+
+(* Modules *)
+val logic_module : dir_path
+val logic_type_module : dir_path
+
+(* Natural numbers *)
+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
+
+(* 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
+   them at runtime. This is the purpose of the [constr delayed] and
+   [constr_pattern delayed] types. Objects of this time needs to be
+   applied to [()] to get the actual constr or pattern at runtime *)
+
+type 'a delayed = unit -> 'a
+
+(*s For Equality tactics *)
+type coq_sigma_data = {
+  proj1 : constr;
+  proj2 : constr;
+  elim  : constr;
+  intro : constr;
+  typ   : constr }
+
+val build_sigma_set : coq_sigma_data delayed
+val build_sigma_type : coq_sigma_data delayed
+
+type coq_leibniz_eq_data = {
+  eq   : constr;
+  refl : constr;
+  ind  : constr;
+  rrec : constr option;
+  rect : constr option;
+  congr: constr;
+  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_eq : constr delayed (* = (build_coq_eq_data()).eq *)
+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
+
+(*s Connectives *)
+(* The False proposition *)
+val build_coq_False : constr delayed
+
+(* The True proposition and its unique proof *)
+val build_coq_True : constr delayed
+val build_coq_I : constr delayed
+
+(* Negation *)
+val build_coq_not : constr delayed
+
+(* Conjunction *)
+val build_coq_and : constr delayed
+
+(* Disjunction *)
+val build_coq_or : constr delayed
+
+(* Existential quantifier *)
+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_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
diff --git a/interp/doc.tex b/interp/doc.tex
new file mode 100644
index 00000000..4d60ec34
--- /dev/null
+++ b/interp/doc.tex
@@ -0,0 +1,14 @@
+
+\newpage
+\section*{The interpretation of Coq front abstract syntax of terms}
+
+\ocwsection \label{library}
+This chapter describes the translation from \Coq\ context-dependent
+front abstract syntax of terms (\verb=front=} to and from the
+context-free, untyped, raw form of constructions (\verb=rawconstr=).
+
+The modules translating back and forth the front abstract syntax are
+organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=library.dep.ps}\end{center}
diff --git a/interp/genarg.ml b/interp/genarg.ml
new file mode 100644
index 00000000..af3d805a
--- /dev/null
+++ b/interp/genarg.ml
@@ -0,0 +1,228 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: genarg.ml,v 1.9.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Nametab
+open Rawterm
+open Topconstr
+open Term
+
+type argument_type =
+  (* Basic types *)
+  | BoolArgType
+  | IntArgType
+  | IntOrVarArgType
+  | StringArgType
+  | PreIdentArgType
+  | IntroPatternArgType
+  | IdentArgType
+  | HypArgType
+  | RefArgType
+  (* Specific types *)
+  | SortArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | TacticArgType
+  | CastedOpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | List0ArgType of argument_type
+  | List1ArgType of argument_type
+  | OptArgType of 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
+
+(* Dynamics but tagged by a type expression *)
+
+type ('a,'b) generic_argument = argument_type * Obj.t
+
+let dyntab = ref ([] : string list)
+
+type ('a,'b,'c) abstract_argument_type = argument_type
+
+let create_arg s =
+  if List.mem s !dyntab then
+    anomaly ("Genarg.create: already declared generic argument " ^ s);
+  dyntab := s :: !dyntab;
+  let t = ExtraArgType s in
+  (t,t,t)
+
+let exists_argtype s = List.mem s !dyntab
+
+type intro_pattern_expr =
+  | IntroOrAndPattern of case_intro_pattern_expr
+  | IntroWildcard
+  | IntroIdentifier of identifier
+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
+
+and pr_case_intro_pattern = function
+  | [_::_ as pl] ->
+      str "(" ++ hv 0 (prlist_with_sep pr_coma pr_intro_pattern pl) ++ str ")"
+  | pll ->
+      str "[" ++
+      hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc pr_intro_pattern) pll)
+      ++ str "]"
+
+type open_constr = Evd.evar_map * Term.constr
+type open_constr_expr = constr_expr
+type open_rawconstr = rawconstr_and_expr
+
+let rawwit_bool = BoolArgType
+let globwit_bool = BoolArgType
+let wit_bool = BoolArgType
+
+let rawwit_int = IntArgType
+let globwit_int = IntArgType
+let wit_int = IntArgType
+
+let rawwit_int_or_var = IntOrVarArgType
+let globwit_int_or_var = IntOrVarArgType
+let wit_int_or_var = IntOrVarArgType
+
+let rawwit_string = StringArgType
+let globwit_string = StringArgType
+let wit_string = StringArgType
+
+let rawwit_pre_ident = PreIdentArgType
+let globwit_pre_ident = PreIdentArgType
+let wit_pre_ident = PreIdentArgType
+
+let rawwit_intro_pattern = IntroPatternArgType
+let globwit_intro_pattern = IntroPatternArgType
+let wit_intro_pattern = IntroPatternArgType
+
+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_ref = RefArgType
+let globwit_ref = RefArgType
+let wit_ref = RefArgType
+
+let rawwit_quant_hyp = QuantHypArgType
+let globwit_quant_hyp = QuantHypArgType
+let wit_quant_hyp = QuantHypArgType
+
+let rawwit_sort = SortArgType
+let globwit_sort = SortArgType
+let wit_sort = SortArgType
+
+let rawwit_constr = ConstrArgType
+let globwit_constr = ConstrArgType
+let wit_constr = ConstrArgType
+
+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_casted_open_constr = CastedOpenConstrArgType
+let globwit_casted_open_constr = CastedOpenConstrArgType
+let wit_casted_open_constr = CastedOpenConstrArgType
+
+let rawwit_constr_with_bindings = ConstrWithBindingsArgType
+let globwit_constr_with_bindings = ConstrWithBindingsArgType
+let wit_constr_with_bindings = ConstrWithBindingsArgType
+
+let rawwit_bindings = BindingsArgType
+let globwit_bindings = BindingsArgType
+let wit_bindings = BindingsArgType
+
+let rawwit_red_expr = RedExprArgType
+let globwit_red_expr = RedExprArgType
+let wit_red_expr = RedExprArgType
+
+let wit_list0 t = List0ArgType t
+
+let wit_list1 t = List1ArgType t
+
+let wit_opt t = OptArgType t
+
+let wit_pair t1 t2 = PairArgType (t1,t2)
+
+let in_gen t o = (t,Obj.repr o)
+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) ->
+      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) ->
+      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) ->
+      (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) ->
+      let (x1,x2) = Obj.magic l in
+      f (in_gen t1 x1) (in_gen t2 x2)
+  | _ -> failwith "Genarg: not a pair"
+
+let app_list0 f = function
+  | (List0ArgType t as u, l) ->
+      let o = Obj.magic l in
+      (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o))
+  | _ -> failwith "Genarg: not a list0"
+
+let app_list1 f = function
+  | (List1ArgType t as u, l) ->
+      let o = Obj.magic l in
+      (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o))
+  | _ -> failwith "Genarg: not a list1"
+
+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))
+  | _ -> failwith "Genarg: not an opt"
+
+let app_pair f1 f2 = function
+  | (PairArgType (t1,t2) as u, l) ->
+      let (o1,o2) = Obj.magic l in
+      let o1 = out_gen t1 (f1 (in_gen t1 o1)) in
+      let o2 = out_gen t2 (f2 (in_gen t2 o2)) in
+      (u, Obj.repr (o1,o2))
+  | _ -> failwith "Genarg: not a pair"
+
+let unquote x = x
+
+type an_arg_of_this_type = Obj.t
+
+let in_generic t x = (t, Obj.repr x)
diff --git a/interp/genarg.mli b/interp/genarg.mli
new file mode 100644
index 00000000..59b6e10d
--- /dev/null
+++ b/interp/genarg.mli
@@ -0,0 +1,262 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: genarg.mli,v 1.9.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Libnames
+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*)
+(* in the environment by the effective calls to Intro, Inversion, etc *)
+(* The constr_expr field is None in TacDef though *)
+type rawconstr_and_expr = rawconstr * constr_expr option
+
+type open_constr = Evd.evar_map * Term.constr
+type open_constr_expr = constr_expr
+type open_rawconstr = rawconstr_and_expr
+
+type intro_pattern_expr =
+  | IntroOrAndPattern of case_intro_pattern_expr
+  | IntroWildcard
+  | IntroIdentifier of identifier
+and case_intro_pattern_expr = intro_pattern_expr list list
+
+val pr_intro_pattern : intro_pattern_expr -> Pp.std_ppcmds
+val pr_case_intro_pattern : case_intro_pattern_expr -> Pp.std_ppcmds
+
+(* The route of a generic argument, from parsing to evaluation
+
+              parsing        in_raw                           out_raw
+    char stream ----> rawtype ----> rawconstr generic_argument ---->
+                                                                   |
+                                                                   | interp
+                                                                   V
+                          type  <---- constr generic_argument  <----
+                                  out                            in
+
+To distinguish between the uninterpreted (raw) and the interpreted
+worlds, we annotate the type generic_argument by a phantom argument
+which is either constr_expr or constr (actually we add also a second
+argument raw_tactic_expr and tactic, but this is only for technical
+reasons, because these types are undefined at the type of compilation
+of Genarg).
+
+Transformation for each type :
+tag   f                          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
+CastedOpenConstrArgType        constr_expr              open_constr
+ConstrBindingsArgType      constr_expr with_bindings constr with_bindings
+List0ArgType of argument_type
+List1ArgType of argument_type
+OptArgType of argument_type
+ExtraArgType of string         '_a                      '_b
+*)
+
+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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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
+
+(* 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 wit_list0 :
+  ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type
+
+val wit_list1 :
+  ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type
+
+val wit_opt :
+  ('a,'co,'ta) abstract_argument_type -> ('a option,'co,'ta) abstract_argument_type
+
+val wit_pair :
+  ('a,'co,'ta) abstract_argument_type ->
+  ('b,'co,'ta) abstract_argument_type ->
+      ('a * 'b,'co,'ta) abstract_argument_type
+
+(* 'a generic_argument = (Sigma t:type. t[constr/'a]) *)
+type ('a,'b) generic_argument
+
+val fold_list0 : 
+ (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c
+
+val fold_list1 : 
+ (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c
+
+val fold_opt :
+ (('a,'b) generic_argument -> 'c) -> 'c -> ('a,'b) generic_argument -> 'c
+
+val fold_pair :
+ (('a,'b) generic_argument -> ('a,'b) generic_argument -> 'c) -> 
+      ('a,'b) generic_argument -> 'c
+
+(* [app_list0] fails if applied to an argument not of tag [List0 t]
+    for some [t]; it's the responsability of the caller to ensure it *)
+
+val app_list0 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> 
+('a,'b) generic_argument -> ('c,'d) generic_argument
+
+val app_list1 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> 
+('a,'b) generic_argument -> ('c,'d) generic_argument
+
+val app_opt : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> 
+('a,'b) generic_argument -> ('c,'d) generic_argument
+
+val app_pair :
+  (('a,'b) generic_argument -> ('c,'d) generic_argument) ->
+      (('a,'b) generic_argument -> ('c,'d) generic_argument)
+   -> ('a,'b) generic_argument -> ('c,'d) generic_argument
+
+(* Manque l'ordre supérieur, on aimerait ('co,'ta) 'a; manque aussi le
+   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
+
+val exists_argtype : string -> bool
+
+type argument_type =
+  (* Basic types *)
+  | BoolArgType
+  | IntArgType
+  | IntOrVarArgType
+  | StringArgType
+  | PreIdentArgType
+  | IntroPatternArgType
+  | IdentArgType
+  | HypArgType
+  | RefArgType
+  (* Specific types *)
+  | SortArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | TacticArgType
+  | CastedOpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | List0ArgType of argument_type
+  | List1ArgType of argument_type
+  | OptArgType of argument_type
+  | PairArgType of argument_type * argument_type
+  | ExtraArgType of string
+
+val genarg_tag : ('a,'b) generic_argument -> argument_type
+
+val unquote : ('a,'co,'ta) abstract_argument_type -> argument_type
+
+(* We'd like
+
+  [in_generic: !b:type, !a:argument_type -> (f a) -> b generic_argument]
+
+   with f a = b if a is Constr, f a = c if a is Tactic, otherwise f a = |a|
+
+   in_generic is not typable; we replace the second argument by an absurd
+   type (with no introduction rule)
+*)
+type an_arg_of_this_type
+
+val in_generic : 
+  argument_type -> an_arg_of_this_type -> ('a,'b) generic_argument
+
+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
new file mode 100644
index 00000000..0929119c
--- /dev/null
+++ b/interp/modintern.ml
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: modintern.ml,v 1.2.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Entries
+open Libnames
+open Topconstr
+open Constrintern
+ 
+let rec make_mp mp = function
+    [] -> mp
+  | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
+
+(*
+(* Since module components are not put in the nametab we try to locate
+the module prefix *)
+exception BadRef
+
+let lookup_qualid (modtype:bool) qid = 
+  let rec make_mp mp = function
+      [] -> mp
+    | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
+  in
+  let rec find_module_prefix dir n =
+    if n<0 then raise Not_found;
+    let dir',dir'' = list_chop n dir in
+    let id',dir''' = 
+      match dir'' with 
+	| hd::tl -> hd,tl 
+	| _ -> anomaly "This list should not be empty!"
+    in
+    let qid' = make_qualid dir' id' in
+      try 
+	match Nametab.locate qid' with
+	  | ModRef mp -> mp,dir'''
+	  | _ -> raise BadRef
+      with
+	  Not_found -> find_module_prefix dir (pred n)
+  in
+    try Nametab.locate qid
+    with Not_found -> 
+      let (dir,id) = repr_qualid qid in
+      let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in
+      let mp = 
+	List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' 
+      in
+	if modtype then
+	  ModTypeRef (make_ln mp (label_of_id id))
+	else
+	  ModRef (MPdot (mp,label_of_id id))
+
+*)
+
+(* Search for the head of [qid] in [binders]. 
+   If found, returns the module_path/kernel_name created from the dirpath
+   and the basename. Searches Nametab otherwise.
+*)
+
+let lookup_module (loc,qid) =
+  try
+    Nametab.locate_module qid
+  with
+    | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid)
+	
+let lookup_modtype (loc,qid) =
+  try
+    Nametab.locate_modtype qid
+  with
+    | Not_found -> 
+	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)
+
+let rec interp_modtype env = function 
+  | CMTEident qid ->
+      MTEident (lookup_modtype qid)
+  | CMTEwith (mty,decl) ->
+      let mty = interp_modtype env mty in
+      let decl = transl_with_decl env decl in
+	MTEwith(mty,decl)
+ 
+
+let rec interp_modexpr env = function 
+  | CMEident qid ->
+      MEident (lookup_module qid)
+  | CMEapply (me1,me2) ->
+      let me1 = interp_modexpr env me1 in
+      let me2 = interp_modexpr env me2 in
+	MEapply(me1,me2)
+
diff --git a/interp/modintern.mli b/interp/modintern.mli
new file mode 100644
index 00000000..050d9f94
--- /dev/null
+++ b/interp/modintern.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: modintern.mli,v 1.1.6.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+
+(*i*)
+open Declarations
+open Environ
+open Entries
+open Topconstr
+(*i*)
+
+(* Module expressions and module types are interpreted relatively to 
+   eventual functor or funsig arguments. *)
+
+val interp_modtype : env -> module_type_ast -> module_type_entry
+
+val interp_modexpr : env -> module_ast -> module_expr
+
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
new file mode 100644
index 00000000..29fb7cc7
--- /dev/null
+++ b/interp/ppextend.ml
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ppextend.ml,v 1.4.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+(*i*)
+open Pp
+open Util
+open Names
+(*i*)
+
+(*s Pretty-print. *)
+
+(* Dealing with precedences *)
+
+type precedence = int
+
+type parenRelation = L | E | Any | Prec of precedence
+
+type tolerability = precedence * parenRelation
+
+type ppbox =
+  | PpHB of int
+  | PpHOVB of int
+  | PpHVB of int
+  | PpVB of int
+  | PpTB
+
+type ppcut =
+  | PpBrk of int * int
+  | PpTbrk of int * int
+  | PpTab
+  | PpFnl
+
+let ppcmd_of_box = function
+  | PpHB n -> h n
+  | PpHOVB n -> hov n
+  | PpHVB n -> hv n
+  | PpVB n -> v n
+  | PpTB   -> t
+
+let ppcmd_of_cut = function
+  | PpTab -> tab ()
+  | PpFnl -> fnl ()
+  | PpBrk(n1,n2) -> brk(n1,n2)
+  | PpTbrk(n1,n2) -> tbrk(n1,n2)
+
+type unparsing = 
+  | UnpMetaVar of int * parenRelation
+  | UnpListMetaVar of int * parenRelation * unparsing list
+  | UnpTerminal of string
+  | UnpBox of ppbox * unparsing list
+  | UnpCut of ppcut
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
new file mode 100644
index 00000000..056b7a42
--- /dev/null
+++ b/interp/ppextend.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: ppextend.mli,v 1.4.2.1 2004/07/16 19:30:22 herbelin Exp $ *)
+
+(*i*)
+open Pp
+open Names
+(*i*)
+
+(*s Pretty-print. *)
+
+(* Dealing with precedences *)
+
+type precedence = int
+
+type parenRelation = L | E | Any | Prec of precedence
+
+type tolerability = precedence * parenRelation
+
+type ppbox =
+  | PpHB of int
+  | PpHOVB of int
+  | PpHVB of int
+  | PpVB of int
+  | PpTB
+
+type ppcut =
+  | PpBrk of int * int
+  | PpTbrk of int * int
+  | PpTab
+  | PpFnl
+
+val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds
+
+val ppcmd_of_cut : ppcut -> std_ppcmds
+
+type unparsing = 
+  | UnpMetaVar of int * parenRelation
+  | UnpListMetaVar of int * parenRelation * unparsing list
+  | UnpTerminal of string
+  | UnpBox of ppbox * unparsing list
+  | UnpCut of ppcut
diff --git a/interp/reserve.ml b/interp/reserve.ml
new file mode 100644
index 00000000..72899676
--- /dev/null
+++ b/interp/reserve.ml
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: reserve.ml,v 1.10.2.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+
+(* Reserved names *)
+
+open Util
+open Pp
+open Names
+open Nameops
+open Summary
+open Libobject
+open Lib
+
+let reserve_table = ref Idmap.empty
+
+let cache_reserved_type (_,(id,t)) =
+  reserve_table := Idmap.add id t !reserve_table
+
+let (in_reserved, _) =
+  declare_object {(default_object "RESERVED-TYPE") with 
+    cache_function = cache_reserved_type }
+
+let _ = 
+  Summary.declare_summary "reserved-type"
+    { Summary.freeze_function = (fun () -> !reserve_table);
+      Summary.unfreeze_function = (fun r -> reserve_table := r);
+      Summary.init_function = (fun () -> reserve_table := Idmap.empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let declare_reserved_type (loc,id) t = 
+  if id <> root_of_id id then
+    user_err_loc(loc,"declare_reserved_type",
+    (pr_id id ++ str
+      " is not reservable: it must have no trailing digits, quote, or _"));
+  begin try
+    let _ = Idmap.find id !reserve_table in 
+    user_err_loc(loc,"declare_reserved_type",
+    (pr_id id++str" is already bound to a type"))
+  with Not_found -> () end;
+  add_anonymous_leaf (in_reserved (id,t))
+
+let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table
+
+open Rawterm
+
+let rec unloc = function
+  | RVar (_,id) -> RVar (dummy_loc,id)
+  | RApp (_,g,args) -> RApp (dummy_loc,unloc g, List.map unloc args)
+  | 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 (dummy_loc,
+        (option_app unloc tyopt,ref (option_app 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)
+  | RIf (_,c,(na,po),b1,b2) ->
+      RIf (dummy_loc,unloc c,(na,option_app 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)))
+              bl,
+            Array.map unloc tyl,
+            Array.map unloc bv)
+  | RCast (_,c,t) -> RCast (dummy_loc,unloc c,unloc t)
+  | RSort (_,x) -> RSort (dummy_loc,x)
+  | RHole (_,x)  -> RHole (dummy_loc,x)
+  | RRef (_,x) -> RRef (dummy_loc,x)
+  | REvar (_,x,l) -> REvar (dummy_loc,x,l)
+  | RPatVar (_,x) -> RPatVar (dummy_loc,x)
+  | RDynamic (_,x) -> RDynamic (dummy_loc,x)
+
+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)
+	else t
+      with Not_found -> t)
+  | Anonymous -> t
diff --git a/interp/reserve.mli b/interp/reserve.mli
new file mode 100644
index 00000000..a79e2c25
--- /dev/null
+++ b/interp/reserve.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: reserve.mli,v 1.2.2.1 2004/07/16 19:30:22 herbelin Exp $ i*)
+
+open Util
+open Names
+open Rawterm
+
+val declare_reserved_type : identifier located -> rawconstr -> unit
+val find_reserved_type : identifier -> rawconstr
+val anonymize_if_reserved : name -> rawconstr -> rawconstr
diff --git a/interp/symbols.ml b/interp/symbols.ml
new file mode 100644
index 00000000..ed151d8e
--- /dev/null
+++ b/interp/symbols.ml
@@ -0,0 +1,662 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: symbols.ml,v 1.31.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Pp
+open Bignat
+open Names
+open Nametab
+open Libnames
+open Summary
+open Rawterm
+open Topconstr
+open Ppextend
+(*i*)
+
+(*s A scope is a set of notations; it includes
+
+  - a set of ML interpreters/parsers for positive (e.g. 0, 1, 15, ...) and
+    negative numbers (e.g. -0, -2, -13, ...). These interpreters may
+    fail if a number has no interpretation in the scope (e.g. there is
+    no interpretation for negative numbers in [nat]); interpreters both for
+    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])
+  - 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
+*)
+
+(**********************************************************************)
+(* Scope of symbols *)
+
+type level = precedence * tolerability list
+type delimiters = string
+
+type scope = {
+  notations: (interpretation * (dir_path * string) * bool) Stringmap.t;
+  delimiters: delimiters option
+}
+
+(* Uninterpreted notation map: notation -> level * dir_path *)
+let notation_level_map = ref Stringmap.empty
+
+(* Scopes table: scope_name -> symbol_interpretation *)
+let scope_map = ref Stringmap.empty
+
+let empty_scope = {
+  notations = Stringmap.empty;
+  delimiters = None
+}
+
+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
+
+(**********************************************************************)
+(* Operations on scopes *)
+
+let declare_scope scope =
+  try let _ = Stringmap.find scope !scope_map in ()
+  with Not_found ->
+(*    Options.if_verbose message ("Creating scope "^scope);*)
+    scope_map := Stringmap.add scope empty_scope !scope_map
+
+let find_scope scope =
+  try Stringmap.find scope !scope_map
+  with Not_found -> error ("Scope "^scope^" is not declared")
+
+let check_scope sc = let _ = find_scope sc in ()
+
+(**********************************************************************)
+(* The global stack of scopes                                         *)
+
+type scope_elem = Scope of scope_name | SingleNotation of string
+type scopes = scope_elem list
+
+let scope_stack = ref []
+
+let current_scopes () = !scope_stack
+
+(* TODO: push nat_scope, z_scope, ... in scopes summary *)
+
+(* Exportation of scopes *)
+let cache_scope (_,(local,op,sc)) =
+  (match sc with Scope sc -> check_scope sc | _ -> ());
+  scope_stack := if op then sc :: !scope_stack else list_except sc !scope_stack
+
+let subst_scope (_,subst,sc) = sc
+
+open Libobject
+
+let classify_scope (_,(local,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+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);
+      subst_function = subst_scope;
+      classify_function = classify_scope;
+      export_function = export_scope }
+
+let open_close_scope (local,opening,sc) =
+  Lib.add_anonymous_leaf (inScope (local,opening,Scope sc))
+
+let empty_scope_stack = []
+
+let push_scope sc scopes = Scope sc :: scopes
+
+(**********************************************************************)
+(* Delimiters *)
+
+let delimiters_map = ref Stringmap.empty
+
+let declare_delimiters scope key =
+  let sc = find_scope scope in
+  if sc.delimiters <> None && Options.is_verbose () then begin
+    let old = out_some sc.delimiters in
+    Options.if_verbose 
+      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)
+  end;
+  delimiters_map := Stringmap.add key scope !delimiters_map
+
+let find_delimiters_scope loc key = 
+  try Stringmap.find key !delimiters_map
+  with Not_found -> 
+    user_err_loc 
+    (loc, "find_delimiters", str ("Unknown scope delimiting key "^key))
+
+(* Uninterpretation tables *)
+
+type interp_rule =
+  | NotationRule of scope_name option * notation
+  | SynDefRule of kernel_name
+
+(* We define keys for rawterm and aconstr to split the syntax entries
+   according to the key of the pattern (adapted from Chet Murthy by HH) *)
+
+type key =
+  | RefKey of global_reference
+  | Oth
+
+(* Scopes table : interpretation -> scope_name *)
+let notations_key_table = ref Gmapl.empty
+let numeral_key_table = Hashtbl.create 7
+
+let rawconstr_key = function
+  | RApp (_,RRef (_,ref),_) -> RefKey ref
+  | RRef (_,ref) -> RefKey ref
+  | _ -> Oth
+
+let cases_pattern_key = function
+  | PatCstr (_,ref,_,_) -> RefKey (ConstructRef ref)
+  | _ -> Oth
+
+let aconstr_key = function
+  | AApp (ARef ref,args) -> RefKey ref, Some (List.length args)
+  | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey ref, Some (List.length args)
+  | ARef ref -> RefKey ref, Some 0
+  | _ -> Oth, None
+
+let pattern_key = function
+  | PatCstr (_,cstr,_,_) -> RefKey (ConstructRef cstr)
+  | _ -> Oth
+
+(**********************************************************************)
+(* Interpreting numbers (not in summary because functional objects)   *)
+
+type num_interpreter =
+    (loc -> bigint -> rawconstr)
+    * (loc -> bigint -> name -> cases_pattern) option
+
+type num_uninterpreter =
+    rawconstr list * (rawconstr -> bigint option)
+    * (cases_pattern -> bigint option) option
+
+type required_module = global_reference * string list 
+
+let numeral_interpreter_tab =
+  (Hashtbl.create 7 : (scope_name,required_module*num_interpreter) Hashtbl.t)
+
+let declare_numeral_interpreter sc dir interp (patl,uninterp,uninterpc) =
+  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))
+    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 ()
+  with Not_found ->
+    user_err_loc (loc,"numeral_interpreter",
+    str ("Cannot interpret numbers 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
+	| Some key -> Some (Some scope, Some key)
+	| None -> None
+
+let rec find_without_delimiters find (ntn_scope,ntn) = function
+  | Scope scope :: scopes -> 
+      (* Is the expected ntn/numpr attached to the most recently open scope? *)
+      if Some scope = ntn_scope then
+	Some (None,None)
+      else
+	(* If the most recently open scope has a notation/numeral printer
+    	   but not the expected one then we need delimiters *)
+	if find scope then
+	  find_with_delimiters ntn_scope
+	else
+	  find_without_delimiters find (ntn_scope,ntn) scopes
+  | SingleNotation ntn' :: scopes ->
+      if ntn_scope = None & ntn = Some ntn' then 
+	Some (None,None)
+      else
+	find_without_delimiters find (ntn_scope,ntn) scopes
+  | [] ->
+      (* Can we switch to [scope]? Yes if it has defined delimiters *)
+      find_with_delimiters ntn_scope
+
+(* Uninterpreted notation levels *)
+
+let declare_notation_level ntn level =
+  if not !Options.v7 & Stringmap.mem ntn !notation_level_map then
+    error ("Notation "^ntn^" is already assigned a level");
+  notation_level_map := Stringmap.add ntn level !notation_level_map
+
+let level_of_notation ntn =
+  Stringmap.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
+    warning ("Notation "^ntn^" is 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 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)
+  | [] -> raise Not_found
+
+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 -> 
+    user_err_loc
+      (loc,"",str ("Unknown interpretation for notation \""^ntn^"\""))
+
+let uninterp_notations c =
+  Gmapl.find (rawconstr_key c) !notations_key_table
+
+let uninterp_cases_pattern_notations c =
+  Gmapl.find (cases_pattern_key c) !notations_key_table
+
+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)
+
+let uninterp_numeral c =
+  try 
+    let (sc,numpr,_) = Hashtbl.find numeral_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 =
+  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)
+  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)
+
+(* 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 -> []
+
+(**********************************************************************)
+(* Mapping classes to scopes *)
+
+open Classops
+
+let class_scope_map = ref (Gmap.empty : (cl_typ,scope_name) Gmap.t)
+
+let _ = Gmap.add CL_SORT "type_scope" Gmap.empty
+
+let declare_class_scope sc cl =
+  class_scope_map := Gmap.add cl sc !class_scope_map
+
+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
+    | Var id -> CL_SECVAR id
+    | Const sp -> CL_CONST sp
+    | Ind ind_sp -> CL_IND ind_sp
+    | Prod (_,_,_) -> CL_FUN
+    | Sort _ -> CL_SORT
+    |  _ -> raise Not_found
+
+let rec compute_arguments_scope t =
+  match kind_of_term (Reductionops.whd_betaiotazeta t) with
+    | Prod (_,t,u) ->
+	let sc =
+	  try Some (find_class_scope (find_class t)) with Not_found -> None in
+	sc :: compute_arguments_scope u
+    | _ -> []
+
+let declare_ref_arguments_scope ref =
+  let t = Global.type_of_global ref in
+  declare_arguments_scope ref (compute_arguments_scope t)
+
+(********************************)
+(* Encoding notations as string *)
+
+type symbol =
+  | Terminal of string
+  | NonTerminal of identifier
+  | SProdList of identifier * symbol list
+  | Break of int
+
+let rec string_of_symbol = function
+  | NonTerminal _ -> ["_"]
+  | Terminal s -> [s]
+  | SProdList (_,l) -> 
+     let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"]
+  | Break _ -> []
+
+let make_notation_key symbols =
+  String.concat " " (List.flatten (List.map string_of_symbol symbols))
+
+let decompose_notation_key s =
+  let len = String.length s in
+  let rec decomp_ntn dirs n =
+    if n>=len then dirs else
+    let pos =
+      try
+	String.index_from s n ' ' 
+      with Not_found -> len
+    in
+    let tok =
+      match String.sub s n (pos-n) with
+      | "_" -> NonTerminal (id_of_string "_")
+      | s -> Terminal s in
+    decomp_ntn (tok::dirs) (pos+1)	  
+  in
+    decomp_ntn [] 0
+
+(************)
+(* Printing *)
+
+let pr_delimiters_info = function
+  | None -> str "No delimiting key"
+  | Some key -> str "Delimiting key is " ++ str key
+
+let classes_of_scope sc =
+  Gmap.fold (fun cl sc' l -> if sc = sc' then cl::l else l) !class_scope_map []
+
+let pr_scope_classes sc =
+  let l = classes_of_scope sc in
+  if l = [] then mt()
+  else 
+    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)
+
+let pr_named_scope prraw scope sc =
+ (if scope = default_scope then
+   match Stringmap.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 ->
+	 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 
+   (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 ->
+      Some scope
+  | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope
+  | _::scopes -> find_default ntn scopes
+  | [] -> None
+
+let factorize_entries = function
+  | [] -> []
+  | (ntn,c)::l ->
+      let (ntn,l_of_ntn,rest) =
+	List.fold_left
+          (fun (a',l,rest) (a,c) ->
+	    if a = a' then (a',c::l,rest) else (a,[c],(a',l)::rest))
+	  (ntn,[c],[]) l in
+      (ntn,l_of_ntn)::rest
+
+let is_ident s = (* Poor analysis *)
+  String.length s <> 0 & is_letter s.[0]
+
+let browse_notation ntn map =
+  let find =
+    if String.contains ntn ' ' then (=) ntn
+    else fun ntn' -> List.mem (Terminal ntn) (decompose_notation_key ntn') in
+  let l =
+    Stringmap.fold 
+      (fun scope_name sc ->
+	Stringmap.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
+  factorize_entries l
+
+let locate_notation prraw ntn =
+  let ntns = browse_notation ntn !scope_map in
+  if ntns = [] then
+    str "Unknown notation"
+  else
+    t (str "Notation            " ++
+    tab () ++ str "Scope     " ++ tab () ++ fnl () ++ 
+    prlist (fun (ntn,l) ->
+      let scope = find_default ntn !scope_stack in
+      prlist 
+	(fun (sc,r,(_,df)) ->
+	  hov 0 (
+	    pr_notation_info prraw df r ++ tbrk (1,2) ++
+	    (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ 
+	    tbrk (1,2) ++
+	    (if Some sc = scope then str "(default interpretation)" else mt ())
+	    ++ fnl ()))
+	l) ntns)
+
+let collect_notation_in_scope scope sc known =
+  assert (scope <> default_scope);
+  Stringmap.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)
+
+let collect_notations stack =
+  fst (List.fold_left
+    (fun (all,knownntn as acc) -> function
+      | Scope scope ->
+	  if List.mem_assoc scope all then acc
+	  else
+	    let (l,knownntn) =
+	      collect_notation_in_scope scope (find_scope scope) knownntn in
+	    ((scope,l)::all,knownntn)
+      | SingleNotation ntn ->
+	  if List.mem ntn knownntn then (all,knownntn)
+	  else
+	    let ((_,r),(_,df),_) =
+	      Stringmap.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
+	      | _ -> 
+		  (default_scope,[df,r])::all in
+	    (all',ntn::knownntn))
+    ([],[]) stack)
+
+let pr_visible_in_scope prraw (scope,ntns) =
+  let strm =
+    List.fold_right
+      (fun (df,r) strm -> pr_notation_info prraw df r ++ fnl () ++ strm)
+      ntns (mt ()) in
+  (if scope = default_scope then
+     str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt())
+   else 
+     str "Visible in scope " ++ str scope)
+  ++ fnl () ++ strm
+
+let pr_scope_stack prraw stack = 
+  List.fold_left
+    (fun strm scntns -> strm ++ pr_visible_in_scope prraw scntns ++ fnl ())
+    (mt ()) (collect_notations stack)
+
+let pr_visibility prraw = function
+  | Some scope -> pr_scope_stack prraw (push_scope scope !scope_stack)
+  | None -> pr_scope_stack prraw !scope_stack
+
+(**********************************************************************)
+(* Mapping notations to concrete syntax *)
+
+type unparsing_rule = unparsing list * precedence
+
+(* Concrete syntax for symbolic-extension table *)
+let printing_rules = 
+  ref (Stringmap.empty : unparsing_rule Stringmap.t)
+
+let declare_notation_printing_rule ntn unpl =
+  printing_rules := Stringmap.add ntn unpl !printing_rules
+
+let find_notation_printing_rule ntn =
+  try Stringmap.find ntn !printing_rules
+  with Not_found -> anomaly ("No printing rule found for "^ntn)
+
+(**********************************************************************)
+(* Synchronisation with reset *)
+
+let freeze () =
+ (!scope_map, !notation_level_map, !scope_stack, !arguments_scope,
+  !delimiters_map, !notations_key_table, !printing_rules,
+  !class_scope_map)
+
+let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
+  scope_map := scm;
+  notation_level_map := nlm;
+  scope_stack := scs;
+  delimiters_map := dlm;
+  arguments_scope := asc;
+  notations_key_table := fkm;
+  printing_rules := pprules;
+  class_scope_map := clsc
+
+let init () =
+  init_scope_map ();
+(*
+  scope_stack := Stringmap.empty
+  arguments_scope := Refmap.empty
+*)
+  notation_level_map := Stringmap.empty;
+  delimiters_map := Stringmap.empty;
+  notations_key_table := Gmapl.empty;
+  printing_rules := Stringmap.empty;
+  class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
+
+let _ = 
+  declare_summary "symbols"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init;
+      survive_module = false;
+      survive_section = false }
diff --git a/interp/symbols.mli b/interp/symbols.mli
new file mode 100644
index 00000000..00d8e5ff
--- /dev/null
+++ b/interp/symbols.mli
@@ -0,0 +1,160 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: symbols.mli,v 1.22.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Pp
+open Bignat
+open Names
+open Nametab
+open Libnames
+open Rawterm
+open Topconstr
+open Ppextend
+
+(*i*)
+
+(**********************************************************************)
+(* Scopes *)
+
+(*s A scope is a set of interpreters for symbols + optional
+   interpreter and printers for integers + optional delimiters *)
+
+type level = precedence * tolerability list
+type delimiters = string
+type scope
+type scopes (* = scope_name list*)
+
+val type_scope : scope_name
+val declare_scope : scope_name -> unit
+
+(* Open scope *)
+
+val current_scopes : unit -> scopes
+val open_close_scope : 
+  (* locality *) bool * (* open *) bool * scope_name -> unit
+
+(* Extend a list of scopes *)
+val empty_scope_stack : scopes
+val push_scope : scope_name -> scopes -> scopes
+
+(* Declare delimiters for printing *)
+
+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 *)
+
+(* 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 num_uninterpreter =
+    rawconstr list * (rawconstr -> bigint option)
+    * (cases_pattern -> bigint option) option
+
+type required_module = global_reference * string list 
+val declare_numeral_interpreter : scope_name -> required_module ->
+  num_interpreter -> num_uninterpreter -> unit
+
+(* Returns 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
+
+(* Returns the numeral bound to a term/cases_pattern; raises No_match if no *)
+(* such numeral *)
+val uninterp_numeral : rawconstr -> scope_name * bigint
+val uninterp_cases_numeral : cases_pattern -> scope_name * bigint
+
+val availability_of_numeral : scope_name -> scopes -> delimiters option option
+
+(*s Declare and interpret back and forth a notation *)
+
+(* Binds a notation in a given scope to an interpretation *)
+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
+
+val declare_uninterpretation : interp_rule -> interpretation -> unit
+
+(* Returns the interpretation bound to a notation *)
+val interp_notation : loc -> notation -> scope_name list -> 
+      interpretation * ((dir_path * string) * scope_name option)
+
+(* Returns the possible notations for a given term *)
+val uninterp_notations : rawconstr ->
+      (interp_rule * interpretation * int option) list
+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 -> 
+  (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 *)
+
+(*s** Miscellaneous *)
+
+(* Checks for already existing notations *)
+val exists_notation_in_scope : scope_name option -> notation ->
+      interpretation -> bool * 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 find_arguments_scope : global_reference -> scope_name option list
+
+val declare_class_scope : scope_name -> Classops.cl_typ -> unit
+val declare_ref_arguments_scope : global_reference -> unit
+
+val compute_arguments_scope : Term.types -> scope_name option list
+
+(* Building notation key *)
+
+type symbol =
+  | Terminal of string
+  | NonTerminal of identifier
+  | SProdList of identifier * symbol list
+  | Break of int
+
+val make_notation_key : symbol list -> notation
+val decompose_notation_key : notation -> symbol list
+
+(* Prints scopes (expect a pure aconstr printer *)
+val pr_scope : (rawconstr -> std_ppcmds) -> scope_name -> std_ppcmds
+val pr_scopes : (rawconstr -> std_ppcmds) -> std_ppcmds
+val locate_notation : (rawconstr -> std_ppcmds) -> notation -> std_ppcmds
+
+val pr_visibility: (rawconstr -> std_ppcmds) -> scope_name option -> std_ppcmds
+
+(**********************************************************************)
+(*s Printing rules for notations *)
+
+(* Declare and look for the printing rule for symbolic notations *)
+type unparsing_rule = unparsing list * precedence
+val declare_notation_printing_rule : notation -> unparsing_rule -> unit
+val find_notation_printing_rule : notation -> unparsing_rule
+
+(**********************************************************************)
+(* Rem: printing rules for numerals are trivial *)
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
new file mode 100644
index 00000000..ef887d88
--- /dev/null
+++ b/interp/syntax_def.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: syntax_def.ml,v 1.6.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Libnames
+open Topconstr
+open Libobject
+open Lib
+open Nameops
+
+(* Syntactic definitions. *)
+
+let syntax_table = ref (KNmap.empty : aconstr KNmap.t)
+
+let _ = Summary.declare_summary
+	  "SYNTAXCONSTANT"
+	  { Summary.freeze_function = (fun () -> !syntax_table);
+	    Summary.unfreeze_function = (fun ft -> syntax_table := ft);
+	    Summary.init_function = (fun () -> syntax_table := KNmap.empty);
+	    Summary.survive_module = false;
+	    Summary.survive_section = false }
+
+let add_syntax_constant kn c =
+  syntax_table := KNmap.add kn c !syntax_table
+
+let load_syntax_constant i ((sp,kn),(local,c,onlyparse)) =
+  if Nametab.exists_cci sp then
+    errorlabstrm "cache_syntax_constant"
+      (pr_id (basename sp) ++ str " already exists");
+  add_syntax_constant kn c;
+  Nametab.push_syntactic_definition (Nametab.Until i) sp kn;
+  if not onlyparse then
+    Symbols.declare_uninterpretation (Symbols.SynDefRule kn) ([],c)
+
+let open_syntax_constant i ((sp,kn),c) =
+  Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn
+
+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)
+
+let classify_syntax_constant (_,(local,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_syntax_constant (local,_,_ as o) =
+  if local then None else Some o
+
+let (in_syntax_constant, out_syntax_constant) =
+  declare_object {(default_object "SYNTAXCONSTANT") with
+    cache_function = cache_syntax_constant;
+    load_function = load_syntax_constant;
+    open_function = open_syntax_constant;
+    subst_function = subst_syntax_constant;
+    classify_function = classify_syntax_constant;
+    export_function = export_syntax_constant } 
+
+let declare_syntactic_definition local id onlyparse c =
+  let _ = add_leaf id (in_syntax_constant (local,c,onlyparse)) in ()
+
+let rec set_loc loc _ a =
+  rawconstr_of_aconstr_with_binders loc (fun id e -> (id,e)) (set_loc loc) () a
+
+let search_syntactic_definition loc kn =
+  set_loc loc () (KNmap.find kn !syntax_table)
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
new file mode 100644
index 00000000..0aec03c2
--- /dev/null
+++ b/interp/syntax_def.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: syntax_def.mli,v 1.3.2.2 2004/07/16 19:30:23 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Topconstr
+open Rawterm
+(*i*)
+
+(* Syntactic definitions. *)
+
+val declare_syntactic_definition : bool -> identifier -> bool -> aconstr
+  -> unit
+
+val search_syntactic_definition : loc -> kernel_name -> rawconstr
+
+
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
new file mode 100644
index 00000000..3ee3285b
--- /dev/null
+++ b/interp/topconstr.ml
@@ -0,0 +1,702 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: topconstr.ml,v 1.35.2.2 2004/07/16 19:30:23 herbelin Exp $ *)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Rawterm
+open Term
+(*i*)
+
+(**********************************************************************)
+(* This is the subtype of rawconstr allowed in syntactic extensions *)
+
+(* For AList: first constr is iterator, second is terminator;
+   first id is where each argument of the list has to be substituted 
+   in iterator and snd id is alternative name just for printing;
+   boolean is associativity *)
+
+type aconstr =
+  (* Part common to rawconstr and cases_pattern *)
+  | ARef of global_reference
+  | AVar of identifier
+  | AApp of aconstr * aconstr list
+  | AList of identifier * identifier * aconstr * aconstr * bool
+  (* Part only in rawconstr *)
+  | 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
+  | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
+  | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
+  | ASort of rawsort
+  | AHole of 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
+
+let rec subst_rawvars l = function
+  | RVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
+  | r -> map_rawconstr (subst_rawvars l) r (* assume: id is not binding *)
+
+let ldots_var = id_of_string ".."
+
+let rawconstr_of_aconstr_with_binders loc g f e = function
+  | AVar id -> RVar (loc,id)
+  | AApp (a,args) -> RApp (loc,f e a, List.map (f e) args)
+  | AList (x,y,iter,tail,swap) ->
+      let t = f e tail in let it = f e iter in
+      let innerl = (ldots_var,t)::(if swap then [] else [x,RVar(loc,y)]) in
+      let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in
+      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)
+  | AProd (na,ty,c) ->
+      let na,e = name_app 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)
+  | ALetTuple (nal,(na,po),b,c) ->
+      RLetTuple (loc,nal,(na,option_app (f e) po),f e b,f e c)
+  | AIf (c,(na,po),b1,b2) ->
+      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)
+  | 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
+
+  | 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')
+
+let add_name r = function
+  | Anonymous -> ()
+  | Name id -> r := id :: !r
+
+let has_ldots =
+  List.exists
+    (function RApp (_,RVar(_,v),_) when v = ldots_var -> true | _ -> false)
+
+let compare_rawconstr f t1 t2 = match t1,t2 with
+  | RRef (_,r1), RRef (_,r2) -> r1 = r2
+  | RVar (_,v1), RVar (_,v2) -> v1 = v2
+  | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & List.for_all2 f l1 l2
+  | RLambda (_,na1,ty1,c1), RLambda (_,na2,ty2,c2) when na1 = na2 ->
+      f ty1 ty2 & f c1 c2
+  | RProd (_,na1,ty1,c1), RProd (_,na2,ty2,c2) when na1 = na2 ->
+      f ty1 ty2 & f c1 c2
+  | RHole _, RHole _ -> true
+  | RSort (_,s1), RSort (_,s2) -> s1 = s2
+  | (RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _
+    | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_
+  | _,(RLetIn _ | RCases _ | ROrderedCase _ | RRec _ | RDynamic _
+      | RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _)
+      -> error "Unsupported construction in recursive notations"
+  | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ | RHole _ | RSort _), _
+      -> false
+
+let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr t1 t2
+
+let discriminate_patterns 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 ->
+      if !diff = None then (diff := Some (v1,v2,(n>=nl)); true)
+      else 
+        !diff = Some (v1,v2,(n>=nl)) or !diff = Some (v2,v1,(n<nl))
+        or (error
+          "Both ends of the recursive pattern differ in more than one place")
+  | _ -> compare_rawconstr (aux (n+1)) c1 c2 in
+  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
+
+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
+  | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args 
+  | 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;
+	  option_iter
+	    (fun (_,_,nl) -> List.iter (add_name bound_binders) nl) x;
+          (aux tm,(na,option_app (fun (_,ind,nal) -> (ind,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) ->
+      ALetTuple (nal,(na,option_app aux po),aux b,aux c)
+  | RIf (loc,c,(na,po),b1,b2) ->
+      AIf (aux c,(na,option_app aux po),aux b1,aux b2)
+  | RCast (_,c,t) -> ACast (aux c,aux t)
+  | RSort (_,s) -> ASort s
+  | RHole (_,w) -> AHole w
+  | RRef (_,r) -> ARef r
+  | RPatVar (_,(_,n)) -> APatVar n
+  | RDynamic _ | RRec _ | REvar _ ->
+      error "Fixpoints, cofixpoints, existential variables and pattern-matching  not \
+allowed in abbreviatable expressions"
+
+  (* Recognizing recursive notations *)
+  and terminator_of_pat f1 ll1 lr1 = function
+  | RApp (loc,f2,l2) ->
+      if not (eq_rawconstr f1 f2) then error
+	"Cannot recognize the same head to both ends of the recursive pattern";
+      let nl = List.length ll1 in
+      let nr = List.length lr1 in
+      if List.length l2 <> nl + nr + 1 then
+	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 iter =
+        if order then RApp (loc,f2,ll2@RVar (loc,ldots_var)::lr2)
+        else RApp (loc,f1,ll1@RVar (loc,ldots_var)::lr1) in
+      (if order then y else x),(if order then x else y), aux iter, aux t, order
+  | _ -> error "One end of the recursive pattern is not an application"
+    
+  and make_aconstr_list f args =
+    let rec find_patterns acc = function
+      | RApp(_,RVar (_,a),[c]) :: l when a = ldots_var ->
+          (* We've found the recursive part *)
+	  let x,y,iter,term,lassoc = terminator_of_pat f (List.rev acc) l c in
+	  AList (x,y,iter,term,lassoc)
+      | a::l -> find_patterns (a::acc) l
+      | [] -> error "Ill-formed recursive notation"
+    in find_patterns [] args
+
+  in
+  let t = aux a in
+  (* Side effect *)
+  t, !found, !bound_binders
+
+let aconstr_of_rawconstr vars a =
+  let a,notbindingvars,binders = aconstr_and_vars_of_rawconstr a in
+  let check_type x =
+    if not (List.mem x notbindingvars or List.mem x binders) then
+      error ((string_of_id x)^" is unbound in the right-hand-side") in
+  List.iter check_type vars;
+  a
+
+let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l)
+
+(* Pattern-matching rawconstr and aconstr *)
+
+let rec adjust_scopes = function
+  | _,[] -> []
+  | [],a::args -> (None,a) :: adjust_scopes ([],args)
+  | sc::scopes,a::args -> (sc,a) :: adjust_scopes (scopes,args)
+
+exception No_match
+
+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 alpha_eq_val (x,y) = x = y
+
+let bind_env sigma var v =
+  try
+    let vvar = List.assoc var sigma in
+    if alpha_eq_val (v,vvar) then sigma
+    else raise No_match
+  with Not_found ->
+    (* TODO: handle the case of multiple occs in different scopes *)
+    (var,v)::sigma
+
+let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
+  | r1, AVar id2 when List.mem id2 metas -> bind_env sigma id2 r1
+  | RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
+  | RRef (_,r1), ARef r2 when r1 = r2 -> sigma
+  | RPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma
+  | RApp (_,f1,l1), AApp (f2,l2) when List.length l1 = List.length l2 ->
+      List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2
+  | RApp (_,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) 
+      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
+  | RProd (_,na1,t1,b1), AProd (na2,t2,b2) ->
+     match_binders alp metas (match_ alp metas sigma t1 t2) b1 b2 na1 na2
+  | 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 
+       (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) ->
+      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
+  | (RDynamic _ | RRec _ | REvar _), _ 
+  | _,_ -> raise No_match
+
+and match_alist alp metas sigma l1 l2 x iter termin lassoc =
+  (* match the iterator at least once *)
+  let sigma = List.fold_left2 (match_ alp (ldots_var::metas)) sigma l1 l2 in
+  (* Recover the recursive position *)
+  let rest = List.assoc ldots_var sigma in
+  (* Recover the first element *)
+  let t1 = List.assoc x sigma in
+  let sigma = List.remove_assoc x (List.remove_assoc ldots_var sigma) in
+  (* try to find the remaining elements or the terminator *)
+  let rec match_alist_tail alp metas sigma acc rest =
+    try 
+      let sigma = match_ alp (ldots_var::metas) sigma rest iter in
+      let rest = List.assoc ldots_var sigma in
+      let t = List.assoc x sigma in
+      let sigma = List.remove_assoc x (List.remove_assoc ldots_var sigma) in
+      match_alist_tail alp metas sigma (t::acc) rest
+    with No_match ->
+      List.rev acc, match_ alp metas sigma rest termin in
+  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 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_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
+
+type scope_name = string
+
+type interpretation = 
+    (identifier * (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
+  (* Reorder canonically the substitution *)
+  let find x subst =
+    try List.assoc x subst
+    with Not_found ->
+      (* Happens for binders bound to Anonymous *)
+      (* Find a better way to propagate Anonymous... *)
+      RVar (dummy_loc,x) in
+  List.map (fun (x,scl) -> (find x subst,scl)) metas_scl
+
+(**********************************************************************)
+(*s Concrete syntax for terms *)
+
+type notation = string
+
+type explicitation = ExplByPos of int | ExplByName of identifier
+
+type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
+
+type cases_pattern_expr =
+  | CPatAlias of loc * cases_pattern_expr * identifier
+  | CPatCstr of loc * reference * cases_pattern_expr list
+  | CPatAtom of loc * reference option
+  | CPatNotation of loc * notation * cases_pattern_expr list
+  | CPatNumeral of loc * Bignat.bigint
+  | CPatDelimiters of loc * string * cases_pattern_expr
+
+type constr_expr =
+  | CRef of reference
+  | CFix of loc * identifier located * fixpoint_expr list
+  | CCoFix of loc * identifier located * cofixpoint_expr list
+  | CArrow of loc * constr_expr * constr_expr
+  | CProdN of loc * (name located list * constr_expr) list * constr_expr
+  | CLambdaN of loc * (name located list * constr_expr) list * constr_expr
+  | CLetIn of loc * name located * constr_expr * 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) *
+      (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
+  | CLetTuple of loc * name list * (name option * constr_expr option) *
+      constr_expr * constr_expr
+  | CIf of loc * constr_expr * (name option * constr_expr option)
+      * constr_expr * constr_expr
+  | CHole of loc
+  | CPatVar of loc * (bool * patvar)
+  | CEvar of loc * existential_key
+  | CSort of loc * rawsort
+  | CCast of loc * constr_expr * constr_expr
+  | CNotation of loc * notation * constr_expr list
+  | CNumeral of loc * Bignat.bigint
+  | CDelimiters of loc * string * constr_expr
+  | CDynamic of loc * Dyn.t
+
+and fixpoint_expr =
+    identifier * int * local_binder list * constr_expr * constr_expr
+
+and local_binder =
+  | LocalRawDef of name located * constr_expr
+  | LocalRawAssum of name located list * constr_expr
+
+and cofixpoint_expr =
+    identifier * local_binder list * constr_expr * constr_expr
+
+(***********************)
+(* For binders parsing *)
+
+let rec local_binders_length = function
+  | [] -> 0
+  | LocalRawDef _::bl -> 1 + 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)
+
+(**********************************************************************)
+(* Functions on constr_expr *)
+
+let constr_loc = function
+  | CRef (Ident (loc,_)) -> loc
+  | CRef (Qualid (loc,_)) -> loc
+  | CFix (loc,_,_) -> loc
+  | CCoFix (loc,_,_) -> loc
+  | CArrow (loc,_,_) -> loc
+  | CProdN (loc,_,_) -> loc
+  | CLambdaN (loc,_,_) -> loc
+  | CLetIn (loc,_,_,_) -> loc
+  | 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
+  | CNotation (loc,_,_) -> loc
+  | CNumeral (loc,_) -> loc
+  | CDelimiters (loc,_,_) -> loc
+  | CDynamic _ -> dummy_loc
+
+let cases_pattern_loc = function
+  | CPatAlias (loc,_,_) -> loc
+  | CPatCstr (loc,_,_) -> loc
+  | CPatAtom (loc,_) -> loc
+  | CPatNotation (loc,_,_) -> loc
+  | CPatNumeral (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,_,_) 
+  | CCoFix (loc,_,_) -> 
+      Pp.warning "Capture check in multiple binders not done"; false
+
+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 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 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 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 []
+
+let map_binder g e nal = List.fold_right (fun (_,na) -> name_fold g na) nal e
+
+let map_binders f g e bl =
+  (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *)
+  let h (e,bl) (nal,t) = (map_binder g e nal,(nal,f e t)::bl) in
+  let (e,rbl) = List.fold_left h (e,[]) bl in
+  (e, List.rev rbl)
+
+let map_local_binders f g e bl =
+  (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *)
+  let h (e,bl) = function
+      LocalRawAssum(nal,ty) ->
+        (map_binder g e nal, LocalRawAssum(nal,f e ty)::bl)
+    | LocalRawDef((loc,na),ty) ->
+        (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl) in
+  let (e,rbl) = List.fold_left h (e,[]) bl in
+  (e, List.rev rbl)
+
+let map_constr_expr_with_binders f g 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) -> 
+      CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l)
+  | CProdN (loc,bl,b) ->
+      let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b)
+  | 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)
+  | 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) ->
+      (* 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)
+  | 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)
+  | 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)
+  | 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
+        let t' = f e' t in
+        (* Note: fix names should be inserted before the arguments... *)
+        let e'' = List.fold_left (fun e (id,_,_,_,_) -> g id e) e' dl in
+        let d' = f e'' d in
+        (id,n,bl',t',d')) dl)
+  | CCoFix (loc,id,dl) ->
+      CCoFix (loc,id,List.map (fun (id,bl,t,d) ->
+        let (e',bl') = map_local_binders f g e bl in
+        let t' = f e' t in
+        let e'' = List.fold_left (fun e (id,_,_,_) -> g id e) e' dl in
+        let d' = f e'' d in
+        (id,bl',t',d')) dl)
+
+(* Used in constrintern *)
+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
+
+(**********************************************************************)
+(* 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
+
+type module_type_ast = 
+  | CMTEident of qualid located
+  | CMTEwith of module_type_ast * with_declaration_ast
+
+type module_ast = 
+  | CMEident of qualid located
+  | CMEapply of module_ast * module_ast
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
new file mode 100644
index 00000000..f4a82a3a
--- /dev/null
+++ b/interp/topconstr.mli
@@ -0,0 +1,172 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: topconstr.mli,v 1.23.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Rawterm
+open Term
+(*i*)
+
+(*s This is the subtype of rawconstr allowed in syntactic extensions *)
+(* No location since intended to be substituted at any place of a text *)
+(* Complex expressions such as fixpoints and cofixpoints are excluded, *)
+(* non global expressions such as existential variables also *)
+
+type aconstr =
+  (* Part common to rawconstr and cases_pattern *)
+  | ARef of global_reference
+  | AVar of identifier
+  | AApp of aconstr * aconstr list
+  | AList of identifier * identifier * aconstr * aconstr * bool
+  (* Part only in rawconstr *)
+  | 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
+  | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
+  | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
+  | ASort of rawsort
+  | AHole of hole_kind
+  | APatVar of patvar
+  | ACast of aconstr * aconstr
+
+val rawconstr_of_aconstr_with_binders : loc -> 
+  (identifier -> 'a -> identifier * 'a) ->
+  ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr
+
+val subst_aconstr : Names.substitution -> aconstr -> aconstr
+
+val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr
+
+(* [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 interpretation = 
+    (identifier * (scope_name option * scope_name list)) list * aconstr
+
+val match_aconstr : (* scope_name option -> *) rawconstr -> interpretation ->
+      (rawconstr * (scope_name option * scope_name list)) list
+
+(*s Concrete syntax for terms *)
+
+type notation = string
+
+type explicitation = ExplByPos of int | ExplByName of identifier
+
+type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
+
+type cases_pattern_expr =
+  | CPatAlias of loc * cases_pattern_expr * identifier
+  | CPatCstr of loc * reference * cases_pattern_expr list
+  | CPatAtom of loc * reference option
+  | CPatNotation of loc * notation * cases_pattern_expr list
+  | CPatNumeral of loc * Bignat.bigint
+  | CPatDelimiters of loc * string * cases_pattern_expr
+
+type constr_expr =
+  | CRef of reference
+  | CFix of loc * identifier located * fixpoint_expr list
+  | CCoFix of loc * identifier located * cofixpoint_expr list
+  | CArrow of loc * constr_expr * constr_expr
+  | CProdN of loc * (name located list * constr_expr) list * constr_expr
+  | CLambdaN of loc * (name located list * constr_expr) list * constr_expr
+  | CLetIn of loc * name located * constr_expr * 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) *
+      (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
+  | CLetTuple of loc * name list * (name option * constr_expr option) *
+      constr_expr * constr_expr
+  | CIf of loc * constr_expr * (name option * constr_expr option)
+      * constr_expr * constr_expr
+  | CHole of loc
+  | CPatVar of loc * (bool * patvar)
+  | CEvar of loc * existential_key
+  | CSort of loc * rawsort
+  | CCast of loc * constr_expr * constr_expr
+  | CNotation of loc * notation * constr_expr list
+  | CNumeral of loc * Bignat.bigint
+  | CDelimiters of loc * string * constr_expr
+  | CDynamic of loc * Dyn.t
+
+and fixpoint_expr =
+    identifier * int * local_binder list * constr_expr * constr_expr
+
+and cofixpoint_expr =
+    identifier * local_binder list * constr_expr * constr_expr
+
+and local_binder =
+  | LocalRawDef of name located * constr_expr
+  | LocalRawAssum of name located list * constr_expr
+
+
+val constr_loc : constr_expr -> loc
+
+val cases_pattern_loc : cases_pattern_expr -> loc
+
+val replace_vars_constr_expr :
+  (identifier * identifier) list -> constr_expr -> constr_expr
+
+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 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 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
+
+(* For binders parsing *)
+
+(* Includes let binders *)
+val local_binders_length : local_binder list -> int
+
+(* Does not take let binders into account *)
+val names_of_local_assums : 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
+
+(* 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
+
+type module_type_ast = 
+  | CMTEident of qualid located
+  | CMTEwith of module_type_ast * with_declaration_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/closure.ml b/kernel/closure.ml
new file mode 100644
index 00000000..1a635ccf
--- /dev/null
+++ b/kernel/closure.ml
@@ -0,0 +1,1140 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: closure.ml,v 1.54.2.1 2004/07/16 19:30:23 herbelin Exp $ *)
+
+open Util
+open Pp
+open Term
+open Names
+open Declarations
+open Environ
+open Esubst
+
+
+let stats = ref false
+let share = ref true
+
+(* Profiling *)
+let beta = ref 0
+let delta = ref 0
+let zeta = ref 0
+let evar = ref 0
+let iota = ref 0
+let prune = ref 0
+
+let reset () =
+  beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0
+
+let stop() =
+  msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+	 str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++
+         str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]")
+
+let incr_cnt red cnt =
+  if red then begin
+    if !stats then incr cnt;
+    true
+  end else 
+    false
+
+let with_stats c =
+  if !stats then begin
+    reset();
+    let r = Lazy.force c in
+    stop();
+    r
+  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)
+
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+  val no_red : reds
+  val red_add : reds -> red_kind -> reds
+  val red_sub : reds -> red_kind -> reds
+  val red_add_transparent : reds -> transparent_state -> reds
+  val mkflags : red_kind list -> reds
+  val red_set : reds -> red_kind -> bool
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags = (struct
+
+  (* [r_const=(true,cl)] means all constants but those in [cl] *)
+  (* [r_const=(false,cl)] means only those in [cl] *)
+  (* [r_delta=true] just mean [r_const=(true,[])] *)
+
+  type reds = {
+    r_beta : bool;
+    r_delta : bool;
+    r_const : transparent_state;
+    r_zeta : bool;
+    r_evar : bool;
+    r_iota : bool }
+
+  type red_kind = BETA | DELTA | IOTA | ZETA
+	      | CONST of constant | VAR of identifier
+  let fBETA = BETA
+  let fDELTA = DELTA
+  let fIOTA = IOTA
+  let fZETA = ZETA
+  let fCONST kn  = CONST kn
+  let fVAR id  = VAR id
+  let no_red = {
+    r_beta = false;
+    r_delta = false;
+    r_const = all_opaque;
+    r_zeta = false;
+    r_evar = false;
+    r_iota = false }
+
+  let red_add red = function
+    | BETA -> { red with r_beta = true }
+    | 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 }
+    | IOTA -> { red with r_iota = true }
+    | ZETA -> { red with r_zeta = true }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.add id l1, l2 }
+
+  let red_sub red = function
+    | BETA -> { red with r_beta = false }
+    | DELTA -> { red with r_delta = false }
+    | CONST kn ->
+ 	let (l1,l2) = red.r_const in
+	{ red with r_const = l1, KNpred.remove kn l2 }
+    | IOTA -> { red with r_iota = false }
+    | ZETA -> { red with r_zeta = false }
+    | VAR id ->
+	let (l1,l2) = red.r_const in
+	{ red with r_const = Idpred.remove id l1, l2 }
+
+  let red_add_transparent red tr =
+    { red with r_const = tr } 
+
+  let mkflags = List.fold_left red_add no_red
+
+  let red_set red = function
+    | BETA -> incr_cnt red.r_beta beta
+    | CONST kn -> 
+	let (_,l) = red.r_const in
+	let c = KNpred.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
+	let c = Idpred.mem id l in
+	incr_cnt c delta
+    | ZETA -> incr_cnt red.r_zeta zeta
+    | IOTA -> incr_cnt red.r_iota iota
+    | DELTA -> (* Used for Rel/Var defined in context *)
+	incr_cnt red.r_delta delta
+
+  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
+    if b1=b2 then
+      let l1' = List.map (fun x -> EvalVarRef x) l1 in
+      let l2' = List.map (fun x -> EvalConstRef x) l2 in
+      (b1, l1' @ l2')
+    else error "unrepresentable pair of predicate"
+
+end : RedFlagsSig)
+
+open RedFlags
+
+let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA]
+let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA]
+let betaiota = mkflags [fBETA;fIOTA]
+let beta = mkflags [fBETA]
+let betaiotazeta = mkflags [fBETA;fIOTA;fZETA]
+let unfold_red kn = 
+  let flag = match kn with
+    | EvalVarRef id -> fVAR id
+    | EvalConstRef kn -> fCONST kn
+  in (* Remove fZETA for finer behaviour ? *)
+  mkflags [fBETA;flag;fIOTA;fZETA]
+
+(************************* Obsolète
+(* [r_const=(true,cl)] means all constants but those in [cl] *)
+(* [r_const=(false,cl)] means only those in [cl] *)
+type reds = {
+  r_beta : bool;
+  r_const : bool * constant_path list * identifier list;
+  r_zeta : bool;
+  r_evar : bool;
+  r_iota : bool }
+
+let betadeltaiota_red = {
+  r_beta = true;
+  r_const = true,[],[];
+  r_zeta = true;
+  r_evar = true;
+  r_iota = true } 
+
+let betaiota_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = true }
+		     
+let beta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let no_red = {
+  r_beta = false;
+  r_const = false,[],[];
+  r_zeta = false;
+  r_evar = false;
+  r_iota = false }
+
+let betaiotazeta_red = {
+  r_beta = true;
+  r_const = false,[],[];
+  r_zeta = true;
+  r_evar = false;
+  r_iota = true }
+
+let unfold_red kn =
+  let c = match kn with
+    | EvalVarRef id -> false,[],[id]
+    | EvalConstRef kn -> false,[kn],[]
+  in {
+  r_beta = true;
+  r_const = c;
+  r_zeta = true;   (* false for finer behaviour ? *)
+  r_evar = false;
+  r_iota = true }
+
+(* Sets of reduction kinds.
+   Main rule: delta implies all consts (both global (= by
+   kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's).
+   Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of 
+   a LetIn expression is Letin reduction *)
+
+type red_kind =
+    BETA | DELTA | ZETA | IOTA
+  | CONST of constant_path list | CONSTBUT of constant_path list
+  | VAR of identifier | VARBUT of identifier
+
+let rec red_add red = function
+  | BETA -> { red with r_beta = true }
+  | DELTA ->
+      (match red.r_const with
+	| _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags"
+	| _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true })
+  | CONST cl ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 })
+  | CONSTBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, list_union cl l1, l2;
+		r_zeta = true; r_evar = true })
+  | IOTA -> { red with r_iota = true }
+  | ZETA -> { red with r_zeta = true }
+  | VAR id ->
+      (match red.r_const with
+	| true,_,_ -> error "Conflict in the reduction flags"
+	| _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 })
+  | VARBUT cl ->
+      (match red.r_const with
+	| false,_::_,_ | false,_,_::_ ->
+			   error "Conflict in the reduction flags"
+	| _,l1,l2 ->
+	    { red with r_const = true, l1, list_union [cl] l2;
+		r_zeta = true; r_evar = true })
+
+let red_delta_set red =
+  let b,_,_ = red.r_const in b
+
+let red_local_const = red_delta_set
+
+(* to know if a redex is allowed, only a subset of red_kind is used ... *)
+let red_set red = function
+  | BETA -> incr_cnt red.r_beta beta
+  | CONST [kn] -> 
+      let (b,l,_) = red.r_const in
+      let c = List.mem kn l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | VAR id -> (* En attendant d'avoir des kn pour les Var *)
+     let (b,_,l) = red.r_const in
+      let c = List.mem id l in
+      incr_cnt ((b & not c) or (c & not b)) delta
+  | ZETA -> incr_cnt red.r_zeta zeta
+  | EVAR -> incr_cnt red.r_zeta evar
+  | IOTA -> incr_cnt red.r_iota iota
+  | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*)
+  (* Not for internal use *)
+  | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented"
+
+(* Gives the constant list *)
+let red_get_const red =
+  let b,l1,l2 = red.r_const in
+  let l1' = List.map (fun x -> EvalConstRef x) l1 in
+  let l2' = List.map (fun x -> EvalVarRef x) l2 in
+  b, l1' @ l2'
+fin obsolète **************)
+(* specification of the reduction function *)
+
+
+(* Flags of reduction and cache of constants: 'a is a type that may be
+ * mapped to constr. 'a infos implements a cache for constants and
+ * abstractions, storing a representation (of type 'a) of the body of
+ * this constant or abstraction.
+ *  * i_tab is the cache table of the results
+ *  * i_repr is the function to get the representation from the current
+ *         state of the cache and the body of the constant. The result
+ *         is stored in the table.
+ *  * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables
+ *    and only those with index 1 and 3 have bodies which are c and d resp.
+ *  * i_vars is the list of _defined_ named variables.
+ *
+ * ref_value_cache searchs in the tab, otherwise uses i_repr to
+ * compute the result and store it in the table. If the constant can't
+ * be unfolded, returns None, but does not store this failure.  * This
+ * doesn't take the RESET into account. You mustn't keep such a table
+ * after a Reset.  * This type is not exported. Only its two
+ * 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 'a infos = {
+  i_flags : reds;
+  i_repr : 'a infos -> constr -> 'a;
+  i_env : env;
+  i_rels : int * (int * constr) list;
+  i_vars : (identifier * constr) list;
+  i_tab : (table_key, 'a) Hashtbl.t }
+
+let info_flags info = info.i_flags
+
+let ref_value_cache info ref =
+  try  
+    Some (Hashtbl.find info.i_tab ref)
+  with Not_found ->
+  try
+    let body =
+      match ref with
+	| FarRelKey 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
+    in
+    let v = info.i_repr info body in
+    Hashtbl.add info.i_tab ref v;
+    Some v
+  with
+    | Not_found (* List.assoc *)
+    | NotEvaluableConst _ (* Const *)
+      -> None
+
+let defined_vars flags env =
+(*  if red_local_const (snd flags) then*)
+    fold_named_context 
+      (fun env (id,b,t) e ->
+	 match b with
+	   | None -> e
+	   | Some body -> (id, body)::e)
+      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) ->
+	 match b with
+	   | None -> (i+1, subs)
+	   | Some body -> (i+1, (i,body) :: subs))
+      env ~init:(0,[])
+(*  else (0,[])*)
+
+
+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 create mk_cl flgs env =
+  { i_flags = flgs;
+    i_repr = mk_cl;
+    i_env = env;
+    i_rels = defined_rels flgs env;
+    i_vars = defined_vars flgs env;
+    i_tab = Hashtbl.create 17 }
+
+
+(**********************************************************************)
+(* 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.
+ * Clone of the constr structure, but completely mutable, and
+ * annotated with reduction state (reducible or not).
+ *  - FLIFT is a delayed shift; allows sharing between 2 lifted copies
+ *    of a given term.
+ *  - FCLOS is a delayed substitution applied to a constr
+ *  - FLOCKED is used to erase the content of a reference that must
+ *    be updated. This is to allow the garbage collector to work
+ *    before the term is computed.
+ *)
+
+(* Norm means the term is fully normalized and cannot create a redex
+     when substituted
+   Cstr means the term is in head normal form and that it can
+     create a redex when substituted (i.e. constructor, fix, lambda)
+   Whnf means we reached the head normal form and that it cannot
+     create a redex when substituted
+   Red is used for terms that might be reduced
+*)
+type red_state = Norm | Cstr | Whnf | Red
+
+let neutr = function
+  | (Whnf|Norm) -> Whnf
+  | (Red|Cstr) -> Red
+
+type fconstr = { 
+  mutable norm: red_state; 
+  mutable term: fterm }
+
+and fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * fconstr
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+let fterm_of v = v.term
+let set_norm v = v.norm <- Norm
+let is_val v = v.norm = Norm
+
+(* Could issue a warning if no is still Red, pointing out that we loose
+   sharing. *)
+let update v1 (no,t) =
+  if !share then
+    (v1.norm <- no;
+     v1.term <- t;
+     v1)
+  else {norm=no;term=t}
+
+(* 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
+    | 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"
+    | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
+let lift_fconstr k f =
+  if k=0 then f else lft_fconstr k f
+let lift_fconstr_vect k v =
+  if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
+let lift_fconstr_list k l =
+  if k=0 then l else List.map (fun f -> lft_fconstr k f) l
+
+let clos_rel e i =
+  match expand_rel i e with
+    | 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)}
+
+(* since the head may be reducible, we might introduce lifts of 0 *)
+let compact_stack head stk =
+  let rec strip_rec depth = function
+    | Zshift(k)::s -> strip_rec (depth+k) s
+    | Zupdate(m)::s ->
+        (* Be sure to create a new cell otherwise sharing would be
+           lost by the update operation *)
+        let h' = lft_fconstr depth head in
+        let _ = update m (h'.norm,h'.term) in
+        strip_rec depth s
+    | stk -> zshift depth stk in
+  strip_rec 0 stk
+
+(* Put an update mark in the stack, only if needed *)
+let zupdate m s =
+  if !share & m.norm = Red
+  then
+    let s' = compact_stack m s in
+    let _ = m.term <- FLOCKED in
+    Zupdate(m)::s'
+  else s
+
+(* Closure optimization: *)
+let rec compact_constr (lg, subs as s) c k =
+  match kind_of_term c with
+      Rel i ->
+        if i < k then c,s else
+          (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs)
+          with Not_found -> mkRel (k+lg), (lg+1, (i-k+1)::subs))
+    | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s
+    | 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) ->
+        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
+    | App(f,v) ->
+        let (f',s) = compact_constr s f k in
+        let (v',s) = compact_vect s v k in
+        if f==f' && v==v' then c,s else mkApp(f',v'), s
+    | Lambda(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else mkLambda(n,a',b'), s
+    | Prod(n,a,b) ->
+        let (a',s) = compact_constr s a k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && b==b' then c,s else mkProd(n,a',b'), s
+    | LetIn(n,a,ty,b) ->
+        let (a',s) = compact_constr s a k in
+        let (ty',s) = compact_constr s ty k in
+        let (b',s) = compact_constr s b (k+1) in
+        if a==a' && ty==ty' && b==b' then c,s else mkLetIn(n,a',ty',b'), s
+    | Fix(fi,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else mkFix(fi,(na,ty',bd')), s
+    | CoFix(i,(na,ty,bd)) ->
+        let (ty',s) = compact_vect s ty k in
+        let (bd',s) = compact_vect s bd (k+Array.length ty) in
+        if ty==ty' && bd==bd' then c,s else mkCoFix(i,(na,ty',bd')), s
+    | Case(ci,p,a,br) ->
+        let (p',s) = compact_constr s p k in
+        let (a',s) = compact_constr s a k in
+        let (br',s) = compact_vect s br k in
+        if p==p' && a==a' && br==br' then c,s else mkCase(ci,p',a',br'),s
+and compact_vect s v k = compact_v [] s v k (Array.length v - 1)
+and compact_v acc s v k i =
+  if i < 0 then
+    let v' = Array.of_list acc in
+    if array_for_all2 (==) v v' then v,s else v',s
+  else
+    let (a',s') = compact_constr s v.(i) k in
+    compact_v (a'::acc) s' v k (i-1)
+
+(* Computes the minimal environment of a closure.
+   Idea: if the subs is not identity, the term will have to be
+   reallocated entirely (to propagate the substitution). So,
+   computing the set of free variables does not change the
+   complexity. *)
+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 mk_lambda env t =
+(*  let (env,t) = optimise_closure env t in*)
+  let (rvars,t') = decompose_lam t in
+  FLambda(List.length rvars, List.rev rvars, t', env)
+
+let destFLambda clos_fun t =
+  match t.term with
+      FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b)
+    | FLambda(n,(na,ty)::tys,b,e) ->
+        (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)})
+    | _ -> assert false
+
+(* Optimization: do not enclose variables in a closure.
+   Makes variable access much faster *)
+let mk_clos e t =
+  match kind_of_term t with
+    | Rel i -> clos_rel e i
+    | Var x -> { norm = Red; term = FFlex (VarKey x) }
+    | Const c -> { norm = Red; term = FFlex (ConstKey c) }
+    | Meta _ | Sort _ ->  { norm = Norm; term = FAtom t }
+    | Ind kn -> { norm = Norm; term = FInd kn }
+    | Construct kn -> { norm = Cstr; term = FConstruct kn }
+    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) ->
+        {norm = Red; term = FCLOS(t,e)}
+
+let mk_clos_vect env v = Array.map (mk_clos env) v
+
+(* Translate the head constructor of t from constr to fconstr. This
+   function is parameterized by the function to apply on the direct
+   subterms.
+   Could be used insted of mk_clos. *)
+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) ->
+        { norm = Red;
+          term = FCast (clos_fun env a, clos_fun env b)}
+    | App (f,v) ->
+        { norm = Red;
+	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
+    | Case (ci,p,c,v) ->
+        { norm = Red;
+	  term = FCases (ci, clos_fun env p, clos_fun env c,
+			 Array.map (clos_fun env) v) }
+    | Fix fx ->
+        { norm = Cstr; term = FFix (fx, env) }
+    | CoFix cfx ->
+        { norm = Cstr; term = FCoFix(cfx,env) }
+    | Lambda _ ->
+        { norm = Cstr; term = mk_lambda env t }
+    | Prod (n,t,c)   ->
+        { norm = Whnf;
+	  term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) }
+    | LetIn (n,b,t,c) ->
+        { norm = Red;
+	  term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) }
+    | Evar(ev,args) ->
+	{ norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) }
+
+(* A better mk_clos? *)
+let mk_clos2 = mk_clos_deep mk_clos
+
+(* The inverse of mk_clos_deep: move back to constr *)
+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 (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)
+    | FFlex (ConstKey op) -> mkConst op
+    | FInd op -> mkInd op
+    | FConstruct op -> mkConstruct op
+    | FCases (ci,p,c,ve) ->
+	mkCase (ci, constr_fun lfts p,
+                constr_fun lfts c,
+		Array.map (constr_fun lfts) ve)
+    | FFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn n lfts in
+	mkFix (op, (lna, Array.map (constr_fun lfts) ftys,
+		         Array.map (constr_fun lfts') fbds))
+    | FCoFix ((op,(lna,tys,bds)),e) ->
+        let n = Array.length bds in
+        let ftys = Array.map (mk_clos e) tys in
+        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+	let lfts' = el_liftn (Array.length bds) lfts in
+	mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys,
+		           Array.map (constr_fun lfts') fbds))
+    | FApp (f,ve) ->
+	mkApp (constr_fun lfts f,
+	       Array.map (constr_fun lfts) ve)
+    | FLambda _ ->
+        let (na,ty,bd) = destFLambda mk_clos2 v in
+	mkLambda (na, constr_fun lfts ty,
+	              constr_fun (el_lift lfts) bd)
+    | FProd (n,t,c)   ->
+	mkProd (n, constr_fun lfts t,
+	           constr_fun (el_lift lfts) c)
+    | FLetIn (n,b,t,f,e) ->
+        let fc = mk_clos2 (subs_lift e) f in
+	mkLetIn (n, constr_fun lfts b,
+	            constr_fun lfts t,
+	            constr_fun (el_lift lfts) fc)
+    | FEvar (ev,args) -> mkEvar(ev,Array.map (constr_fun lfts) args)
+    | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
+    | FCLOS (t,env) ->
+        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_")
+
+(* This function defines the correspondance between constr and
+   fconstr. When we find a closure whose substitution is the identity,
+   then we directly return the constr to avoid possibly huge
+   reallocation. *)
+let term_of_fconstr =
+  let rec term_of_fconstr_lift lfts v =
+    match v.term with
+      | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t
+      | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts ->
+          compose_lam (List.rev tys) f
+      | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx
+      | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
+      | _ -> to_constr term_of_fconstr_lift lfts v in
+  term_of_fconstr_lift ELID
+
+
+
+(* fstrong applies unfreeze_fun recursively on the (freeze) term and
+ * yields a term.  Assumes that the unfreeze_fun never returns a
+ * FCLOS term. 
+let rec fstrong unfreeze_fun lfts v =
+  to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v)
+*)
+
+let rec zip zfun 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
+    | 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
+    | Zfix(fx,par)::s ->
+        zip zfun fx (par @ append_stack_list ([m], s))
+    | Zshift(n)::s ->
+        zip zfun (lift_fconstr n m) s
+    | Zupdate(rf)::s ->
+        zip zfun (update rf (m.norm,m.term)) s
+
+let fapp_stack (m,stk) = zip (fun x -> x) m stk
+
+(*********************************************************************)
+
+(* The assertions in the functions below are granted because they are
+   called only when m is a constructor, a cofix
+   (strip_update_shift_app), a fix (get_nth_arg) or an abstraction
+   (strip_update_shift, through get_arg). *)
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift head stk =
+  assert (head.norm <> Red);
+  let rec strip_rec h depth = function
+    | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
+    | Zupdate(m)::s ->
+        strip_rec (update m (h.norm,h.term)) depth s
+    | stk -> (depth,stk) in
+  strip_rec head 0 stk
+
+(* optimised for the case where there are no shifts... *)
+let strip_update_shift_app head stk =
+  assert (head.norm <> Red);
+  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 ->
+        strip_rec (Zapp args :: rstk)
+          {norm=h.norm;term=FApp(h,Array.of_list 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 =
+  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
+        if n >= q
+        then
+          strip_rec (Zapp args::rstk)
+            {norm=h.norm;term=FApp(h,Array.of_list 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)
+    | Zupdate(m)::s ->
+        strip_rec rstk (update m (h.norm,h.term)) depth n s
+    | s -> (None, List.rev rstk @ s) in
+  strip_rec [] head 0 n stk
+
+(* Beta reduction: look for an applied argument in the stack.
+   Since the encountered update marks are removed, h must be a whnf *)
+let get_arg h stk =
+  let (depth,stk') = strip_update_shift h stk in
+  match  decomp_stack stk' with
+      Some (v, s') -> (Some (depth,v), s')
+    | None -> (None, zshift depth 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
+        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)
+        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)
+        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
+    | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
+
+
+(* Iota reduction: extract the arguments to be passed to the Case
+   branches *)
+let rec reloc_rargs_rec depth stk =
+  match stk with
+      Zapp args :: s ->
+        Zapp (lift_fconstr_list depth args) :: reloc_rargs_rec depth s
+    | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s
+    | _ -> stk
+
+let reloc_rargs depth stk =
+  if depth = 0 then stk else reloc_rargs_rec depth stk
+
+let rec drop_parameters depth n stk =
+  match stk with
+      Zapp args::s ->
+        let q = List.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))
+    | Zshift(k)::s -> drop_parameters (depth-k) n s
+    | [] -> assert (n=0); []
+    | _ -> assert false (* we know that n < stack_args_size(stk) *)
+
+
+(* Iota reduction: expansion of a fixpoint.
+ * Given a fixpoint and a substitution, returns the corresponding
+ * fixpoint body, and the substitution in which it should be
+ * evaluated: its first variables are the fixpoint bodies
+ *
+ * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S)
+ *    -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti)
+ *)
+(* does not deal with FLIFT *)
+let contract_fix_vect fix =
+  let (thisbody, make_body, env, nfix) =
+    match fix with
+      | FFix (((reci,i),(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }),
+	   env, Array.length bds)
+      | FCoFix ((i,(_,_,bds as rdcl)),env) ->
+          (bds.(i),
+	   (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }),
+	   env, Array.length bds)
+      | _ -> anomaly "Closure.contract_fix_vect: not a (co)fixpoint" 
+  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
+
+
+(*********************************************************************)
+(* A machine that inspects the head of a term until it finds an
+   atom or a subterm that may produce a redex (abstraction,
+   constructor, cofix, letin, constant), or a neutral term (product,
+   inductive) *)
+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"
+    | 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
+(* cases where knh stops *)
+    | (FFlex _|FLetIn _|FConstruct _|FEvar _|
+       FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
+        (m, stk)
+
+(* The same for pure terms *)
+and knht e t stk =
+  match kind_of_term t with
+    | App(a,b) ->
+        knht e a (append_stack (mk_clos_vect e b) 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
+    | Rel n -> knh (clos_rel e n) stk
+    | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
+       LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
+        (mk_clos2 e t, stk)
+
+
+(************************************************************************)
+
+(* Computes a normal form from the result of knh. *)
+let rec knr info m stk =
+  match m.term with
+  | FLambda(n,tys,f,e) when red_set info.i_flags fBETA ->
+      (match get_args n tys f e stk with
+          Inl e', s -> knit info e' f s
+        | Inr lam, s -> (lam,s)) 
+  | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
+      (match ref_value_cache info (ConstKey kn) with
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
+      (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
+          Some v -> kni info v stk
+        | None -> (set_norm m; (m,stk)))
+  | FConstruct(ind,c) when red_set info.i_flags fIOTA ->
+      (match strip_update_shift_app m stk with
+          (depth, args, Zcase(ci,_,br)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            kni info br.(c-1) (rargs@s)
+        | (_, cargs, Zfix(fx,par)::s) ->
+            let rarg = fapp_stack(m,cargs) in
+            let stk' = par @ append_stack [|rarg|] s in
+            let (fxe,fxbd) = contract_fix_vect fx.term in
+            knit info fxe fxbd stk'
+        | (_,args,s) -> (m,args@s))
+  | FCoFix _ when red_set info.i_flags fIOTA ->
+      (match strip_update_shift_app m stk with
+          (_, args, ((Zcase _::_) as stk')) ->
+            let (fxe,fxbd) = contract_fix_vect m.term in
+            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
+  | _ -> (m,stk)
+
+(* Computes the weak head normal form of a term *)
+and kni info m stk =
+  let (hm,s) = knh m stk in
+  knr info hm s
+and knit info e t stk =
+  let (ht,s) = knht e t stk in
+  knr info ht s
+
+let kh info v stk = fapp_stack(kni info v stk)
+
+(************************************************************************)
+
+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
+        zip_term zfun t s
+    | Zfix(fx,par)::s ->
+        let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in
+        zip_term zfun h s
+    | Zshift(n)::s ->
+        zip_term zfun (lift n m) s
+    | Zupdate(rf)::s ->
+        zip_term zfun m s
+
+(* Computes the strong normal form of a term.
+   1- Calls kni
+   2- tries to rebuild the term. If a closure still has to be computed,
+      calls itself recursively. *)
+let rec kl info m =
+  if is_val m then (incr prune; term_of_fconstr m)
+  else
+    let (nm,s) = kni info m [] in
+    let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *)
+    zip_term (kl info) (norm_head info nm) s
+
+(* no redex: go up for atoms and already normalized terms, go down
+   otherwise. *) 
+and norm_head info m =
+  if is_val m then (incr prune; term_of_fconstr m) else
+    match m.term with
+      | FLambda(n,tys,f,e) ->
+          let (e',rvtys) =
+            List.fold_left (fun (e,ctxt) (na,ty) ->
+              (subs_lift e, (na,kl info (mk_clos e ty))::ctxt))
+              (e,[]) tys in
+          let bd = kl info (mk_clos e' f) in
+          List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys
+      | FLetIn(na,a,b,f,e) ->
+          let c = mk_clos (subs_lift e) f in
+          mkLetIn(na, kl info a, kl info b, kl info c)
+      | FProd(na,dom,rng) ->
+          mkProd(na, kl info dom, kl info rng)
+      | FCoFix((n,(na,tys,bds)),e) ->
+          let ftys = Array.map (mk_clos e) tys in
+          let fbds =
+            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
+          mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+      | FEvar(i,args) -> mkEvar(i, Array.map (kl info) args)
+      | t -> term_of_fconstr m
+
+(* Initialization and then normalization *)
+
+(* weak reduction *)
+let whd_val info v =
+  with_stats (lazy (term_of_fconstr (kh info v [])))
+
+(* strong reduction *)
+let norm_val info v =
+  with_stats (lazy (kl info v))
+
+let inject = mk_clos (ESID 0)
+
+let whd_stack infos m stk =
+  let k = kni infos m stk in
+  let _ = fapp_stack k in (* to unlock Zupdates! *)
+  k
+
+(* cache of constants: the body is computed only when needed. *)
+type clos_infos = fconstr infos
+
+let create_clos_infos flgs env =
+  create (fun _ -> inject) flgs env
+
+let unfold_reference = ref_value_cache
diff --git a/kernel/closure.mli b/kernel/closure.mli
new file mode 100644
index 00000000..e58b91eb
--- /dev/null
+++ b/kernel/closure.mli
@@ -0,0 +1,207 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: closure.mli,v 1.42.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Environ
+open Esubst
+(*i*)
+
+(* Flags for profiling reductions. *)
+val stats : bool ref
+val share : bool ref
+
+val with_stats: 'a Lazy.t -> 'a
+
+(*s Delta implies all consts (both global (= by
+  [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
+  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
+
+(* Sets of reduction kinds. *)
+module type RedFlagsSig = sig
+  type reds
+  type red_kind
+
+  (* The different kind of reduction *)
+  (* Const/Var means the reference as argument should be unfolded *)
+  (* Constbut/Varbut means all references except the ones as argument
+     of Constbut/Varbut should be unfolded (there may be several such
+     Constbut/Varbut *)
+  val fBETA : red_kind
+  val fDELTA : red_kind
+  val fIOTA : red_kind
+  val fZETA : red_kind
+  val fCONST : constant -> red_kind
+  val fVAR : identifier -> red_kind
+
+  (* No reduction at all *)
+  val no_red : reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add : reds -> red_kind -> reds
+
+  (* Removes a reduction kind to a set *)
+  val red_sub : reds -> red_kind -> reds
+
+  (* Adds a reduction kind to a set *)
+  val red_add_transparent : reds -> transparent_state -> reds
+
+  (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
+  val mkflags : red_kind list -> reds
+
+  (* Tests if a reduction kind is set *)
+  val red_set : reds -> red_kind -> bool
+
+  (* Gives the constant list *)
+  val red_get_const : reds -> bool * evaluable_global_reference list
+end
+
+module RedFlags : RedFlagsSig
+open RedFlags
+
+val beta               : reds
+val betaiota           : reds
+val betadeltaiota      : reds
+val betaiotazeta       : reds
+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 'a infos
+val ref_value_cache: 'a infos -> table_key -> 'a option
+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 *)
+
+type fconstr
+
+(* [fconstr] can be accessed by using the function [fterm_of] and by
+   matching on type [fterm] *)
+
+type fterm =
+  | FRel of int
+  | FAtom of constr (* Metas and Sorts *)
+  | FCast of fconstr * fconstr
+  | FFlex of table_key
+  | FInd of inductive
+  | FConstruct of constructor
+  | FApp of fconstr * fconstr array
+  | FFix of fixpoint * fconstr subs
+  | FCoFix of cofixpoint * fconstr subs
+  | FCases of case_info * fconstr * fconstr * fconstr array
+  | FLambda of int * (name * constr) list * constr * fconstr subs
+  | FProd of name * fconstr * fconstr
+  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FEvar of existential_key * fconstr array
+  | FLIFT of int * fconstr
+  | FCLOS of constr * fconstr subs
+  | FLOCKED
+
+(* 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
+val fterm_of : fconstr -> fterm
+val term_of_fconstr : fconstr -> constr
+val destFLambda :
+  (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+
+(* Global and local constant cache *)
+type clos_infos
+val create_clos_infos : reds -> env -> clos_infos
+
+(* Reduction function *)
+
+(* [norm_val] is for strong normalization *)
+val norm_val : clos_infos -> fconstr -> constr
+
+(* [whd_val] is for weak head normalization *)
+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
+
+(* 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
+
+(************************************************************************)
+(*i This is for lazy debug *)
+
+val lift_fconstr      : int -> fconstr -> fconstr
+val lift_fconstr_vect : int -> fconstr array -> fconstr array
+
+val mk_clos      : fconstr subs -> constr -> fconstr
+val mk_clos_vect : fconstr subs -> constr array -> fconstr array
+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 kl : clos_infos -> fconstr -> constr
+
+val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
+val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
+
+(* End of cbn debug section i*)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
new file mode 100644
index 00000000..dba373ce
--- /dev/null
+++ b/kernel/conv_oracle.ml
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: conv_oracle.ml,v 1.2.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+
+open Names
+open Closure
+
+(* Opaque constants *)
+let cst_transp = ref KNpred.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 is_opaque_cst kn = not (KNpred.mem kn !cst_transp)
+
+(* Opaque variables *)
+let var_transp = ref Idpred.full
+
+let set_opaque_var kn = var_transp := Idpred.remove kn !var_transp
+let set_transparent_var kn = var_transp := Idpred.add kn !var_transp
+
+let is_opaque_var kn = not (Idpred.mem kn !var_transp)
+
+(* Opaque reference keys *)
+let is_opaque = function
+  | ConstKey cst -> is_opaque_cst cst
+  | VarKey id -> is_opaque_var id
+  | FarRelKey _ -> 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)
+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
new file mode 100644
index 00000000..77de9b8a
--- /dev/null
+++ b/kernel/conv_oracle.mli
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: conv_oracle.mli,v 1.3.8.2 2004/07/16 19:30:24 herbelin Exp $ *)
+
+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
+
+(* Changing the oracle *)
+val set_opaque_const      : constant -> unit
+val set_transparent_const : constant -> unit
+
+val set_opaque_var      : identifier -> unit
+val set_transparent_var : identifier -> unit
+
+val is_opaque_cst : constant -> bool
+val is_opaque_var : identifier -> bool
+
+(*****************************)
+
+(* transparent state summary operations *)
+val init     : unit -> unit
+val freeze   : unit -> transparent_state
+val unfreeze : transparent_state -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
new file mode 100644
index 00000000..d69efe3a
--- /dev/null
+++ b/kernel/cooking.ml
@@ -0,0 +1,172 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: cooking.ml,v 1.17.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Declarations
+open Environ
+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 =
+    (constant * constant modification) list
+    * (inductive * inductive modification) list
+    * (constructor * constructor modification) list
+
+type recipe = {
+  d_from : constant_body;
+  d_abstract : identifier list;
+  d_modlist : work_list }
+
+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 rec substrec c =
+    let c' = map_constr substrec c in
+    match kind_of_term c' with
+      | Case (ci,p,t,br) ->
+	  (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)
+	   with 
+	     | Not_found -> c')
+
+      | Construct spi ->
+	  (try
+	     (match List.assoc spi cstrl with
+		| NOT_OCCUR -> failure ()
+		| DO_ABSTRACT (oper',abs_vars) ->
+		    mkApp (mkConstruct oper', abs_vars)
+		| DO_REPLACE _ -> assert false)
+	   with 
+	     | Not_found -> c')
+
+      | Const kn ->
+	  (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)))
+	   with 
+	     | Not_found -> c')
+  
+    | _ -> c'
+  in 
+  if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec
+
+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')
+
+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)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
new file mode 100644
index 00000000..54526e99
--- /dev/null
+++ b/kernel/cooking.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: cooking.mli,v 1.9.8.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+open Names
+open Term
+open Declarations
+open Environ
+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 recipe = {
+  d_from : constant_body;
+  d_abstract : identifier list;
+  d_modlist : work_list }
+
+val cook_constant :
+  env -> recipe -> constr_substituted option * constr * constraints * bool
+
+(*s Utility functions used in module [Discharge]. *)
+
+val expmod_constr : work_list -> constr -> constr
+val expmod_type : work_list -> types -> types
+
+
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
new file mode 100644
index 00000000..8943b0b5
--- /dev/null
+++ b/kernel/declarations.ml
@@ -0,0 +1,193 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: declarations.ml,v 1.31.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the types of global declarations. This includes
+   global constants/axioms and mutual inductive definitions *)
+
+(*s Constants (internal representation) (Definition/Axiom) *)
+
+type subst_internal = 
+  | Constr of constr 
+  | LazyConstr of substitution * constr
+
+type constr_substituted = subst_internal ref
+
+let from_val c = ref (Constr c)
+
+let force cs = match !cs with
+    Constr c -> c
+  | LazyConstr (subst,c) -> 
+      let c' = subst_mps subst c in
+	cs := Constr c';
+	c'
+
+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))
+
+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 }
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+let subst_recarg sub r = match r with
+  | Norec | Mrec _  -> r
+  | Imbr (kn,i) -> let kn' = subst_kn sub kn in
+      if kn==kn' then r else Imbr (kn',i)
+
+type wf_paths = recarg Rtree.t
+
+let mk_norec = Rtree.mk_node Norec [||]
+
+let mk_paths r recargs =
+  Rtree.mk_node r
+    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
+
+let dest_recarg p = fst (Rtree.dest_node p)
+
+let dest_subterms p =
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
+
+let recarg_length p j = 
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
+
+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 *) 
+
+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;
+  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 mutual_inductive_body = {
+  mind_finite : bool;
+  mind_ntypes : int;
+  mind_hyps : section_context;
+  mind_packets : one_inductive_body array;
+  mind_constraints : constraints;
+  mind_equiv : kernel_name option
+ }
+
+(* 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;
+    const_hyps = (assert (cb.const_hyps=[]); []);
+    const_constraints = cb.const_constraints;
+    const_opaque = cb.const_opaque}
+  
+let subst_mind_packet sub mbp = 
+  { mind_consnames = mbp.mind_consnames;
+    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_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*);
+}
+
+let subst_mind sub mib = 
+  { mind_finite = mib.mind_finite ;
+    mind_ntypes = mib.mind_ntypes ;
+    mind_hyps = (assert (mib.mind_hyps=[]); []) ;
+    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;
+}
+
+
+(*s Modules: signature component specifications, module types, and
+  module declarations *)
+
+type specification_body = 
+  | SPBconst of constant_body
+  | SPBmind of mutual_inductive_body
+  | SPBmodule of module_specification_body
+  | SPBmodtype of module_type_body
+
+and module_signature_body = (label * specification_body) list
+
+and module_type_body = 
+  | MTBident of kernel_name
+  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
+  | MTBsig of mod_self_id * module_signature_body
+
+and module_specification_body = 
+    { msb_modtype : module_type_body;
+      msb_equiv : module_path option; 
+      msb_constraints : constraints }
+
+
+type structure_elem_body = 
+  | SEBconst of constant_body
+  | SEBmind of mutual_inductive_body
+  | SEBmodule of module_body
+  | SEBmodtype of module_type_body
+
+and module_structure_body = (label * structure_elem_body) list
+
+and module_expr_body =
+  | MEBident of module_path
+  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
+  | MEBstruct of mod_self_id * module_structure_body
+  | MEBapply of module_expr_body * module_expr_body
+      * constraints
+
+and module_body = 
+    { mod_expr : module_expr_body option;
+      mod_user_type : module_type_body option;
+      mod_type : module_type_body;
+      mod_equiv : module_path option;
+      mod_constraints : constraints }
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
new file mode 100644
index 00000000..3252ddee
--- /dev/null
+++ b/kernel/declarations.mli
@@ -0,0 +1,141 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: declarations.mli,v 1.33.2.1 2004/07/16 19:30:24 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*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 constr_substituted
+
+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 }
+
+val subst_const_body : substitution -> constant_body -> constant_body
+
+(*s Inductive types (internal representation with redundant
+    information). *)
+
+type recarg = 
+  | Norec 
+  | Mrec of int 
+  | Imbr of inductive
+
+val subst_recarg : substitution -> recarg -> recarg
+
+type wf_paths = recarg Rtree.t
+
+val mk_norec : wf_paths
+val mk_paths : recarg -> wf_paths list array -> wf_paths
+val dest_recarg : wf_paths -> recarg
+val dest_subterms : wf_paths -> wf_paths list array
+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 *) 
+
+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;
+  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 mutual_inductive_body = {
+  mind_finite : bool;
+  mind_ntypes : int;
+  mind_hyps : section_context;
+  mind_packets : one_inductive_body array;
+  mind_constraints : constraints;
+  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 *)
+
+type specification_body = 
+  | SPBconst of constant_body
+  | SPBmind of mutual_inductive_body
+  | SPBmodule of module_specification_body
+  | SPBmodtype of module_type_body
+
+and module_signature_body = (label * specification_body) list
+
+and module_type_body = 
+  | MTBident of kernel_name
+  | MTBfunsig of mod_bound_id * module_type_body * module_type_body
+  | MTBsig of mod_self_id * module_signature_body
+
+and module_specification_body = 
+    { msb_modtype : module_type_body;
+      msb_equiv : module_path option; 
+      msb_constraints : constraints }
+    (*    type_of(equiv) <: modtype  (if given)  
+       +  substyping of past With_Module mergers *)
+
+
+type structure_elem_body = 
+  | SEBconst of constant_body
+  | SEBmind of mutual_inductive_body
+  | SEBmodule of module_body
+  | SEBmodtype of module_type_body
+
+and module_structure_body = (label * structure_elem_body) list
+
+and module_expr_body =
+  | MEBident of module_path
+  | MEBfunctor of mod_bound_id * module_type_body * module_expr_body 
+  | MEBstruct of mod_self_id * module_structure_body
+  | MEBapply of module_expr_body * module_expr_body  (* (F A) *)
+      * constraints  (* type_of(A) <: input_type_of(F) *)
+
+and module_body = 
+    { mod_expr : module_expr_body option;
+      mod_user_type : module_type_body option;
+      mod_type : module_type_body;
+      mod_equiv : module_path option;
+      mod_constraints : constraints }
+    (*    type_of(mod_expr)  <: mod_user_type (if given)  *)
+    (*  if equiv given then constraints are empty *)
+
+
+
diff --git a/kernel/doc.tex b/kernel/doc.tex
new file mode 100644
index 00000000..4a9fc355
--- /dev/null
+++ b/kernel/doc.tex
@@ -0,0 +1,11 @@
+
+\newpage
+\section*{The Coq kernel}
+
+\ocwsection \label{kernel}
+This chapter describes the \Coq\ kernel, which is a type checker for the \CCI.
+The modules of the kernel are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=kernel.dep.ps,width=\linewidth}\end{center}
+
diff --git a/kernel/entries.ml b/kernel/entries.ml
new file mode 100644
index 00000000..d833499e
--- /dev/null
+++ b/kernel/entries.ml
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: entries.ml,v 1.3.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the entry types for global declarations. This
+   information is entered in the environments. This includes global
+   constants/axioms, mutual inductive definitions, modules and module
+   types *)
+
+
+(*s Local entries *)
+
+type local_entry =
+  | LocalDef of constr
+  | LocalAssum of constr
+
+
+(*s Declaration of inductive types. *)
+
+(* Assume the following definition in concrete syntax:
+\begin{verbatim}
+Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+...
+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]];
+[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
+*)
+
+type one_inductive_entry = {
+  mind_entry_params : (identifier * local_entry) list;
+  mind_entry_typename : identifier;
+  mind_entry_arity : constr;
+  mind_entry_consnames : identifier list;
+  mind_entry_lc : constr list }
+
+type mutual_inductive_entry = {
+  mind_entry_finite : bool;
+  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 }
+
+type parameter_entry = types
+
+type constant_entry = 
+  | DefinitionEntry of definition_entry
+  | ParameterEntry of parameter_entry
+
+(*s Modules *)
+
+type specification_entry = 
+    SPEconst of constant_entry
+  | SPEmind of mutual_inductive_entry
+  | SPEmodule of module_entry
+  | SPEmodtype of module_type_entry
+
+and module_type_entry = 
+    MTEident of kernel_name
+  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
+  | MTEsig of mod_self_id * module_signature_entry
+  | MTEwith of module_type_entry * with_declaration
+
+and module_signature_entry = (label * specification_entry) list
+
+and with_declaration = 
+    With_Module of identifier * module_path
+  | With_Definition of identifier * constr
+
+and module_expr = 
+    MEident of module_path
+  | MEfunctor of mod_bound_id * module_type_entry * module_expr
+  | MEstruct of mod_self_id * module_structure
+  | MEapply of module_expr * module_expr
+
+and module_structure = (label * specification_entry) list
+
+
+and module_entry = 
+    { mod_entry_type : module_type_entry option;
+      mod_entry_expr : module_expr option}
+
diff --git a/kernel/entries.mli b/kernel/entries.mli
new file mode 100644
index 00000000..edade51a
--- /dev/null
+++ b/kernel/entries.mli
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: entries.mli,v 1.3.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Sign
+(*i*)
+
+(* This module defines the entry types for global declarations. This
+   information is entered in the environments. This includes global
+   constants/axioms, mutual inductive definitions, modules and module
+   types *)
+
+
+(*s Local entries *)
+
+type local_entry =
+  | LocalDef of constr
+  | LocalAssum of constr
+
+
+(*s Declaration of inductive types. *)
+
+(* Assume the following definition in concrete syntax:
+\begin{verbatim}
+Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1
+...
+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]];
+[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
+*)
+
+type one_inductive_entry = {
+  mind_entry_params : (identifier * local_entry) list;
+  mind_entry_typename : identifier;
+  mind_entry_arity : constr;
+  mind_entry_consnames : identifier list;
+  mind_entry_lc : constr list }
+
+type mutual_inductive_entry = {
+  mind_entry_finite : bool;
+  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 }
+
+type parameter_entry = types
+
+type constant_entry = 
+  | DefinitionEntry of definition_entry
+  | ParameterEntry of parameter_entry
+
+(*s Modules *)
+
+type specification_entry = 
+    SPEconst of constant_entry
+  | SPEmind of mutual_inductive_entry
+  | SPEmodule of module_entry
+  | SPEmodtype of module_type_entry
+
+and module_type_entry = 
+    MTEident of kernel_name
+  | MTEfunsig of mod_bound_id * module_type_entry * module_type_entry
+  | MTEsig of mod_self_id * module_signature_entry
+  | MTEwith of module_type_entry * with_declaration
+
+and module_signature_entry = (label * specification_entry) list
+
+and with_declaration = 
+    With_Module of identifier * module_path
+  | With_Definition of identifier * constr
+
+and module_expr = 
+    MEident of module_path
+  | MEfunctor of mod_bound_id * module_type_entry * module_expr
+  | MEstruct of mod_self_id * module_structure
+  | MEapply of module_expr * module_expr
+
+and module_structure = (label * specification_entry) list
+
+
+and module_entry = 
+    { mod_entry_type : module_type_entry option;
+      mod_entry_expr : module_expr option}
+
diff --git a/kernel/environ.ml b/kernel/environ.ml
new file mode 100644
index 00000000..ec3c903d
--- /dev/null
+++ b/kernel/environ.ml
@@ -0,0 +1,295 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: environ.ml,v 1.89.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Sign
+open Univ
+open Term
+open Declarations
+
+(* The type of environments. *)
+
+type checksum = int
+
+type compilation_unit_name = dir_path * checksum
+
+type global = Constant | Inductive
+
+type engagement = ImpredicativeSet
+
+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 engagement env = env.env_stratification.env_engagement
+let universes env = env.env_stratification.env_universes
+let named_context env = env.env_named_context
+let rel_context env = env.env_rel_context
+
+let empty_context env = 
+  env.env_rel_context = empty_rel_context 
+  && env.env_named_context = empty_named_context
+
+(* Rel context *)
+let lookup_rel n env =
+  Sign.lookup_rel n env.env_rel_context
+
+let evaluable_rel n env =
+  try
+    match lookup_rel n env with
+        (_,Some _,_) -> true
+      | _ -> false
+  with Not_found -> 
+    false
+
+let push_rel d env =
+  { env with
+      env_rel_context = add_rel_decl d env.env_rel_context }
+
+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 }
+
+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))
+
+
+(* 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 push_named d env =
+  { env with
+      env_named_context = Sign.add_named_decl d env.env_named_context }
+
+let reset_context env =
+  { env with
+      env_named_context = empty_named_context;
+      env_rel_context = empty_rel_context }
+
+let reset_with_named_context ctxt env =
+  { env with
+      env_named_context = ctxt;
+      env_rel_context = empty_rel_context }
+
+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 fold_named_context_reverse f ~init 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 new_globals = 
+    { env.env_globals with 
+	env_constants = new_constants } in 
+  { env with env_globals = new_globals }
+
+(* constant_type gives the type of a constant *)
+let constant_type env kn =
+  let cb = lookup_constant kn env in
+  cb.const_type  
+
+type const_evaluation_result = NoBody | Opaque
+
+exception NotEvaluableConst of const_evaluation_result
+
+let constant_value env kn =
+  let cb = lookup_constant kn env in
+  if cb.const_opaque then raise (NotEvaluableConst Opaque);
+  match cb.const_body with
+    | Some l_body -> Declarations.force l_body
+    | None -> raise (NotEvaluableConst NoBody)
+
+let constant_opt_value env cst =
+  try Some (constant_value env cst)
+  with NotEvaluableConst _ -> None
+
+(* A global const is evaluable if it is defined and not opaque *)
+let evaluable_constant cst env =
+  try let _  = constant_value env cst in true
+  with Not_found | NotEvaluableConst _ -> false
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  KNmap.find kn env.env_globals.env_inductives
+
+let add_mind kn mib env =
+  let new_inds = KNmap.add kn mib env.env_globals.env_inductives in
+  let new_globals = 
+    { env.env_globals with 
+	env_inductives = new_inds } in
+  { env with env_globals = new_globals }
+
+(* Universe constraints *)
+let set_universes g env =
+  if env.env_stratification.env_universes == g then env
+  else
+    { env with env_stratification = 
+      { env.env_stratification with env_universes = g } }
+
+let add_constraints c env =
+  if c == Constraint.empty then 
+    env 
+  else
+    let s = env.env_stratification in
+    { env with env_stratification = 
+      { s with env_universes = merge_constraints c s.env_universes } }
+
+let set_engagement c env = (* Unsafe *)
+  { env with env_stratification =
+    { env.env_stratification with env_engagement = Some c } }
+
+(* Lookup of section variables *)
+let lookup_constant_variables c env =
+  let cmap = lookup_constant c env in
+  Sign.vars_of_named_context cmap.const_hyps
+
+let lookup_inductive_variables (kn,i) env =
+  let mis = lookup_mind kn env in
+  Sign.vars_of_named_context mis.mind_hyps
+
+let lookup_constructor_variables (ind,_) env =
+  lookup_inductive_variables ind env
+
+(* Returns the list of global variables in a term *)
+
+let vars_of_global env constr =
+  match kind_of_term constr with
+      Var id -> [id]
+    | Const kn -> lookup_constant_variables kn env
+    | Ind ind -> lookup_inductive_variables ind env
+    | Construct cstr -> lookup_constructor_variables cstr env
+    | _ -> []
+
+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
+  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 
+   contained in the types of the needed variables. *)
+
+let keep_hyps env needed =
+  let really_needed =
+    Sign.fold_named_context_reverse
+      (fun need (id,copt,t) ->
+        if Idset.mem id need then
+          let globc = 
+	    match copt with
+	      | None -> Idset.empty
+	      | Some c -> global_vars_set env c in
+	  Idset.union
+            (global_vars_set env t) 
+	    (Idset.union globc need)
+        else need)
+      ~init:needed
+      (named_context env) in
+  Sign.fold_named_context
+    (fun (id,_,_ as d) nsign ->
+      if Idset.mem id really_needed then add_named_decl d nsign
+      else nsign)
+    (named_context env)
+    ~init:empty_named_context
+
+
+(* Modules *)
+
+let add_modtype ln mtb env = 
+  let new_modtypes = KNmap.add ln mtb env.env_globals.env_modtypes in
+  let new_globals = 
+    { env.env_globals with 
+	env_modtypes = new_modtypes } in
+  { env with env_globals = new_globals }
+
+let shallow_add_module mp mb env = 
+  let new_mods = MPmap.add mp mb env.env_globals.env_modules in
+  let new_globals = 
+    { env.env_globals with 
+	env_modules = new_mods } in
+  { env with env_globals = new_globals }
+
+let lookup_module mp env = 
+  MPmap.find mp env.env_globals.env_modules
+
+let lookup_modtype ln env = 
+  KNmap.find ln env.env_globals.env_modtypes
+
+(*s Judgments. *)
+
+type unsafe_judgment = { 
+  uj_val : constr;
+  uj_type : types }
+
+let make_judge v tj =
+  { uj_val = v;
+    uj_type = tj }
+
+let j_val j = j.uj_val
+let j_type j = j.uj_type
+
+type unsafe_type_judgment = { 
+  utj_val : constr;
+  utj_type : sorts }
+
diff --git a/kernel/environ.mli b/kernel/environ.mli
new file mode 100644
index 00000000..4e54761b
--- /dev/null
+++ b/kernel/environ.mli
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: environ.mli,v 1.66.2.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Sign
+(*i*)
+
+(*s Unsafe environments. We define here a datatype for environments. 
+   Since typing is not yet defined, it is not possible to check the
+   informations added in environments, and that is why we speak here
+   of ``unsafe'' environments. *)
+
+(* Environments have the following components:
+   - a context for de Bruijn variables
+   - a context for section variables and goal assumptions
+   - 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 empty_env : env
+
+val universes     : env -> Univ.universes
+val rel_context   : env -> rel_context
+val named_context : env -> named_context
+
+type engagement = ImpredicativeSet
+
+val engagement    : env -> engagement option
+
+(* is the local context empty *)
+val empty_context : env -> bool
+
+(************************************************************************)
+(*s Context of de Bruijn variables (rel_context) *)
+val push_rel         : rel_declaration -> env -> env
+val push_rel_context :     rel_context -> env -> env
+val push_rec_types   : rec_declaration -> env -> env
+
+(* Looks up in the context of local vars referred by indice ([rel_context]) *)
+(* raises [Not_found] if the index points out of the context *)
+val lookup_rel    : int -> env -> rel_declaration
+val evaluable_rel : int -> env -> bool
+
+(*s Recurrence on [rel_context] *)
+val fold_rel_context :
+  (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+
+(************************************************************************)
+(* Context of variables (section variables and goal assumptions) *)
+val push_named : named_declaration -> env -> env
+
+(* 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
+
+(*s Recurrence on [named_context]: older declarations processed first *)
+val fold_named_context :
+  (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+
+(* Recurrence on [named_context] starting from younger decl *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a
+
+(* 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
+
+(************************************************************************)
+(*s Global constants *)
+(*s Add entries to global environment *)
+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
+
+(*s [constant_value env c] raises [NotEvaluableConst Opaque] if
+   [c] is opaque and [NotEvaluableConst NoBody] if it has no
+   body and [Not_found] if it does not exist in [env] *)
+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_opt_value : env -> constant -> constr option
+
+(************************************************************************)
+(*s Inductive types *)
+val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
+
+(* Looks up in the context of global inductive names *)
+(* raises [Not_found] if the required path is not found *)
+val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
+
+(************************************************************************)
+(*s Modules *)
+val add_modtype : kernel_name -> module_type_body -> env -> env
+
+(* [shallow_add_module] does not add module components *)
+val shallow_add_module : module_path -> module_body -> env -> env
+
+val lookup_module : module_path -> env -> module_body
+val lookup_modtype : kernel_name -> env -> module_type_body
+
+(************************************************************************)
+(*s Universe constraints *)
+val set_universes   :   Univ.universes -> env -> env
+val add_constraints : Univ.constraints -> env -> env
+
+val set_engagement : engagement -> env -> env
+
+(************************************************************************)
+(* Sets of referred section variables *)
+(* [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
+(* the constr must be an atomic construction *)
+val vars_of_global : env -> constr -> identifier list
+
+val keep_hyps : env -> Idset.t -> section_context
+
+(************************************************************************)
+(*s Unsafe judgments. We introduce here the pre-type of judgments, which is
+  actually only a datatype to store a term with its type and the type of its
+  type. *)
+
+type unsafe_judgment = { 
+  uj_val  : constr;
+  uj_type : types }
+
+val make_judge : constr -> types -> unsafe_judgment
+val j_val  : unsafe_judgment -> constr
+val j_type : unsafe_judgment -> types
+
+type unsafe_type_judgment = { 
+  utj_val  : constr;
+  utj_type : sorts }
+
+
+
+
+
+
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
new file mode 100644
index 00000000..38db01fc
--- /dev/null
+++ b/kernel/esubst.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: esubst.ml,v 1.4.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+(* Explicit lifts and basic operations *)
+type lift =
+  | ELID
+  | ELSHFT of lift * int (* ELSHFT(l,n) == lift of n, then apply lift l *)
+  | ELLFT of int * lift  (* ELLFT(n,l)  == apply l to de Bruijn > n *)
+                         (*                 i.e under n binders *)
+
+(* compose a relocation of magnitude n *)
+let rec el_shft_rec n = function
+  | ELSHFT(el,k) -> el_shft_rec (k+n) el
+  | el           -> ELSHFT(el,n)
+let el_shft n el = if n = 0 then el else el_shft_rec n el
+
+(* cross n binders *)
+let rec el_liftn_rec n = function
+  | ELID        -> ELID
+  | ELLFT(k,el) -> el_liftn_rec (n+k) el
+  | el          -> ELLFT(n, el)
+let el_liftn n el = if n = 0 then el else el_liftn_rec n el
+
+let el_lift el = el_liftn_rec 1 el
+
+(* relocation of de Bruijn n in an explicit lift *)
+let rec reloc_rel n = function
+  | ELID -> n
+  | ELLFT(k,el) ->
+      if n <= k then n else (reloc_rel (n-k) el) + k
+  | ELSHFT(el,k) -> (reloc_rel (n+k) el)
+
+let rec is_lift_id = function
+  | ELID -> true
+  | ELSHFT(e,n) -> n=0 & is_lift_id e
+  | ELLFT (_,e) -> is_lift_id e
+
+(*********************)
+(*  Substitutions    *)
+(*********************)
+
+(* (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 *)
+  | 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) *)
+
+(* operations of subs: collapses constructors when possible.
+ * Needn't be recursive if we always use these functions
+ *)
+
+let subs_cons(x,s) = CONS(x,s)
+
+let subs_liftn n = function
+  | ESID p        -> ESID (p+n) (* bounded identity lifted extends by p *)
+  | LIFT (p,lenv) -> LIFT (p+n, lenv)
+  | lenv          -> LIFT (n,lenv)
+
+let subs_lift a = subs_liftn 1 a
+let subs_liftn n a = if n = 0 then a else subs_liftn n a
+
+let subs_shft = function
+  | (0, s)            -> s
+  | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1)
+  | (n, s)            -> SHIFT (n,s)
+let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a)
+
+let subs_shift_cons = function
+  (0, s, t)           -> CONS(t,s)
+| (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 *)
+let rec is_subs_id = function
+    ESID _     -> true
+  | LIFT(_,s)  -> is_subs_id s
+  | SHIFT(0,s) -> is_subs_id s
+  | _          -> false
+
+(* Expands de Bruijn k in the explicit substitution subs
+ * lams accumulates de shifts to perform when retrieving the i-th value
+ * the rules used are the following:
+ *
+ *    [id]k       --> k
+ *    [S.t]1      --> t
+ *    [S.t]k      --> [S](k-1)  if k > 1
+ *    [^n o S] k  --> [^n]([S]k)
+ *    [(%n S)] k  --> k         if k <= n
+ *    [(%n S)] k  --> [^n]([S](k-n))
+ *
+ * the result is (Inr (k+lams,p)) when the variable is just relocated
+ * where p is None if the variable points inside subs and Some(k) if the
+ * 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))
+
+let expand_rel k subs = exp_rel 0 k subs
+
+let rec comp mk_cl s1 s2 =
+  match (s1, s2) with
+    | _, 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'))
+    | LIFT(k,s), SHIFT(k',s') ->
+        if k<k'
+        then subs_shft(k, comp mk_cl s (subs_shft(k'-k, s')))
+        else subs_shft(k', comp mk_cl (subs_liftn (k-k') s) s')
+    | LIFT(k,s), LIFT(k',s') ->
+        if k<k'
+        then subs_liftn k (comp mk_cl s (subs_liftn (k'-k) s'))
+        else subs_liftn k' (comp mk_cl (subs_liftn (k-k') s) s')
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
new file mode 100644
index 00000000..b02d747b
--- /dev/null
+++ b/kernel/esubst.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: esubst.mli,v 1.3.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+(*s Compact representation of explicit relocations. \\
+   [ELSHFT(l,n)] == lift of [n], then apply [lift l].
+   [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
+type lift =
+  | ELID
+  | ELSHFT of lift * int
+  | ELLFT of int * lift
+
+val el_shft : int -> lift -> lift
+val el_liftn : int -> lift -> lift
+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)$. *)
+type 'a subs =
+  | ESID of int
+  | CONS of 'a * 'a subs
+  | SHIFT of int * 'a subs
+  | LIFT of int * 'a subs
+
+val subs_cons: 'a * '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 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
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
new file mode 100644
index 00000000..88f837aa
--- /dev/null
+++ b/kernel/indtypes.ml
@@ -0,0 +1,548 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: indtypes.ml,v 1.59.2.1 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Inductive
+open Sign
+open Environ
+open Reduction
+open Typeops
+open Entries
+
+(* [check_constructors_names id s cl] checks that all the constructors names
+   appearing in [l] are not present in the set [s], and returns the new set
+   of names. The name [id] is the name of the current inductive type, used
+   when reporting the error. *)
+
+(************************************************************************)
+(* Various well-formedness check for inductive declarations            *)
+
+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
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier * identifier
+  | 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
+
+let check_constructors_names id =
+  let rec check idset = function
+    | [] -> idset
+    | c::cl -> 
+	if Idset.mem c idset then 
+	  raise (InductiveError (SameNamesConstructors (id,c)))
+	else
+	  check (Idset.add c idset) cl
+  in
+  check
+
+(* [mind_check_names mie] checks the names of an inductive types declaration,
+   and raises the corresponding exceptions when two types or two constructors
+   have the same name. *)
+
+let mind_check_names mie =
+  let rec check indset cstset = function
+    | [] -> ()
+    | ind::inds -> 
+	let id = ind.mind_entry_typename in
+	let cl = ind.mind_entry_consnames in
+	if Idset.mem id indset then
+	  raise (InductiveError (SameNamesTypes id))
+	else
+	  let cstset' = check_constructors_names id cstset cl in
+	  check (Idset.add id indset) cstset' inds
+  in
+  check Idset.empty Idset.empty mie.mind_entry_inds
+(* The above verification is not necessary from the kernel point of
+  vue since inductive and constructors are not referred to by their
+  name, but only by the name of the inductive packet and an index. *)
+
+let mind_check_arities env mie =
+  let check_arity id c =
+    if not (is_arity env c) then 
+      raise (InductiveError (NotAnArity id))
+  in
+  List.iter
+    (fun {mind_entry_typename=id; mind_entry_arity=ar} -> check_arity id ar)
+    mie.mind_entry_inds
+
+(************************************************************************)
+(************************************************************************)
+
+(* 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
+
+(* [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 
+*)
+let is_unit constrsinfos =
+  match constrsinfos with  (* One info = One constructor *)
+   | [constrinfos] -> is_logic_constr constrinfos 
+   | [] -> (* type without constructors *) true
+   | _ -> false
+
+let rec infos_and_sort env t =
+  match kind_of_term t with
+    | 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 small = Term.is_small varj.utj_type in
+	(logic,small) :: (infos_and_sort env1 c2)
+    | Cast (c,_) -> infos_and_sort env c
+    | _ -> []
+
+let small_unit constrsinfos =
+  let issmall = List.for_all is_small 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 *)
+
+(* [smax] is the max of the sorts of the products of the constructor type *)
+
+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
+
+let type_one_constructor env_ar_par params arsort c =
+  let infos = infos_and_sort env_ar_par c in
+
+  (* 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
+
+  (* 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
+
+  (infos, full_cstr_type, cst2)
+
+let infer_constructor_packet env_ar params arsort vc =
+  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 an inductive definition. Does not check positivity
+   conditions. *)
+let typecheck_inductive env mie =
+  if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration";
+  (* Check unicity of names *)
+  mind_check_names mie;
+  mind_check_arities env mie;
+  (* We first type params and 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 =
+    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
+         (* Arities (without params) are typed-checked here *)
+	 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,[])
+      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
+
+  (* 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
+	 let consnames = ind.mind_entry_consnames in
+	 let ind' = (params,id,full_arity,consnames,issmall,isunit,lc')
+	 in
+	 (ind'::inds, Constraint.union cst cst'))
+      mie.mind_entry_inds
+      params_arity_list
+      ([],cst) in
+  (env_arities, Array.of_list inds, cst)
+
+(************************************************************************)
+(************************************************************************)
+(* Positivity *)
+
+type ill_formed_ind =
+  | LocalNonPos of int
+  | LocalNotEnoughArgs of int
+  | LocalNotConstructor
+  | LocalNonPar of int * int
+
+exception IllFormedInd of ill_formed_ind
+
+(* [mind_extract_params mie] extracts the params from an inductive types
+   declaration, and checks that they are all present (and all the same)
+   for all the given types. *)
+
+let mind_extract_params = decompose_prod_n_assum
+
+let explain_ind_err ntyp env0 nbpar c err = 
+  let (lpar,c') = mind_extract_params nbpar c in
+  let env = push_rel_context lpar env0 in
+  match err with
+    | LocalNonPos kt -> 
+	raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar))))
+    | LocalNotEnoughArgs kt -> 
+	raise (InductiveError 
+		 (NotEnoughArgs (env,c',mkRel (kt+nbpar))))
+    | LocalNotConstructor ->
+	raise (InductiveError 
+		 (NotConstructor (env,c',mkRel (ntyp+nbpar))))
+    | LocalNonPar (n,l) ->
+	raise (InductiveError 
+		 (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar))))
+
+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"
+
+(* Check the inductive type is called with the expected parameters *)
+let check_correct_par (env,n,ntypes,_) hyps l largs =
+  let nparams = rel_context_nhyps hyps in
+  let largs = Array.of_list largs in
+  if Array.length largs < nparams then 
+    raise (IllFormedInd (LocalNotEnoughArgs l));
+  let (lpar,largs') = array_chop nparams largs in
+  let nhyps = List.length hyps in
+  let rec check k index = function
+    | [] -> ()
+    | (_,Some _,_)::hyps -> check k (index+1) hyps
+    | _::hyps ->
+        match kind_of_term (whd_betadeltaiota env lpar.(k)) with
+	  | Rel w when w = index -> check (k-1) (index+1) hyps
+	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
+  in check (nparams-1) (n-nhyps) hyps;
+  if not (array_for_all (noccur_between n ntypes) largs') then 
+    failwith_non_pos_vect n ntypes largs'
+
+(* This removes global parameters of the inductive types in lc (for
+   nested inductive types only ) *)
+let abstract_mind_lc env ntyps npars lc = 
+  if npars = 0 then 
+    lc
+  else 
+    let make_abs = 
+      list_tabulate
+	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps 
+    in 
+    Array.map (substl make_abs) lc
+
+(* [env] is the typing environment
+   [n] is the dB of the last inductive type
+   [ntypes] is the number of inductive types in the definition
+     (i.e. range of inductives is [n; n+ntypes-1])
+   [lra] is the list of recursive tree of each variable
+ *) 
+let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
+ (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
+
+let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
+  let auxntyp = 1 in
+  let env' =
+    push_rel (Anonymous,None,
+              hnf_prod_applist env (type_of_inductive env mi) 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
+  (* New index of the inductive types *)
+  let newidx = n + auxntyp in
+  (env', newidx, ntypes, ra_env')
+
+(* 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
+  (* check the inductive types occur positively in [c] *)
+  let rec check_pos (env, n, ntypes, ra_env as ienv) c = 
+    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    match kind_of_term x with
+      | Prod (na,b,d) ->
+	  assert (largs = []);
+          if not (noccur_between n ntypes b) then
+	    raise (IllFormedInd (LocalNonPos n));
+	  check_pos (ienv_push_var ienv (na, b, mk_norec)) 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
+      | 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)
+      | err -> 
+	  if noccur_between n ntypes x &&
+             List.for_all (noccur_between n ntypes) largs 
+	  then mk_norec
+	  else raise (IllFormedInd (LocalNonPos n))
+
+  (* 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) =
+    let (mib,mip) = lookup_mind_specif env mi in
+    let auxnpar = mip.mind_nparams in
+    let (lpar,auxlargs) =
+      try list_chop auxnpar largs 
+      with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in 
+    (* If the inductive appears in the args (non params) then the
+       definition is not positive. *)
+    if not (List.for_all (noccur_between n ntypes) auxlargs) then
+      raise (IllFormedInd (LocalNonPos n));
+    (* We do not deal with imbricated mutual inductive types *)
+    let auxntyp = mib.mind_ntypes in 
+    if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+    (* The nested inductive type with parameters removed *)
+    let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+    (* Extends the environment with a variable corresponding to
+       the inductive def *)
+    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 = 
+      (* 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') 
+	auxlcvect
+    in 
+    (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 = 
+      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 ienv' = ienv_push_var ienv (na,b,mk_norec) in
+	    check_constr_rec ienv' (recarg::lrec) d
+
+	| hd ->
+	    if check_head then
+	      if hd = Rel (n+ntypes-i-1) then
+		check_correct_par ienv hyps (ntypes-i) largs
+	      else
+		raise (IllFormedInd LocalNotConstructor)
+	    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
+  in
+  mk_paths (Mrec i)
+    (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
+        try
+	  check_constructors ienv true rawc
+        with IllFormedInd err -> 
+	  explain_ind_err (ntypes-i) env nparams c err)
+      indlc)
+
+let check_positivity env_ar 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 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)
+
+
+(************************************************************************)
+(************************************************************************)
+(* Build the inductive packet *)
+    
+(* Elimination sorts *)
+let is_recursive = Rtree.is_infinite
+(*  let rec one_is_rec rvec = 
+    List.exists (function Mrec(i) -> List.mem i listind 
+                   | Imbr(_,lvec) -> array_exists one_is_rec lvec
+                   | Norec -> false) rvec
+  in 
+  array_exists one_is_rec
+*)
+
+let all_sorts = [InProp;InSet;InType]
+let impredicative_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 finite inds 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
+  (* 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
+    (* 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 = if nf_lc = lc then lc else nf_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
+    (* Build the inductive packet *)
+    { mind_typename = id;
+      mind_nparams = nparamargs;
+      mind_params_ctxt = params;
+      mind_user_arity  = ar;
+      mind_nf_arity = nf_ar;
+      mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
+      mind_sort = ar_sort;
+      mind_kelim = kelim;
+      mind_consnames = Array.of_list cnames;
+      mind_user_lc = lc;
+      mind_nf_lc = nf_lc;
+      mind_recargs = recarg;
+    } in
+  let packets = array_map2 build_one_packet inds recargs in
+  (* Build the mutual inductive *)
+  { mind_ntypes = ntypes;
+    mind_finite = finite;
+    mind_hyps = hyps;
+    mind_packets = packets;
+    mind_constraints = cst;
+    mind_equiv = None;
+  }
+
+(************************************************************************)
+(************************************************************************)
+
+let check_inductive env mie =
+  (* First type-check the inductive definition *)
+  let (env_arities, inds, cst) = typecheck_inductive env mie in
+  (* Then check positivity conditions *)
+  let recargs = check_positivity env_arities inds in
+  (* Build the inductive packets *)
+  build_inductive env env_arities mie.mind_entry_finite inds recargs cst
+
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
new file mode 100644
index 00000000..f5e6d047
--- /dev/null
+++ b/kernel/indtypes.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: indtypes.mli,v 1.23.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Entries
+open Typeops
+(*i*)
+
+
+(*s The different kinds of errors that may result of a malformed inductive
+  definition. *)
+
+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
+  | NonPar of env * constr * int * constr * constr
+  | SameNamesTypes of identifier
+  | SameNamesConstructors of identifier * identifier
+  | 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
+
+(*s The following function does checks on inductive declarations. *)
+
+val check_inductive :
+  env -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
new file mode 100644
index 00000000..07e9b8ea
--- /dev/null
+++ b/kernel/inductive.ml
@@ -0,0 +1,831 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: inductive.ml,v 1.74.2.2 2004/07/16 19:30:25 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Sign
+open Declarations
+open Environ
+open Reduction
+open Type_errors
+
+(* raise Not_found if not an inductive type *)
+let lookup_mind_specif env (kn,tyi) =
+  let mib = Environ.lookup_mind kn env in
+  if tyi >= Array.length mib.mind_packets then
+    error "Inductive.lookup_mind_specif: invalid inductive index";
+  (mib, mib.mind_packets.(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
+
+let find_inductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match kind_of_term t with
+    | Ind ind
+        when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+let find_coinductive env c =
+  let (t, l) = decompose_app (whd_betadeltaiota env c) in
+  match kind_of_term t with
+    | Ind ind
+        when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+    | _ -> raise Not_found
+
+(************************************************************************)
+
+(* Build the substitution that replaces Rels by the appropriate *)
+(* inductives *)
+let ind_subst mind mib =
+  let ntypes = mib.mind_ntypes in
+  let make_Ik k = mkInd (mind,ntypes-k-1) in 
+  list_tabulate make_Ik ntypes
+
+(* Instantiate inductives in constructor type *)
+let constructor_instantiate mind mib c =
+  let s = ind_subst mind mib in
+  type_app (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 () =
+    anomaly "instantiate_params: type, ctxt and args mismatch" in
+  let (rem_args, subs, ty) =
+    Sign.fold_rel_context
+      (fun (_,copt,_) (largs,subs,ty) ->
+        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())
+      sign
+      ~init:(args,[],t) 
+  in
+  if rem_args <> [] then fail();
+  type_app (substl subs) ty
+
+let full_inductive_instantiate mip params t =
+  instantiate_params t params mip.mind_params_ctxt
+
+let full_constructor_instantiate (((mind,_),mib,mip),params) =
+  let inst_ind = constructor_instantiate mind mib in
+  (fun t ->
+    instantiate_params (inst_ind t) params mip.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
+
+(************************************************************************)
+(* Type of a constructor *)
+
+let type_of_constructor env cstr =
+  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
+  if i > nconstr then error "Not enough constructors in the type";
+  constructor_instantiate (fst ind) mib specif.(i-1)
+
+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 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
+
+(* Type of case predicates *)
+
+let local_rels ctxt =
+  let (rels,_) =
+    Sign.fold_rel_context_reverse
+      (fun (rels,n) (_,copt,_) ->
+        match copt with
+            None   -> (mkRel n :: rels, n+1)
+          | Some _ -> (rels, n+1))
+      ~init:([],1)
+      ctxt 
+  in
+  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 nrealargs = mip.mind_nrealargs in
+  applist 
+    (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign))
+
+
+(* This exception is local *)
+exception LocalArity of (constr * constr * arity_error) option
+
+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 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') ->
+          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
+            | Sort s -> family_of_sort s 
+	    | _ -> raise (LocalArity None) in
+	  let dep_ind = build_dependent_inductive ind mip 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 (_,_,_) ->
+	  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
+  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
+
+
+(************************************************************************)
+(* Type of case branches *)
+
+(* [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_one_branch i cty =
+    let typi = full_constructor_instantiate ((ind,mib,mip),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 cargs =
+      if dep then
+        let cstr = ith_constructor_of_inductive ind (i+1) in
+        let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
+        vargs @ [dep_cstr]
+      else
+        vargs in
+    let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
+    it_mkProd_or_LetIn base args in
+  Array.mapi build_one_branch mip.mind_nf_lc
+
+(* [p] is the predicate, [c] is the match object, [realargs] is the
+   list of real args of the inductive type *)
+let build_case_type dep p c realargs =
+  let args = if dep then realargs@[c] else realargs in
+  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 (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 ty = build_case_type dep p c realargs in
+  (lc, ty, univ)
+
+
+(************************************************************************)
+(* Checking the case annotation is relevent *)
+
+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)
+  then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
+
+(************************************************************************)
+(************************************************************************)
+
+(* Guard conditions for fix and cofix-points *)
+
+(* Check if t is a subterm of Rel n, and gives its specification, 
+   assuming lst already gives index of
+   subterms with corresponding specifications of recursive arguments *)
+
+(* A powerful notion of subterm *)
+
+(* To each inductive definition corresponds an array describing the
+   structure of recursive arguments for each constructor, we call it
+   the recursive spec of the type (it has type recargs vect).  For
+   checking the guard, we start from the decreasing argument (Rel n)
+   with its recursive spec.  During checking the guardness condition,
+   we collect patterns variables corresponding to subterms of n, each
+   of them with its recursive spec.  They are organised in a list lst
+   of type (int * recargs) list which is sorted with respect to the
+   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.
+
+   Below are functions to handle such environment.
+ *)
+type size = Large | Strict
+
+let size_glb s1 s2 =
+  match s1,s2 with
+      Strict, Strict -> Strict
+    | _ -> Large
+
+type subterm_spec =
+    Subterm of (size * wf_paths)
+  | Dead_code
+  | Not_subterm
+
+let spec_of_tree t =
+  if t=mk_norec then Not_subterm else Subterm(Strict,t)
+
+let subterm_spec_glb =
+  let glb2 s1 s2 =
+    match s1,s2 with
+        _, Dead_code -> s1
+      | Dead_code, _ -> s2
+      | Not_subterm, _ -> Not_subterm
+      | _, Not_subterm -> Not_subterm
+      | Subterm (a1,t1), Subterm (a2,t2) ->
+          if t1=t2 then Subterm (size_glb a1 a2, t1)
+          (* branches do not return objects with same spec *)
+          else Not_subterm in
+  Array.fold_left glb2 Dead_code
+          
+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;
+  }
+
+let make_renv env minds recarg (kn,tyi) =
+  let mib = Environ.lookup_mind kn env in
+  let mind_recvec =
+    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+  { env = env;
+    rel_min = recarg+2;
+    inds = minds;
+    recvec = mind_recvec;
+    genv = [Subterm(Large,mind_recvec.(tyi))] }
+
+let push_var renv (x,ty,spec) =
+  { renv with 
+    env = push_rel (x,None,ty) renv.env;
+    rel_min = renv.rel_min+1;
+    genv = spec:: renv.genv }
+
+let assign_var_spec renv (i,spec) =
+  { renv with genv = list_assign renv.genv (i-1) spec }
+
+let push_var_renv renv (x,ty) =
+  push_var renv (x,ty,Not_subterm)
+
+(* Fetch recursive information about a variable p *)
+let subterm_var p renv = 
+  try List.nth renv.genv (p-1)
+  with Failure _ | Invalid_argument _ -> Not_subterm
+
+(* Add a variable and mark it as strictly smaller with information [spec]. *)
+let add_subterm renv (x,a,spec) =
+  push_var renv (x,a,spec_of_tree spec)
+
+let push_ctxt_renv renv ctxt =
+  let n = rel_context_length ctxt in
+  { renv with 
+    env = push_rel_context ctxt renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+let push_fix_renv renv (_,v,_ as recdef) =
+  let n = Array.length v in
+  { renv with
+    env = push_rec_types recdef renv.env;
+    rel_min = renv.rel_min+n;
+    genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+
+
+(******************************)
+(* Computing the recursive subterms of a term (propagation of size
+   information through Cases). *)
+
+(*
+   c is a branch of an inductive definition corresponding to the spec
+   lrec.  mind_recvec is the recursive spec of the inductive
+   definition of the decreasing argument n.
+
+   case_branches_specif renv lrec lc will pass the lambdas
+   of c corresponding to pattern variables and collect possibly new
+   subterms variables and returns the bodies of the branches with the
+   correct envs and decreasing args.
+*)
+
+let lookup_subterms env ind =
+  let (_,mip) = lookup_mind_specif env ind in
+  mip.mind_recargs
+
+(*********************************)
+
+(* 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
+
+(* 
+   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
+*)
+
+let rec subterm_specif renv t ind = 
+  let f,l = decompose_app (whd_betadeltaiota renv.env t) in
+  match kind_of_term f with 
+    | Rel k -> subterm_var k renv
+
+    | 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 stl  =
+            Array.map (fun (renv',br') -> subterm_specif renv' br' ind)
+              lbr_spec in
+          subterm_spec_glb stl
+	       
+    | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+(* when proving that the fixpoint f(x)=e is less than n, it is enough
+   to prove that e is less than n assuming f is less than n
+   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
+	    
+    | Lambda (x,a,b) -> 
+        assert (l=[]);
+        subterm_specif (push_var_renv renv (x,a)) b ind
+
+    (* 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
+    Subterm (Strict,_) | Dead_code -> true
+  |  _ -> false
+
+(************************************************************************)
+
+exception FixGuardError of env * guard_error
+
+let error_illegal_rec_call renv fx arg =
+  let (_,le_vars,lt_vars) =
+    List.fold_left
+      (fun (i,le,lt) sbt ->
+        match sbt with
+            (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt)
+          | (Subterm(Large,_)) -> (i+1, i::le, lt)
+          | _ -> (i+1, le ,lt))
+      (1,[],[]) renv.genv in
+  raise (FixGuardError (renv.env,
+                        RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+
+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 
+  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
+                (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
+	            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)
+
+      (* The cases below simply check recursively the condition on the
+         subterms *)
+      | Cast (a,b) -> 
+          List.for_all (check_rec_call renv) (a::b::l)
+
+      | Lambda (x,a,b) ->
+          check_rec_call (push_var_renv renv (x,a)) b &&
+          List.for_all (check_rec_call renv) (a::l)
+
+      | Prod (x,a,b) -> 
+          check_rec_call (push_var_renv renv (x,a)) b &&
+          List.for_all (check_rec_call renv) (a::l)
+
+      | 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
+
+      | Evar (_,la) -> 
+	  array_for_all (check_rec_call renv) la &&
+          List.for_all (check_rec_call renv) l
+
+      | Meta _ -> true
+
+      | (App _ | LetIn _) -> 
+	  anomaly "check_rec_call: should have been reduced"
+
+      | (Ind _ | Construct _ | Var _ | Sort _) ->
+          List.for_all (check_rec_call renv) l
+
+  and check_nested_fix_body renv decr recArgsDecrArg body =
+    if decr = 0 then
+      check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+    else
+      match kind_of_term body with
+	| Lambda (x,a,b) ->
+            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
+
+
+let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
+  let nbfix = Array.length bodies in 
+  if nbfix = 0
+    or Array.length nvect <> nbfix 
+    or Array.length types <> nbfix
+    or Array.length names <> nbfix
+    or bodynum < 0
+    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
+  (* 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 = 
+      match kind_of_term (whd_betadeltaiota env def) with
+        | Lambda (x,a,b) -> 
+	    if noccur_with_meta n nbfix a then
+	      let env' = push_rel (x, None, a) env in
+              if n = k+1 then
+                (* get the inductive type of the fixpoint *)
+                let (mind, _) = 
+                  try find_inductive env a 
+                  with Not_found -> raise_err i RecursionNotOnInductiveType 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
+    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 (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 ()
+    with FixGuardError (fixenv,err) ->
+      error_ill_formed_rec_body fixenv err names i
+  done
+
+(*
+let cfkey = Profile.declare_profile "check_fix";;
+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
+
+let anomaly_ill_typed () =
+  anomaly "check_one_cofix: too many arguments applied to constructor"
+
+let rec codomain_is_coind env c =
+  let b = whd_betadeltaiota env c in
+  match kind_of_term b with
+    | Prod (x,a,b) ->
+	codomain_is_coind (push_rel (x, None, a) env) b 
+    | _ -> 
+	(try find_coinductive env b
+        with Not_found ->
+	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
+
+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
+      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 
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
+		 
+	| Construct (_,i as cstr_kn)  ->
+            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 rec process_args_of_constr = function
+              | (t::lr), (rar::lrar) -> 
+                  if rar = mk_norec then
+                    if noccur_with_meta n nbfix t
+                    then process_args_of_constr (lr, lrar)
+                    else raise (CoFixGuardError
+		                 (env,RecCallInNonRecArgOfConstructor t))
+                  else
+                    let spec = dest_subterms rar in
+                    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
+            else 
+	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
+	      
+	| CoFix (j,(_,varit,vdefs as recdef)) ->
+            if (List.for_all (noccur_with_meta n nbfix) args)
+            then 
+              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) 
+              else 
+		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
+	    else
+	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
+
+	| Case (_,p,tm,vrest) ->
+            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)
+		else 
+		  raise (CoFixGuardError (env,RecCallInCaseFun c))
+              else 
+		raise (CoFixGuardError (env,RecCallInCaseArg c))
+            else 
+	      raise (CoFixGuardError (env,RecCallInCasePred c))
+              
+	| _    -> 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
+
+(* The  function which checks that the whole block of definitions 
+   satisfies the guarded condition *)
+
+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 ()
+    with CoFixGuardError (errenv,err) -> 
+      error_ill_formed_rec_body errenv err names i
+  done
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
new file mode 100644
index 00000000..ad44fa64
--- /dev/null
+++ b/kernel/inductive.mli
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: inductive.mli,v 1.57.8.1 2004/07/16 19:30:25 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+(*i*)
+
+(*s Extracting an inductive type from a construction *)
+
+(* [find_m*type env sigma c] coerce [c] to an recursive type (I args).
+   [find_rectype], [find_inductive] and [find_coinductive]
+   respectively accepts any recursive type, only an inductive type and
+   only a coinductive type.
+   They raise [Not_found] if not convertible to a recursive type. *)
+
+val find_rectype     : env -> types -> inductive * constr list
+val find_inductive   : env -> types -> inductive * constr list
+val find_coinductive : env -> types -> inductive * constr list
+
+(*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
+
+(*s Functions to build standard types related to inductive *)
+
+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
+
+(* Transforms inductive specification into types (in nf) *)
+val arities_of_specif : mutual_inductive -> 
+  mutual_inductive_body * one_inductive_body -> types array 
+
+(* [type_case_branches env (I,args) (p:A) c] computes useful types
+   about the following Cases expression:
+      <p>Cases (c :: (I args)) of b1..bn end
+   It computes the type of every branch (pattern variables are
+   introduced by products), the type for the whole expression, and
+   the universe constraints generated.
+ *)
+val type_case_branches :
+  env -> inductive * constr list -> unsafe_judgment -> constr
+    -> types array * types * constraints
+
+(* 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
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
new file mode 100644
index 00000000..5e8c7001
--- /dev/null
+++ b/kernel/mod_typing.ml
@@ -0,0 +1,324 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_typing.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+open Util
+open Names
+open Univ
+open Declarations
+open Entries
+open Environ
+open Term_typing
+open Modops
+open Subtyping
+
+exception Not_path
+
+let path_of_mexpr = function
+  | MEident mb -> mb
+  | _ -> raise Not_path
+
+let rec replace_first p k = function 
+  | [] -> [] 
+  | h::t when p h -> k::t
+  | h::t -> h::(replace_first p k t)
+
+let rec list_split_assoc k rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' -> rev_before,b,after
+  | h::tail -> list_split_assoc k (h::rev_before) tail
+
+let rec list_fold_map2 f e = function 
+  |  []  -> (e,[],[])
+  |  h::t -> 
+       let e',h1',h2' = f e h in
+       let e'',t1',t2' = list_fold_map2 f e' t in
+	 e'',h1'::t1',h2'::t2'
+
+let type_modpath env mp = 
+  strengthen env (lookup_module mp env).mod_type mp
+
+let rec translate_modtype env mte =
+  match mte with
+    | MTEident ln -> MTBident ln
+    | MTEfunsig (arg_id,arg_e,body_e) -> 
+	let arg_b = translate_modtype env arg_e in
+	let env' = 
+	  add_module (MPbound arg_id) (module_body_of_type arg_b) env in
+	let body_b = translate_modtype env' body_e in
+	  MTBfunsig (arg_id,arg_b,body_b)
+    | MTEsig (msid,sig_e) ->
+	let str_b,sig_b = translate_entry_list env msid false sig_e in
+	  MTBsig (msid,sig_b)
+    | MTEwith (mte, with_decl) ->
+	let mtb = translate_modtype env mte in
+	  merge_with env mtb with_decl
+
+and merge_with env mtb with_decl = 
+  let msid,sig_b = match (Modops.scrape_modtype env mtb) with 
+    | 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
+  in
+  let l = label_of_id id in
+    try
+      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      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) -> 
+	    let cb = match spec with
+		SPBconst cb -> cb
+	      | _ -> error_not_a_constant l
+	    in 
+	      begin
+		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 cst = 
+			Constraint.union 
+			  (Constraint.union cb.const_constraints cst1)
+			  cst2
+		      in
+			SPBconst {cb with 
+				    const_body = 
+				      Some (Declarations.from_val j.uj_val);
+				    const_constraints = cst}
+		  | Some b -> 
+		      let cst1 = Reduction.conv env' c (Declarations.force b) in
+		      let cst = Constraint.union cb.const_constraints cst1 in
+			SPBconst {cb with 
+				    const_body = Some (Declarations.from_val c);
+				    const_constraints = cst}
+	      end	
+(* and what about msid's ????? Don't they clash ? *)
+	| With_Module (id, mp) ->
+	    let old = match spec with
+		SPBmodule msb -> msb
+	      | _ -> error_not_a_module (string_of_label l)
+	    in
+	    let mtb = type_modpath env' mp in
+	 (* here, using assertions in substitutions, 
+	    we check that there is no msid bound in mtb *)
+	    begin
+	      try 
+		let _ = subst_modtype (map_msid msid (MPself msid)) mtb in
+		  ()
+	      with
+		  Failure _ -> error_circular_with_module id
+	    end;
+	    let cst =
+              try check_subtypes env' mtb old.msb_modtype
+              with Failure _ -> error_with_incorrect (label_of_id id) in
+	    let equiv = 
+ 	      match old.msb_equiv with
+		| None -> Some mp
+		| Some mp' -> 
+		    check_modpath_equiv env' mp mp';
+		    Some mp
+	    in
+	    let msb =
+	      {msb_modtype = mtb; 
+	       msb_equiv = equiv; 
+	       msb_constraints = Constraint.union old.msb_constraints cst }
+	    in
+	      SPBmodule msb
+      in
+	MTBsig(msid,  before@(l,new_spec)::after)
+    with
+	Not_found -> error_no_such_label l
+      | Reduction.NotConvertible -> error_with_incorrect l
+
+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
+    match e with
+      | SPEconst ce ->
+	  let cb = translate_constant env ce in
+	    begin match cb.const_hyps with
+	      |	(_::_) -> error_local_context (Some l)
+	      | [] ->
+		  add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb)
+	    end
+      | SPEmind mie -> 
+	  let mib = translate_mind env mie in
+	    begin match mib.mind_hyps with
+	      |	(_::_) -> error_local_context (Some l)
+	      | [] ->
+		  add_mind kn mib env, (l, SEBmind mib), (l, SPBmind mib)
+	    end
+      | SPEmodule me ->
+	  let mb = translate_module env is_definition me in
+	  let mspec = 
+	    { msb_modtype = mb.mod_type;
+	      msb_equiv = mb.mod_equiv;
+	      msb_constraints = mb.mod_constraints }
+	  in
+	  let mp' = MPdot (mp,l) in
+	    add_module mp' mb env, (l, SEBmodule mb), (l, SPBmodule mspec)
+      | SPEmodtype mte ->
+	  let mtb = translate_modtype env mte in
+	    add_modtype kn mtb env, (l, SEBmodtype mtb), (l, SPBmodtype mtb)
+  in
+  let _,str_b,sig_b = list_fold_map2 do_entry env sig_e
+  in
+    str_b,sig_b
+
+(* if [is_definition=true], [mod_entry_expr] may be any expression.
+   Otherwise it must be a path *)
+
+and translate_module env is_definition me =
+  match me.mod_entry_expr, me.mod_entry_type with
+    | None, None -> 
+	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
+    | None, Some mte -> 
+	let mtb = translate_modtype env mte in
+	{ mod_expr = None;
+	  mod_user_type = Some mtb;
+	  mod_type = mtb;
+	  mod_equiv = None;
+	  mod_constraints = Constraint.empty }
+    | Some mexpr, _ -> 
+	let meq_o = (* do we have a transparent module ? *)
+	  try       (* TODO: transparent field in module_entry *)
+	    match me.mod_entry_type with
+	      | None -> Some (path_of_mexpr mexpr)
+	      | Some _ -> None
+	  with 
+	    | Not_path -> None
+	in
+	let meb,mtb1 = 
+	  if is_definition then
+	    translate_mexpr env mexpr
+	  else 
+	    let mp = 
+	      try 
+		path_of_mexpr mexpr 
+	      with 
+		| Not_path -> error_declaration_not_path mexpr
+	    in
+	      MEBident mp, type_modpath env mp
+	in
+	let mtb, mod_user_type, cst =
+	  match me.mod_entry_type with
+	    | 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
+	in
+	  { mod_type = mtb;
+	    mod_user_type = mod_user_type;
+	    mod_expr = Some meb;
+	    mod_equiv = meq_o;
+	    mod_constraints = cst }
+
+(* translate_mexpr : env -> module_expr -> module_expr_body * module_type_body *)
+and translate_mexpr env mexpr = match mexpr with
+  | MEident mp -> 
+      MEBident mp,
+      type_modpath env mp
+  | MEfunctor (arg_id, arg_e, body_expr) ->
+      let arg_b = translate_modtype env arg_e in
+      let env' = add_module (MPbound arg_id) (module_body_of_type arg_b) env in
+      let (body_b,body_tb) = translate_mexpr env' body_expr in
+	MEBfunctor (arg_id, arg_b, body_b), 
+	MTBfunsig (arg_id, arg_b, body_tb)
+  | MEapply (fexpr,mexpr) ->
+      let feb,ftb = translate_mexpr env fexpr in
+      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 mp = 
+	try
+	  path_of_mexpr mexpr 
+	with
+	  | Not_path -> error_application_to_not_path mexpr
+	      (* place for nondep_supertype *)
+      in
+	MEBapply(feb,meb,cst),
+	subst_modtype (map_mbid farg_id mp) fbody_b
+  | MEstruct (msid,structure) ->
+      let structure,signature = translate_entry_list env msid true structure in
+	MEBstruct (msid,structure),
+	MTBsig (msid,signature)
+
+
+(* is_definition is true - me.mod_entry_expr may be any expression *)
+let translate_module env me = translate_module env true me
+
+let rec add_module_expr_constraints env = function
+  | MEBident _ -> env
+
+  | MEBfunctor (_,mtb,meb) -> 
+      add_module_expr_constraints (add_modtype_constraints env mtb) meb
+
+  | MEBstruct (_,mod_struct_body) ->
+      List.fold_left 
+        (fun env (l,item) -> add_struct_elem_constraints env item)
+        env
+        mod_struct_body
+
+  | MEBapply (meb1,meb2,cst) ->
+      Environ.add_constraints cst 
+        (add_module_expr_constraints 
+	  (add_module_expr_constraints env meb1) 
+	  meb2)
+
+and add_struct_elem_constraints env = function 
+  | SEBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SEBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SEBmodule mb -> add_module_constraints env mb
+  | SEBmodtype mtb -> add_modtype_constraints env mtb
+
+and add_module_constraints env mb = 
+  (* if there is a body, the mb.mod_type is either inferred from the
+     body and hence uninteresting or equal to the non-empty
+     user_mod_type *)
+  let env = match mb.mod_expr with
+    | None -> add_modtype_constraints env mb.mod_type
+    | Some meb -> add_module_expr_constraints env meb
+  in
+  let env = match mb.mod_user_type with
+    | None -> env
+    | Some mtb -> add_modtype_constraints env mtb
+  in
+    Environ.add_constraints mb.mod_constraints env
+
+and add_modtype_constraints env = function
+  | MTBident _ -> env
+  | MTBfunsig (_,mtb1,mtb2) ->
+      add_modtype_constraints
+        (add_modtype_constraints env mtb1)
+        mtb2
+  | MTBsig (_,mod_sig_body) ->
+      List.fold_left 
+        (fun env (l,item) -> add_sig_elem_constraints env item)
+        env
+        mod_sig_body
+
+and add_sig_elem_constraints env = function 
+  | SPBconst cb -> Environ.add_constraints cb.const_constraints env
+  | SPBmind mib -> Environ.add_constraints mib.mind_constraints env
+  | SPBmodule {msb_modtype=mtb; msb_constraints=cst} -> 
+      add_modtype_constraints (Environ.add_constraints cst env) mtb
+  | SPBmodtype mtb -> add_modtype_constraints env mtb
+
+
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
new file mode 100644
index 00000000..0ea98bf0
--- /dev/null
+++ b/kernel/mod_typing.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: mod_typing.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+(*i*)
+open Declarations
+open Environ
+open Entries
+(*i*)
+
+
+val translate_modtype : env -> module_type_entry -> module_type_body
+
+val translate_module : env -> module_entry -> module_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
new file mode 100644
index 00000000..84845af5
--- /dev/null
+++ b/kernel/modops.ml
@@ -0,0 +1,245 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: modops.ml,v 1.12.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Pp
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Entries
+(*i*)
+
+let error_existing_label l = 
+  error ("The label "^string_of_label l^" is already declared")
+
+let error_declaration_not_path _ = error "Declaration is not a path"
+
+let error_application_to_not_path _ = error "Application to not path"
+
+let error_not_a_functor _ = error "Application of not a functor"
+
+let error_incompatible_modtypes _ _ = error "Incompatible module types"
+
+let error_not_equal _ _ = error "Not equal modules"
+
+let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match")
+
+let error_no_such_label l = error ("No such label "^string_of_label l)
+
+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 = 
+  error "The result module type must be a signature"
+
+let error_signature_expected mtb =
+  error "Signature expected"
+
+let error_no_module_to_end _ = 
+  error "No open module to end"
+
+let error_no_modtype_to_end _ =
+  error "No open module type to end"
+
+let error_not_a_modtype_loc loc s = 
+  user_err_loc (loc,"",str ("\""^s^"\" is not a module type"))
+
+let error_not_a_module_loc loc s = 
+  user_err_loc (loc,"",str ("\""^s^"\" is not a module"))
+
+let error_not_a_module s = error_not_a_module_loc dummy_loc s
+
+let error_not_a_constant l = 
+  error ("\""^(string_of_label l)^"\" is not a constant")
+
+let error_with_incorrect l =
+  error ("Incorrect constraint for label \""^(string_of_label l)^"\"")
+
+let error_local_context lo = 
+  match lo with
+      None -> 
+	error ("The local context is not empty.")
+    | (Some l) ->
+	error ("The local context of the component "^
+	       (string_of_label l)^" is not empty")
+
+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 rec scrape_modtype env = function
+  | MTBident kn -> scrape_modtype env (lookup_modtype kn env)
+  | mtb -> mtb
+
+(* the constraints are not important here *)
+let module_body_of_spec msb = 
+    { mod_type = msb.msb_modtype;
+      mod_equiv = msb.msb_equiv;
+      mod_expr = None;
+      mod_user_type = None;
+      mod_constraints = Constraint.empty}
+
+let module_body_of_type mtb = 
+  { mod_type = mtb;
+    mod_equiv = None;
+    mod_expr = None;
+    mod_user_type = None;
+    mod_constraints = Constraint.empty}
+
+
+(* the constraints are not important here *)
+let module_spec_of_body mb = 
+  { msb_modtype = mb.mod_type; 
+    msb_equiv = mb.mod_equiv; 
+    msb_constraints = Constraint.empty}
+
+
+
+let destr_functor = function
+  | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t)
+  | mtb -> error_not_a_functor mtb
+ 
+
+let rec check_modpath_equiv env mp1 mp2 = 
+  if mp1=mp2 then () else
+  let mb1 = lookup_module mp1 env in
+    match mb1.mod_equiv with
+      | None ->
+	  let mb2 = lookup_module mp2 env in
+	    (match mb2.mod_equiv with
+	      | None -> error_not_equal mp1 mp2
+	      | Some mp2' -> check_modpath_equiv env mp2' mp1)
+      | Some mp1' -> check_modpath_equiv env mp2 mp1'
+
+
+let rec subst_modtype sub = function
+  | MTBident ln -> MTBident (subst_kn sub ln)
+  | MTBfunsig (arg_id, arg_b, body_b) ->
+      if occur_mbid arg_id sub then failwith "capture";
+      MTBfunsig (arg_id, 
+		 subst_modtype sub arg_b, 
+		 subst_modtype sub body_b)
+  | MTBsig (sid1, msb) -> 
+      if occur_msid sid1 sub then failwith "capture";
+      MTBsig (sid1, subst_signature sub msb)
+
+and subst_signature sub sign = 
+  let subst_body = function
+      SPBconst cb -> 
+	SPBconst (subst_const_body sub cb)
+    | SPBmind mib -> 
+	SPBmind (subst_mind sub mib)
+    | SPBmodule mb -> 
+	SPBmodule (subst_module sub mb)
+    | SPBmodtype mtb -> 
+	SPBmodtype (subst_modtype sub mtb)
+  in
+    List.map (fun (l,b) -> (l,subst_body b)) sign
+
+and subst_module sub mb =
+  let mtb' = subst_modtype sub mb.msb_modtype in
+  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)
+
+(* we assume that the substitution of "mp" into "msid" is already done
+(or unnecessary) *)
+let rec add_signature mp sign env = 
+  let add_one env (l,elem) =
+    let kn = make_kn mp empty_dirpath l in
+      match elem with
+	| SPBconst cb -> Environ.add_constant kn cb env
+	| SPBmind mib -> Environ.add_mind kn mib env
+	| SPBmodule mb -> 
+	    add_module (MPdot (mp,l)) (module_body_of_spec mb) env 
+	    (* adds components as well *)
+	| SPBmodtype mtb -> Environ.add_modtype kn mtb env
+  in
+    List.fold_left add_one env sign
+
+
+and add_module mp mb env = 
+  let env = Environ.shallow_add_module mp mb env in
+    match scrape_modtype env mb.mod_type with
+      | MTBident _ -> anomaly "scrape_modtype does not work!"
+      | MTBsig (msid,sign) -> 
+	  add_signature mp (subst_signature_msid msid mp sign) env
+
+      | MTBfunsig _ -> env
+
+
+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_subs = Some (Declarations.from_val const) in
+	{cb with 
+      	   const_body = const_subs;
+	   const_opaque = false
+	}
+
+let strengthen_mind env mp l mib = match mib.mind_equiv with
+  | Some _ -> mib
+  | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)}
+    
+let rec strengthen_mtb env mp mtb = match scrape_modtype env mtb with
+  | MTBident _ -> anomaly "scrape_modtype does not work!"
+  | MTBfunsig _ -> mtb
+  | MTBsig (msid,sign) -> MTBsig (msid,strengthen_sig env msid sign mp)
+
+and strengthen_mod env mp msb = 
+  { msb_modtype = strengthen_mtb env mp msb.msb_modtype;
+    msb_equiv = begin match msb.msb_equiv with
+      | Some _ -> msb.msb_equiv
+      | None -> Some mp 
+    end ;
+    msb_constraints = msb.msb_constraints; }
+
+and strengthen_sig env msid sign mp = match sign with
+  | [] -> []
+  | (l,SPBconst cb) :: rest ->
+      let item' = l,SPBconst (strengthen_const env mp l cb) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmind mib) :: rest ->
+      let item' = l,SPBmind (strengthen_mind env mp l mib) in
+      let rest' = strengthen_sig env msid rest mp in
+	item'::rest'
+  | (l,SPBmodule mb) :: rest ->
+      let mp' = MPdot (mp,l) in
+      let item' = l,SPBmodule (strengthen_mod env mp' mb) in
+      let env' = add_module 
+		   (MPdot (MPself msid,l)) 
+		   (module_body_of_spec mb) 
+		   env 
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item'::rest'
+  | (l,SPBmodtype mty as item) :: rest -> 
+      let env' = add_modtype 
+		   (make_kn (MPself msid) empty_dirpath l) 
+		   mty
+		   env
+      in
+      let rest' = strengthen_sig env' msid rest mp in
+	item::rest'
+
+let strengthen env mtb mp = strengthen_mtb env mp mtb
diff --git a/kernel/modops.mli b/kernel/modops.mli
new file mode 100644
index 00000000..5433fa3e
--- /dev/null
+++ b/kernel/modops.mli
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: modops.mli,v 1.7.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Environ
+open Declarations
+open Entries
+(*i*)
+
+(* Various operations on modules and module types *)
+
+(* recursively unfold MTBdent module types *)
+val scrape_modtype : env -> module_type_body -> module_type_body
+
+(* make the environment entry out of type *)
+val module_body_of_type : module_type_body -> module_body
+
+val module_body_of_spec : module_specification_body -> module_body 
+
+val module_spec_of_body : module_body -> module_specification_body
+
+
+val destr_functor : 
+  module_type_body -> mod_bound_id * module_type_body * module_type_body
+
+
+val subst_modtype : substitution -> module_type_body -> module_type_body
+
+val subst_signature_msid :
+  mod_self_id -> module_path -> 
+  module_signature_body -> module_signature_body
+
+(* [add_signature mp sign env] assumes that the substitution [msid]
+   \mapsto [mp] has already been performed (or is not necessary, like
+   when [mp = MPself msid]) *)
+val add_signature : 
+  module_path -> module_signature_body -> env -> env
+
+(* adds a module and its components, but not the constraints *)
+val add_module :
+  module_path -> module_body -> env -> env
+
+val check_modpath_equiv : env -> module_path -> module_path -> unit
+
+val strengthen : env -> module_type_body -> module_path -> module_type_body
+
+val error_existing_label : label -> 'a
+
+val error_declaration_not_path : module_expr -> 'a
+
+val error_application_to_not_path : module_expr -> 'a
+
+val error_not_a_functor : module_expr -> 'a
+
+val error_incompatible_modtypes : 
+  module_type_body -> module_type_body -> 'a
+
+val error_not_equal : module_path -> module_path -> 'a
+
+val error_not_match : label -> specification_body -> 'a
+  
+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_signature_expected : module_type_body -> 'a
+
+val error_no_module_to_end : unit -> 'a 
+
+val error_no_modtype_to_end : unit -> 'a
+
+val error_not_a_modtype_loc : loc -> string -> 'a 
+
+val error_not_a_module_loc : loc -> string -> 'a 
+
+val error_not_a_module : string -> 'a 
+
+val error_not_a_constant : label -> 'a
+
+val error_with_incorrect : label -> 'a
+
+val error_local_context : label option -> 'a
+
+val error_circular_with_module : identifier -> 'a
diff --git a/kernel/names.ml b/kernel/names.ml
new file mode 100644
index 00000000..df3a012f
--- /dev/null
+++ b/kernel/names.ml
@@ -0,0 +1,355 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: names.ml,v 1.53.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Pp
+open Util
+
+(*s Identifiers *)
+
+type identifier = string
+
+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)
+
+(* Hash-consing of identifier *)
+module Hident = Hashcons.Make(
+  struct 
+    type t = string
+    type u = string -> string
+    let hash_sub hstr id = hstr id
+    let equal id1 id2 = id1 == id2
+    let hash = Hashtbl.hash
+  end)
+
+module IdOrdered = 
+  struct
+    type t = identifier
+    let compare = id_ord
+  end
+
+module Idset = Set.Make(IdOrdered)
+module Idmap = Map.Make(IdOrdered)
+module Idpred = Predicate.Make(IdOrdered)
+
+(* Names *)
+
+type name = Name of identifier | Anonymous
+
+(* Dirpaths are lists of module identifiers. The actual representation
+   is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
+ 
+type module_ident = identifier
+type dir_path = module_ident list
+
+module ModIdOrdered = 
+  struct
+    type t = identifier
+    let compare = Pervasives.compare
+  end
+
+module ModIdmap = Map.Make(ModIdOrdered)
+
+let make_dirpath x = x
+let repr_dirpath x = x
+
+let empty_dirpath = []
+
+let string_of_dirpath = function
+  | [] -> "<empty>"
+  | sl ->
+      String.concat "." (List.map string_of_id (List.rev sl))
+
+
+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) = 
+  "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+
+module Umap = Map.Make(struct 
+			 type t = uniq_ident 
+			 let compare = Pervasives.compare
+		       end)
+
+
+type mod_self_id = uniq_ident
+let make_msid = make_uid
+let debug_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 id_of_mbid (_,s,_) = s
+
+type label = string
+let mk_label l = l
+let string_of_label l = l
+
+let id_of_label l = l
+let label_of_id id = id
+
+module Labset = Idset
+module Labmap = Idmap
+
+type module_path =
+  | MPfile of dir_path
+  | MPbound of mod_bound_id
+  | MPself of mod_self_id 
+  | MPdot of module_path * label
+
+let rec string_of_mp = function
+  | MPfile sl -> string_of_dirpath sl
+  | MPbound uid -> string_of_uid uid
+  | MPself uid -> string_of_uid uid
+  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
+
+(* we compare labels first if both are MPdots *)
+let rec mp_ord mp1 mp2 = match (mp1,mp2) with
+    MPdot(mp1,l1), MPdot(mp2,l2) -> 
+      let c = Pervasives.compare l1 l2 in
+	if c<>0 then
+	  c
+	else
+	  mp_ord mp1 mp2
+  |  _,_ -> Pervasives.compare mp1 mp2
+
+module MPord = struct
+  type t = module_path
+  let compare = mp_ord
+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
+
+let make_kn mp dir l = (mp,dir,l)
+let repr_kn kn = kn
+
+let modpath kn = 
+  let mp,_,_ = repr_kn kn in mp
+
+let label kn = 
+  let _,_,l = repr_kn kn in l
+
+let string_of_kn (mp,dir,l) = 
+  string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label 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
+    let c = Pervasives.compare l1 l2 in
+      if c <> 0 then
+	c
+      else 
+	let c = Pervasives.compare dir1 dir2 in
+	  if c<>0 then
+	    c 
+	  else
+	    MPord.compare mp1 mp2
+
+
+module KNord = struct
+  type t = kernel_name
+  let compare =kn_ord
+end
+
+module KNmap = Map.Make(KNord)
+module KNpred = Predicate.Make(KNord)
+module KNset = Set.Make(KNord)
+
+
+let default_module_name = id_of_string "If you see this, it's a bug"
+
+let initial_dir = make_dirpath [default_module_name]
+
+let initial_msid = (make_msid initial_dir "If you see this, it's a bug")
+let initial_path = MPself initial_msid
+
+type variable = identifier
+type constant = kernel_name
+type mutual_inductive = kernel_name
+type inductive = mutual_inductive * int
+type constructor = inductive * int
+
+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
+
+(* Better to have it here that in closure, since used in grammar.cma *)
+type evaluable_global_reference =
+  | EvalVarRef of identifier
+  | EvalConstRef of constant
+
+(* Hash-consing of name objects *)
+module Hname = Hashcons.Make(
+  struct 
+    type t = name
+    type u = identifier -> identifier
+    let hash_sub hident = function
+      | Name id -> Name (hident id)
+      | n -> n
+    let equal n1 n2 =
+      match (n1,n2) with
+	| (Name id1, Name id2) -> id1 == id2
+        | (Anonymous,Anonymous) -> true
+        | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Hdir = Hashcons.Make(
+  struct 
+    type t = dir_path
+    type u = identifier -> identifier
+    let hash_sub hident d = List.map hident d
+    let rec equal d1 d2 = match (d1,d2) with
+      | [],[] -> true
+      | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
+      | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Huniqid = Hashcons.Make(
+  struct 
+    type t = uniq_ident
+    type u = (string -> string) * (dir_path -> dir_path)
+    let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir)
+    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2
+    let hash = Hashtbl.hash
+  end)
+
+module Hmod = Hashcons.Make(
+  struct 
+    type t = module_path
+    type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) *
+	(string -> string)
+    let rec hash_sub (hdir,huniqid,hstr as hfuns) = function
+      | MPfile dir -> MPfile (hdir dir)
+      | MPbound m -> MPbound (huniqid m)
+      | MPself m -> MPself (huniqid m)
+      | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l)
+    let rec equal d1 d2 = match (d1,d2) with
+      | MPfile dir1, MPfile dir2 -> dir1 == dir2
+      | MPbound m1, MPbound m2 -> m1 == m2
+      | MPself m1, MPself m2 -> m1 == m2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
+      | _ -> false
+    let hash = Hashtbl.hash
+  end)
+
+module Hkn = Hashcons.Make(
+  struct 
+    type t = kernel_name
+    type u = (module_path -> module_path)
+	* (dir_path -> dir_path) * (string -> string)
+    let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l)
+    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
+      mod1 == mod2 && dir1 == dir2 && l1 == l2
+    let hash = Hashtbl.hash
+  end)
+
+let hcons_names () =
+  let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in
+  let hident = Hashcons.simple_hcons Hident.f hstring in
+  let hname = Hashcons.simple_hcons Hname.f hident in
+  let hdir = Hashcons.simple_hcons Hdir.f hident in
+  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)
diff --git a/kernel/names.mli b/kernel/names.mli
new file mode 100644
index 00000000..07c19841
--- /dev/null
+++ b/kernel/names.mli
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: names.mli,v 1.46.6.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*s Identifiers *)
+
+type identifier
+type name = Name of identifier | Anonymous
+(* Parsing and printing of identifiers *)
+val string_of_id : identifier -> string
+val id_of_string : string -> identifier
+
+val id_ord : identifier -> identifier -> int
+
+(* Identifiers sets and maps *)
+module Idset  : Set.S with type elt = identifier
+module Idpred : Predicate.S with type elt = identifier
+module Idmap  : Map.S with type key = identifier
+
+(*s Directory paths = section names paths *)
+type module_ident = identifier
+module ModIdmap : Map.S with type key = module_ident
+
+type dir_path
+
+(* Inner modules idents on top of list (to improve sharing).
+   For instance: A.B.C is ["C";"B";"A"] *)
+val make_dirpath : module_ident list -> dir_path
+val repr_dirpath : dir_path -> module_ident list
+
+val empty_dirpath : dir_path
+
+(* Printing of directory paths as ["coq_root.module.submodule"] *)
+val string_of_dirpath : dir_path -> string
+
+
+(*s Unique identifier to be used as "self" in structures and 
+  signatures - invisible for users *)
+  
+type mod_self_id
+
+(* The first argument is a file name - to prevent conflict between 
+   different files *)
+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
+
+(*s Unique names for bound modules *)
+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
+
+(*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
+
+module Labset : Set.S with type elt = label
+module Labmap : Map.S with type key = label
+
+(*s The module part of the kernel name *)
+type module_path =
+  | MPfile of dir_path
+  | MPbound of mod_bound_id
+  | MPself of mod_self_id 
+  | MPdot of module_path * label
+(*i  | MPapply of module_path * module_path    in the future (maybe) i*)
+
+
+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] *)
+
+(* Initial "seed" of the unique identifier generator *)
+val initial_dir : dir_path
+
+(*s The absolute names of objects seen by kernel *)
+
+type kernel_name
+
+(* Constructor and destructor *)
+val make_kn : module_path -> dir_path -> label -> kernel_name
+val repr_kn : kernel_name -> module_path * dir_path * label
+
+val modpath : kernel_name -> module_path
+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
+module KNpred : Predicate.S with type elt = kernel_name
+module KNmap  : Map.S with type key = kernel_name
+
+
+(*s Specific paths for declarations *)
+
+type variable = identifier
+type constant = kernel_name
+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
+
+val ith_mutual_inductive : inductive -> int -> inductive
+val ith_constructor_of_inductive : inductive -> int -> constructor
+val inductive_of_constructor : constructor -> inductive
+val index_of_constructor : constructor -> int
+
+(* Better to have it here that in Closure, since required in grammar.cma *)
+type evaluable_global_reference =
+  | EvalVarRef of identifier
+  | EvalConstRef of constant
+
+(* Hash-consing *)
+val hcons_names : unit ->
+  (kernel_name -> kernel_name) * (dir_path -> dir_path) *
+  (name -> name) * (identifier -> identifier) * (string -> string)
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
new file mode 100644
index 00000000..5428a40d
--- /dev/null
+++ b/kernel/reduction.ml
@@ -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        *)
+(************************************************************************)
+
+(* $Id: reduction.ml,v 1.91.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Univ
+open Declarations
+open Environ
+open Closure
+open Esubst
+
+let rec is_empty_stack = function
+    [] -> true
+  | Zupdate _::s -> is_empty_stack s
+  | Zshift _::s -> is_empty_stack s
+  | _ -> false
+
+(* Compute the lift to be performed on a term placed in a given stack *)
+let el_stack el stk =
+  let n =
+    List.fold_left
+      (fun i z ->
+        match z with
+            Zshift n -> i+n
+          | _ -> i)
+      0
+      stk in
+  el_shft n el
+
+let compare_stack_shape stk1 stk2 =
+  let rec compare_rec bal stk1 stk2 =
+  match (stk1,stk2) with
+      ([],[]) -> 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
+    | (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) ->
+        bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
+    | (_,_) -> false in
+  compare_rec 0 stk1 stk2
+
+let pure_stack lfts stk =
+  let rec pure_rec lfts stk =
+    match stk with
+        [] -> (lfts,[])
+      | zi::s ->
+          (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)
+            | (Zfix(fx,a),(l,pstk)) ->
+                let (lfx,pa) = pure_rec l a in
+                (l, Zfix((lfx,fx),pa)::pstk)
+            | (Zcase(ci,p,br),(l,pstk)) ->
+                (l,Zcase(ci,(l,p),Array.map (fun t -> (l,t)) br)::pstk)) in
+  snd (pure_rec lfts stk)
+
+(****************************************************************************)
+(*                   Reduction Functions                                    *)
+(****************************************************************************)
+
+let nf_betaiota t =
+  norm_val (create_clos_infos betaiota empty_env) (inject t)
+
+let whd_betaiotazeta env x =
+  match kind_of_term x with
+    | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> x
+    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
+
+let whd_betadeltaiota env t = 
+  match kind_of_term t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t)
+
+let whd_betadeltaiota_nolet env t = 
+  match kind_of_term t with
+    | (Sort _|Meta _|Evar _|Ind _|Construct _|
+       Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t
+    | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t)
+
+(* Beta *)
+
+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)
+
+(********************************************************************)
+(*                         Conversion                               *)
+(********************************************************************)
+
+(* Conversion utility functions *)
+type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+
+exception NotConvertible
+exception NotConvertibleVect of int
+
+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
+          (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)) ->
+                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
+            | _ -> assert false)
+      | _ -> cuniv in
+  if compare_stack_shape stk1 stk2 then
+    cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv
+  else raise NotConvertible
+
+(* Convertibility of sorts *)
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+let sort_cmp pb s0 s1 cuniv =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible
+    | (Prop c1, Type u)  ->
+        (match pb with
+            CUMUL -> cuniv
+          | _ -> raise NotConvertible)
+    | (Type u1, Type u2) ->
+	(match pb with
+           | CONV -> enforce_eq u1 u2 cuniv
+	   | CUMUL -> enforce_geq u2 u1 cuniv)
+    | (_, _) -> raise NotConvertible
+
+
+let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
+
+let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
+
+
+(* Conversion between  [lft1]term1 and [lft2]term2 *)
+let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = 
+  Util.check_for_interrupt ();
+  eqappr cv_pb infos
+    (lft1, whd_stack infos term1 [])
+    (lft2, whd_stack infos term2 [])
+    cuniv
+
+(* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
+and eqappr cv_pb infos appr1 appr2 cuniv =
+  let (lft1,(hd1,v1)) = appr1 in
+  let (lft2,(hd2,v2)) = appr2 in
+  let el1 = el_stack lft1 v1 in
+  let el2 = el_stack lft2 v2 in
+  match (fterm_of hd1, fterm_of hd2) with
+    (* case of leaves *)
+    | (FAtom a1, FAtom a2) ->
+	(match kind_of_term a1, kind_of_term a2 with
+	   | (Sort s1, Sort s2) -> 
+	       assert (is_empty_stack v1 && is_empty_stack v2);
+	       sort_cmp cv_pb s1 s2 cuniv
+	   | (Meta n, Meta m) ->
+               if n=m
+	       then convert_stacks infos lft1 lft2 v1 v2 cuniv
+               else raise NotConvertible
+	   | _ -> raise NotConvertible)
+    | (FEvar (ev1,args1), FEvar (ev2,args2)) ->
+        if ev1=ev2 then
+          let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in
+          convert_vect infos el1 el2 args1 args2 u1
+        else raise NotConvertible
+
+    (* 2 index known to be bound to no constant *)
+    | (FRel n, FRel m) ->
+        if reloc_rel n el1 = reloc_rel m el2
+        then convert_stacks infos lft1 lft2 v1 v2 cuniv
+        else raise NotConvertible
+
+    (* 2 constants, 2 local defined vars or 2 defined rels *)
+    | (FFlex fl1, FFlex fl2) ->
+	(try (* try first intensional equality *)
+	  if fl1 = fl2
+          then convert_stacks infos lft1 lft2 v1 v2 cuniv
+          else raise NotConvertible
+        with NotConvertible ->
+          (* else the oracle tells which constant is to be expanded *)
+          let (app1,app2) =
+            if Conv_oracle.oracle_order fl1 fl2 then
+              match unfold_reference infos fl1 with
+                | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+                | None ->
+                    (match unfold_reference infos fl2 with
+                      | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+		      | None -> raise NotConvertible)
+            else
+	      match unfold_reference infos fl2 with
+                | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2))
+                | None ->
+                    (match unfold_reference infos fl1 with
+                    | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2)
+		    | None -> raise NotConvertible) in
+          eqappr cv_pb infos app1 app2 cuniv)
+
+    (* only one constant, defined var or defined rel *)
+    | (FFlex fl1, _)      ->
+        (match unfold_reference infos fl1 with
+           | Some def1 -> 
+	       eqappr cv_pb infos (lft1, whd_stack infos def1 v1) appr2 cuniv
+           | None -> raise NotConvertible)
+    | (_, FFlex fl2)      ->
+        (match unfold_reference infos fl2 with
+           | Some def2 -> 
+	       eqappr cv_pb infos appr1 (lft2, whd_stack infos def2 v2) cuniv
+           | None -> raise NotConvertible)
+	
+    (* other constructors *)
+    | (FLambda _, FLambda _) ->
+        let (_,ty1,bd1) = destFLambda mk_clos hd1 in
+        let (_,ty2,bd2) = destFLambda mk_clos hd2 in
+        let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+
+    | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
+        assert (is_empty_stack v1 && is_empty_stack v2);
+	(* Luo's system *)
+        let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
+
+    (* Inductive types:  MutInd MutConstruct Fix Cofix *)
+
+     | (FInd (kn1,i1), FInd (kn2,i2)) ->
+         if i1 = i2 && mind_equiv infos kn1 kn2
+	 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
+	 then
+           convert_stacks infos lft1 lft2 v1 v2 cuniv
+         else raise NotConvertible
+
+     | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
+	 if op1 = op2
+	 then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+	   let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
+           let u2 =
+             convert_vect infos 
+		 (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+           convert_stacks infos lft1 lft2 v1 v2 u2
+         else raise NotConvertible
+
+     | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
+         if op1 = op2
+         then
+	   let n = Array.length cl1 in
+           let fty1 = Array.map (mk_clos e1) tys1 in
+           let fty2 = Array.map (mk_clos e2) tys2 in
+           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+           let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
+           let u2 =
+	     convert_vect infos
+		 (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+           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"
+
+     | _ -> 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)
+    lft1 stk1 lft2 stk2 cuniv
+
+and convert_vect infos lft1 lft2 v1 v2 cuniv =
+  let lv1 = Array.length v1 in
+  let lv2 = Array.length v2 in
+  if lv1 = lv2
+  then 
+    let rec fold n univ = 
+      if n >= lv1 then univ
+      else
+        let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
+        fold (n+1) u1 in
+    fold 0 cuniv
+  else raise NotConvertible
+
+
+
+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
+
+let conv = fconv CONV
+let conv_leq = fconv CUMUL
+
+let conv_leq_vecti env v1 v2 =
+  array_fold_left2_i 
+    (fun i c t1 t2 ->
+      let c' =
+        try conv_leq env t1 t2 
+        with NotConvertible -> raise (NotConvertibleVect i) in
+      Constraint.union c c')
+    Constraint.empty
+    v1
+    v2
+
+(*
+let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";;
+let conv_leq env t1 t2 =
+  Profile.profile4 convleqkey conv_leq env t1 t2;;
+
+let convkey = Profile.declare_profile "Kernel_reduction.conv";;
+let conv env t1 t2 =
+  Profile.profile4 convleqkey conv env t1 t2;;
+*)
+
+(********************************************************************)
+(*             Special-Purpose Reduction                            *)
+(********************************************************************)
+
+(* pseudo-reduction rule:
+ * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
+ * with an HNF on the first argument to produce a product.
+ * if this does not work, then we use the string S as part of our
+ * error message. *)
+
+let hnf_prod_app env t n =
+  match kind_of_term (whd_betadeltaiota env t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_prod_app: Need a product"
+
+let hnf_prod_applist env t nl = 
+  List.fold_left (hnf_prod_app env) t nl
+
+(* Dealing with arities *)
+
+let dest_prod env = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env c in
+    match kind_of_term t with
+      | Prod (n,a,c0) ->
+          let d = (n,None,a) in
+	  decrec (push_rel d env) (Sign.add_rel_decl d m) c0
+      | _ -> m,t
+  in 
+  decrec env Sign.empty_rel_context
+
+(* The same but preserving lets *)
+let dest_prod_assum env = 
+  let rec prodec_rec env l ty =
+    let rty = whd_betadeltaiota_nolet env ty in
+    match kind_of_term rty with
+    | Prod (x,t,c)  ->
+        let d = (x,None,t) in
+	prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c
+    | 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
+    | _               -> l,rty
+  in
+  prodec_rec env Sign.empty_rel_context
+
+let dest_arity env c =
+  let l, c = dest_prod env c in
+  match kind_of_term c with
+    | Sort s -> l,s
+    | _ -> error "not an arity"
+
+let is_arity env c =
+  try
+    let _ = dest_arity env c in
+    true
+  with UserError _ -> false
+
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
new file mode 100644
index 00000000..c516ea70
--- /dev/null
+++ b/kernel/reduction.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: reduction.mli,v 1.56.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Environ
+(*i*)
+
+(************************************************************************)
+(*s Reduction functions *)
+
+val whd_betaiotazeta        : env -> constr -> constr
+val whd_betadeltaiota       : env -> constr -> constr
+val whd_betadeltaiota_nolet : env -> constr -> constr
+
+val nf_betaiota      : constr -> constr
+
+(************************************************************************)
+(*s conversion functions *)
+
+exception NotConvertible
+exception NotConvertibleVect of int
+type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
+
+val conv_sort      : sorts conversion_function
+val conv_sort_leq  : sorts conversion_function
+
+val conv           : types conversion_function
+val conv_leq       : types conversion_function
+val conv_leq_vecti : types array conversion_function
+
+(************************************************************************)
+
+(* Builds an application node, reducing beta redexes it may produce. *) 
+val beta_appvect : constr -> constr array -> constr
+
+(* Pseudo-reduction rule  Prod(x,A,B) a --> B[x\a] *)
+val hnf_prod_applist : env -> types -> constr list -> types
+
+
+(************************************************************************)
+(*s Recognizing products and arities modulo reduction *)
+
+val dest_prod       : env -> types -> Sign.rel_context * types
+val dest_prod_assum : env -> types -> Sign.rel_context * types
+
+val dest_arity : env -> types -> Sign.arity
+val is_arity   : env -> types -> bool
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
new file mode 100644
index 00000000..4f180599
--- /dev/null
+++ b/kernel/safe_typing.ml
@@ -0,0 +1,572 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: safe_typing.ml,v 1.76.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Sign
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Typeops
+open Type_errors
+open Indtypes
+open Term_typing
+open Modops
+open Subtyping
+open Mod_typing
+
+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 = 
+    { msid : mod_self_id;
+      modpath : module_path;
+      seed : dir_path; (* the "seed" of unique identifier generator *)
+      label : label;
+      variant : modvariant}
+
+let check_label l labset = 
+  if Labset.mem l labset then error_existing_label l
+
+type library_info = dir_path * Digest.t
+
+type safe_environment = 
+    { old : safe_environment;
+      env : env;
+      modinfo : module_info;
+      labset : Labset.t;
+      revsign : module_signature_body;
+      revstruct : module_structure_body;
+      imports : library_info list;
+      loads : (module_path * module_body) list }
+
+(*
+  { old = senv.old;
+    env = ;
+    modinfo = senv.modinfo;
+    labset = ;
+    revsign = ;
+    imports = senv.imports ;
+    loads = senv.loads }
+*)
+
+
+(* a small hack to avoid variants and an unused case in all functions *)
+let rec empty_environment = 
+  { old = empty_environment; 
+    env = empty_env;
+    modinfo = {
+      msid = initial_msid;
+      modpath = initial_path;
+      seed = initial_dir;
+      label = mk_label "_";
+      variant = NONE};
+    labset = Labset.empty;
+    revsign = [];
+    revstruct = [];
+    imports = [];
+    loads = [] }
+
+let env_of_safe_env senv = senv.env
+let env_of_senv = env_of_safe_env
+
+
+(* Insertion of section variables. They are now typed before being
+   added to the environment. *)
+
+(* Same as push_named, but check that the variable is not already
+   there. Should *not* be done in Environ because tactics add temporary
+   hypothesis many many times, and the check performed here would
+   cost too much. *)
+let safe_push_named (id,_,_ as d) env =
+  let _ =
+    try
+      let _ = lookup_named id env in 
+      error ("identifier "^string_of_id id^" already defined")
+    with Not_found -> () in
+  Environ.push_named d env
+
+let push_named_def (id,b,topt) senv =
+  let (c,typ,cst) = translate_local_def senv.env (b,topt) in
+  let env' = add_constraints cst senv.env in
+  let env'' = safe_push_named (id,Some c,typ) env' in
+  (cst, {senv with env=env''})
+
+let push_named_assum (id,t) senv =
+  let (t,cst) = translate_local_assum senv.env t in
+  let env' = add_constraints cst senv.env in
+  let env'' = safe_push_named (id,None,t) env' in
+  (cst, {senv with env=env''})
+
+
+(* Insertion of constants and parameters in environment. *)
+
+type global_declaration = 
+  | ConstantEntry of constant_entry
+  | GlobalRecipe of Cooking.recipe
+
+let hcons_constant_body cb =
+  let body = match cb.const_body with
+      None -> None
+    | Some l_constr -> let constr = Declarations.force l_constr in
+	Some (Declarations.from_val (hcons1_constr constr))
+  in
+    { cb with
+	const_body = body;
+	const_type = hcons1_constr 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
+  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 }
+    
+
+(* Insertion of inductive types. *)
+
+let add_mind dir l mie senv =
+  if mie.mind_entry_inds = [] then 
+    anomaly "empty inductive types declaration"; 
+            (* this test is repeated by translate_mind *)
+  let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in
+  if l <> label_of_id id then
+    anomaly ("the label of inductive packet and its first inductive"^
+	     " type do not match");
+  check_label l senv.labset; 
+    (* TODO: when we will allow reorderings we will have to verify 
+       all labels *)
+  let mib = translate_mind senv.env mie in
+  let env' = Environ.add_constraints mib.mind_constraints senv.env in
+  let kn = make_kn senv.modinfo.modpath dir l in
+  let env'' = Environ.add_mind kn mib env' in
+  kn, { old = senv.old;
+	env = env'';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;  (* TODO: the same as above *)
+	revsign = (l,SPBmind mib)::senv.revsign;
+	revstruct = (l,SEBmind mib)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+(* Insertion of module types *)
+
+let add_modtype l mte senv = 
+  check_label l senv.labset; 
+  let mtb = translate_modtype senv.env mte in
+  let env' = add_modtype_constraints senv.env mtb in
+  let kn = make_kn senv.modinfo.modpath empty_dirpath l in
+  let env'' = Environ.add_modtype kn mtb env' in
+  kn, { old = senv.old;
+	env = env'';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;
+	revsign = (l,SPBmodtype mtb)::senv.revsign;
+	revstruct = (l,SEBmodtype mtb)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+
+(* full_add_module adds module with universes and constraints *)
+let full_add_module mp mb env =
+  let env = add_module_constraints env mb in
+  let env = Modops.add_module mp mb env in
+    env
+
+(* Insertion of modules *)
+
+let add_module l me senv = 
+  check_label l senv.labset; 
+  let mb = translate_module senv.env me in
+  let mspec = module_spec_of_body mb in
+  let mp = MPdot(senv.modinfo.modpath, l) in
+  let env' = full_add_module mp mb senv.env in
+  mp, { old = senv.old;
+	env = env';
+	modinfo = senv.modinfo;
+	labset = Labset.add l senv.labset;
+	revsign = (l,SPBmodule mspec)::senv.revsign;
+	revstruct = (l,SEBmodule mb)::senv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads }
+
+
+(* Interactive modules *)
+
+let start_module l params result 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) }
+  in
+  mp, { old = senv;
+	env = env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+
+
+let end_module l senv = 
+  let oldsenv = senv.old in
+  let modinfo = senv.modinfo in
+  let params, restype = 
+    match modinfo.variant with
+      | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
+      | STRUCT(params,restype) -> (params,restype)
+  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))
+      params
+  in
+  let auto_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in
+  let mtb, mod_user_type, cst = 
+    match restype with
+      | None -> functorize_type auto_tb, None, Constraint.empty
+      | Some res_tb -> 
+	  let cst = check_subtypes senv.env auto_tb res_tb in
+	  let mtb = functorize_type res_tb in
+	    mtb, Some mtb, cst
+  in
+  let mexpr = 
+    List.fold_right
+      (fun (arg_id,arg_b) mtb -> MEBfunctor (arg_id,arg_b,mtb))
+      params
+      (MEBstruct (modinfo.msid, List.rev senv.revstruct)) 
+  in
+  let mb = 
+    { mod_expr = Some mexpr;
+      mod_user_type = mod_user_type;
+      mod_type = mtb;
+      mod_equiv = None;
+      mod_constraints = cst }
+  in
+  let mspec = 
+    { msb_modtype = mtb;
+      msb_equiv = None;
+      msb_constraints = Constraint.empty } 
+  in
+  let mp = MPdot (oldsenv.modinfo.modpath, l) in
+  let newenv = oldsenv.env in
+  let newenv = 
+    List.fold_left
+      (fun env (mp,mb) -> full_add_module mp mb env) 
+      newenv
+      senv.loads
+  in
+  let newenv = 
+    full_add_module mp mb newenv
+  in 
+  mp, { old = oldsenv.old;
+	env = newenv;
+	modinfo = oldsenv.modinfo;
+	labset = Labset.add l oldsenv.labset;
+	revsign = (l,SPBmodule mspec)::oldsenv.revsign;
+	revstruct = (l,SEBmodule mb)::oldsenv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads@oldsenv.loads }
+
+
+(* Interactive module types *)
+
+let start_modtype l params 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 }
+  in
+  mp, { old = senv;
+	env = env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+let end_modtype l senv = 
+  let oldsenv = senv.old in
+  let modinfo = senv.modinfo in
+  let params = 
+    match modinfo.variant with
+      | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end ()
+      | SIG 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 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
+      res_tb
+  in
+  let kn = make_kn oldsenv.modinfo.modpath empty_dirpath l in
+  let newenv = oldsenv.env in
+  let newenv = 
+    List.fold_left
+      (fun env (mp,mb) -> full_add_module mp mb env) 
+      newenv
+      senv.loads
+  in
+  let newenv = 
+    add_modtype_constraints newenv mtb 
+  in
+  let newenv = 
+    Environ.add_modtype kn mtb newenv
+  in 
+  kn, { old = oldsenv.old;
+	env = newenv;
+	modinfo = oldsenv.modinfo;
+	labset = Labset.add l oldsenv.labset;
+	revsign = (l,SPBmodtype mtb)::oldsenv.revsign;
+	revstruct = (l,SEBmodtype mtb)::oldsenv.revstruct;
+	imports = senv.imports;
+	loads = senv.loads@oldsenv.loads }
+  
+
+let current_modpath senv = senv.modinfo.modpath
+let current_msid senv = senv.modinfo.msid
+
+
+let add_constraints cst senv = 
+  {senv with env = Environ.add_constraints cst senv.env}
+
+(* Check that the engagement expected by a library matches the initial one *)
+let check_engagement env c =
+  match Environ.engagement env, c with
+    | Some ImpredicativeSet, Some ImpredicativeSet -> ()
+    | _, None -> ()
+    | _, Some ImpredicativeSet ->
+        error "Needs option -impredicative-set"
+
+let set_engagement c senv =
+  {senv with env = Environ.set_engagement c senv.env}
+
+
+(* Libraries = Compiled modules *)
+
+type compiled_library = 
+    dir_path * module_body * library_info list * engagement option
+
+
+(* We check that only initial state Require's were performed before 
+   [start_library] was called *)
+
+let start_library dir senv =
+  if not (senv.revsign = [] &&
+	  senv.modinfo.msid = initial_msid &&
+	  senv.modinfo.variant = NONE)
+  then
+    anomaly "Safe_typing.start_library: environment should be empty";
+  let dir_path,l = 
+    match (repr_dirpath dir) with
+	[] -> anomaly "Empty dirpath in Safe_typing.start_library"
+      | hd::tl ->
+	  make_dirpath tl, label_of_id hd
+  in
+  let msid = make_msid dir_path (string_of_label l) in
+  let mp = MPself msid in
+  let modinfo = { msid = msid;
+		  modpath = mp;
+		  seed = dir;
+		  label = l;
+		  variant = LIBRARY dir }
+  in
+  mp, { old = senv;
+	env = senv.env;
+	modinfo = modinfo;
+	labset = Labset.empty;
+	revsign = [];
+	revstruct = [];
+	imports = senv.imports;
+	loads = [] }
+
+
+let export senv dir = 
+  let modinfo = senv.modinfo in
+  begin
+    match modinfo.variant with
+      | LIBRARY dp -> 
+	  if dir <> dp then
+	    anomaly "We are not exporting the right library!"
+      | _ ->
+	  anomaly "We are not exporting the library"
+  end;
+  (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
+    (* error_export_simple *) (); *)
+  let mb = 
+    { mod_expr = Some (MEBstruct (modinfo.msid, List.rev senv.revstruct));
+      mod_type = MTBsig (modinfo.msid, List.rev senv.revsign);
+      mod_user_type = None;
+      mod_equiv = None;
+      mod_constraints = Constraint.empty }
+  in
+    modinfo.msid, (dir,mb,senv.imports,engagement senv.env)
+
+
+let check_imports senv needed =
+  let imports = senv.imports in
+  let check (id,stamp) =
+    try
+      let actual_stamp = List.assoc id imports in
+      if stamp <> actual_stamp then
+	error ("Inconsistent assumptions over module " ^(string_of_dirpath id))
+    with Not_found -> 
+      error ("Reference to unknown module " ^ (string_of_dirpath id))
+  in
+  List.iter check needed
+
+(* we have an inefficiency: Since loaded files are added to the
+environment every time a module is closed, their components are
+calculated many times. Thic could be avoided in several ways:
+
+1 - for each file create a dummy environment containing only this
+file's components, merge this environment with the global
+environment, and store for the future (instead of just its type)
+
+2 - create "persistent modules" environment table in Environ add put
+loaded by side-effect once and for all (like it is done in OCaml).
+Would this be correct with respect to undo's and stuff ?
+*)
+ 
+let import (dp,mb,depends,engmt) digest senv = 
+  check_imports senv depends;
+  check_engagement senv.env engmt;
+  let mp = MPfile dp in
+  let env = senv.env in
+  mp, { senv with 
+	  env = full_add_module mp mb env; 
+	  imports = (dp,digest)::senv.imports;
+	  loads = (mp,mb)::senv.loads }
+
+
+(** 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_type = lighten_modtype mb.mod_type;
+    mod_user_type = option_app lighten_modtype mb.mod_user_type }
+
+and lighten_modtype = function
+  | MTBident kn as x -> x
+  | MTBfunsig (mbid,mtb1,mtb2) ->
+      MTBfunsig (mbid, lighten_modtype mtb1, lighten_modtype mtb2)
+  | MTBsig (msid,sign) -> MTBsig (msid, lighten_sig sign)
+
+and lighten_modspec ms =
+  { ms with msb_modtype = lighten_modtype ms.msb_modtype }
+
+and lighten_sig sign = 
+  let lighten_spec (l,spec) = (l,match spec with
+    | SPBconst ({const_opaque=true} as x) -> SPBconst {x with const_body=None}
+    | (SPBconst _ | SPBmind _) as x -> x
+    | SPBmodule m -> SPBmodule (lighten_modspec m)
+    | SPBmodtype m -> SPBmodtype (lighten_modtype m))
+  in
+    List.map lighten_spec sign
+
+and lighten_struct struc = 
+  let lighten_body (l,body) = (l,match body with
+    | SEBconst ({const_opaque=true} as x) -> SEBconst {x with const_body=None}
+    | (SEBconst _ | SEBmind _) as x -> x
+    | SEBmodule m -> SEBmodule (lighten_module m)
+    | SEBmodtype m -> SEBmodtype (lighten_modtype m))
+  in
+    List.map lighten_body struc
+
+and lighten_modexpr = function
+  | MEBfunctor (mbid,mty,mexpr) ->
+      MEBfunctor (mbid,lighten_modtype mty,lighten_modexpr mexpr)
+  | MEBident mp as x -> x
+  | MEBstruct (msid, struc) ->
+      MEBstruct (msid, lighten_struct struc)
+  | MEBapply (mexpr,marg,u) ->
+      MEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
+
+let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
+
+
+type judgment = unsafe_judgment
+
+let j_val j = j.uj_val
+let j_type j = j.uj_type
+
+let safe_infer senv = infer (env_of_senv senv)
+    
+let typing senv = Typeops.typing (env_of_senv senv)
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
new file mode 100644
index 00000000..84b98984
--- /dev/null
+++ b/kernel/safe_typing.mli
@@ -0,0 +1,127 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: safe_typing.mli,v 1.33.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Entries
+(*i*)
+
+(*s Safe environments. Since we are now able to type terms, we can
+  define an abstract type of safe environments, where objects are
+  typed before being added.
+
+  We also add [open_structure] and [close_section], [close_module] to
+  provide functionnality for sections and interactive modules 
+*)
+
+type safe_environment
+
+val env_of_safe_env : safe_environment -> Environ.env
+
+val empty_environment : safe_environment
+
+(* Adding and removing local declarations (Local or Variables) *)
+val push_named_assum :
+  identifier * types -> safe_environment ->
+    Univ.constraints * safe_environment
+val push_named_def :
+  identifier * constr * types option -> safe_environment ->
+    Univ.constraints * safe_environment
+
+(* Adding global axioms or definitions *)
+type global_declaration = 
+  | ConstantEntry of constant_entry
+  | GlobalRecipe of Cooking.recipe
+
+val add_constant : 
+  dir_path -> label -> global_declaration -> safe_environment -> 
+      kernel_name * safe_environment
+
+(* Adding an inductive type *)
+val add_mind : 
+  dir_path -> label -> mutual_inductive_entry -> safe_environment ->
+    mutual_inductive * safe_environment
+
+(* Adding a module *)
+val add_module :
+  label -> module_entry -> safe_environment 
+    -> module_path * safe_environment
+
+(* Adding a module type *)
+val add_modtype :
+  label -> module_type_entry -> safe_environment 
+    -> kernel_name * safe_environment
+
+(* Adding universe constraints *)
+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
+
+
+(*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
+
+val end_module :
+  label -> safe_environment -> module_path * safe_environment 
+
+
+val start_modtype :
+  label -> (mod_bound_id * module_type_entry) list
+    -> safe_environment -> module_path * safe_environment
+
+val end_modtype :
+  label -> safe_environment -> kernel_name * safe_environment
+
+
+val current_modpath : safe_environment -> module_path
+val current_msid : safe_environment -> mod_self_id
+
+
+(* Loading and saving compilation units *)
+
+(* exporting and importing modules *)
+type compiled_library
+
+val start_library : dir_path -> safe_environment 
+      -> module_path * safe_environment
+
+val export : safe_environment -> dir_path  
+      -> mod_self_id * compiled_library
+
+val import : compiled_library -> Digest.t -> safe_environment 
+      -> module_path * safe_environment
+
+(* Remove the body of opaque constants *)
+
+val lighten_library : compiled_library -> compiled_library
+
+(*s Typing judgments *)
+
+type judgment
+
+val j_val : judgment -> constr
+val j_type : judgment -> constr
+
+(* Safe typing of a term returning a typing judgment and universe
+   constraints to be added to the environment for the judgment to
+   hold. It is guaranteed that the constraints are satisfiable
+ *)
+val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
+
+val typing : safe_environment -> constr -> judgment
+
+
diff --git a/kernel/sign.ml b/kernel/sign.ml
new file mode 100644
index 00000000..a4b2a2ea
--- /dev/null
+++ b/kernel/sign.ml
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: sign.ml,v 1.37.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+open Names
+open Util
+open Term
+
+(*s Signatures of named hypotheses. Used for section variables and
+    goal assumptions. *)
+
+type named_context = named_declaration list
+
+let empty_named_context = []
+
+let add_named_decl d sign = d::sign
+
+let rec lookup_named id = function
+  | (id',_,_ as decl) :: _ when id=id' -> decl
+  | _ :: sign -> lookup_named id sign
+  | [] -> raise Not_found
+
+let named_context_length = List.length
+
+let vars_of_named_context = List.map (fun (id,_,_) -> id)
+
+let instance_from_named_context sign =
+  let rec inst_rec = function
+    | (id,None,_) :: sign -> mkVar id :: inst_rec sign
+    | _ :: sign -> inst_rec sign
+    | [] -> [] in
+  Array.of_list (inst_rec sign)
+
+let fold_named_context f l ~init = List.fold_right f l init
+let fold_named_context_reverse f ~init l = List.fold_left f init l
+
+(*s Signatures of ordered section variables *)
+type section_context = named_context
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices (to represent bound variables) *)
+
+type rel_declaration = name * constr option * types
+type rel_context = rel_declaration list
+
+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 rel_context_length = List.length
+
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 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_decl (n, body_o, typ as decl) =
+    let body_o' = option_smartmap f body_o in
+    let typ' = f typ in
+      if body_o' == body_o && typ' == typ then decl else
+	(n, body_o', typ')
+  in
+    list_smartmap map_decl l
+
+(* 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
+	id::s, d::hyps
+    | [] -> [],[] in
+  let s, hyps = push hyps in
+  let rec subst = function
+    | d :: l ->
+	let n, ctxt = subst l in
+	(n+1), (map_rel_declaration (substn_vars n s) d)::ctxt
+    | [] -> 1, hyps in
+  snd (subst ctxt)
+
+
+(*********************************)
+(*       Term constructors       *)
+(*********************************)
+
+let it_mkProd_or_LetIn   = List.fold_left (fun c d -> mkProd_or_LetIn d c)
+let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
+
+(*********************************)
+(*       Term destructors        *)
+(*********************************)
+
+type arity = rel_context * sorts
+
+(* Decompose an arity (i.e. a product of the form (x1:T1)..(xn:Tn)s
+   with s a sort) into the pair ([(xn,Tn);...;(x1,T1)],s) *)
+
+let destArity = 
+  let rec prodec_rec l c =
+    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
+    | Sort s          -> l,s
+    | _               -> anomaly "destArity: not an arity"
+  in 
+  prodec_rec []
+
+let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign
+
+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
+  | Sort _          -> true
+  | _               -> false
+
+(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
+let decompose_prod_assum = 
+  let rec prodec_rec l c =
+    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
+    | _               -> l,c
+  in 
+  prodec_rec empty_rel_context
+
+(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
+let decompose_lam_assum = 
+  let rec lamdec_rec l c =
+    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
+    | _               -> l,c
+  in 
+  lamdec_rec empty_rel_context
+
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_prod_n_assum n =
+  if n < 0 then
+    error "decompose_prod_n_assum: integer parameter must be positive";
+  let rec prodec_rec l n c = 
+    if n=0 then l,c
+    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
+    | c -> error "decompose_prod_n_assum: not enough assumptions"
+  in 
+  prodec_rec empty_rel_context n
+
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_lam_n_assum n =
+  if n < 0 then
+    error "decompose_lam_n_assum: integer parameter must be positive";
+  let rec lamdec_rec l n c = 
+    if n=0 then l,c 
+    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
+    | 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
new file mode 100644
index 00000000..3f0549cc
--- /dev/null
+++ b/kernel/sign.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: sign.mli,v 1.40.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+(*i*)
+
+(*s Signatures of ordered named declarations *)
+
+type named_context = named_declaration list
+type section_context = named_context
+
+val empty_named_context : named_context
+val add_named_decl : named_declaration -> named_context -> named_context
+val vars_of_named_context : named_context -> identifier list
+
+val lookup_named : identifier -> named_context -> named_declaration
+
+(* number of declarations *)
+val named_context_length : named_context -> int
+
+(*s Recurrence on [named_context]: older declarations processed first *)
+val fold_named_context :
+  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
+(* newer declarations first *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
+
+(*s Section-related auxiliary functions *)
+val instance_from_named_context : named_context -> constr array
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices *)
+
+(* In [rel_context], more recent declaration is on top *)
+type rel_context = rel_declaration list
+
+val empty_rel_context : rel_context
+val add_rel_decl : rel_declaration -> rel_context -> rel_context
+
+val lookup_rel : int -> rel_context -> rel_declaration
+val rel_context_length : rel_context -> int
+val rel_context_nhyps : rel_context -> int
+
+val push_named_to_rel_context : named_context -> rel_context -> rel_context
+
+(*s Recurrence on [rel_context]: older declarations processed first *)
+val fold_rel_context :
+  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
+(* newer declarations first *)
+val fold_rel_context_reverse :
+  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
+
+(*s Map function of [rel_context] *)
+val map_rel_context : (constr -> constr) -> rel_context -> rel_context
+
+(*s Term constructors *)
+
+val it_mkLambda_or_LetIn : constr -> rel_context -> constr
+val it_mkProd_or_LetIn : types -> rel_context -> types
+
+(*s Term destructors *)
+
+(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *)
+type arity = rel_context * sorts
+val destArity : types -> arity
+val mkArity : arity -> types
+val isArity : types -> bool
+
+(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ including letins
+   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
+   product nor a let. *)
+val decompose_prod_assum : types -> rel_context * types
+
+(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ including letins
+   into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a
+   lambda nor a let. *)
+val decompose_lam_assum : constr -> rel_context * constr
+
+(* Given a positive integer n, transforms a product term 
+   $(x_1:T_1)..(x_n:T_n)T$
+   into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
+val decompose_prod_n_assum : int -> types -> rel_context * types
+
+(* Given a positive integer $n$, transforms a lambda term 
+   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+val decompose_lam_n_assum : int -> constr -> rel_context * constr
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
new file mode 100644
index 00000000..825ae8fa
--- /dev/null
+++ b/kernel/subtyping.ml
@@ -0,0 +1,246 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: subtyping.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Environ
+open Reduction
+open Inductive
+open Modops
+(*i*)
+
+(* This local type is used to subtype a constant with a constructor or
+   an inductive type. It can also be useful to allow reorderings in
+   inductive types *)
+
+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
+  | Modtype of module_type_body
+
+(* adds above information about one mutual inductive: all types and
+   constructors *)
+
+let add_nameobjects_of_mib ln mib map = 
+  let add_nameobjects_of_one j oib 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
+    in
+      Idmap.add 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 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
+  in
+    List.fold_right add_one list Labmap.empty
+
+let check_conv_error error cst f env a1 a2 =
+  try
+    Constraint.union cst (f env a1 a2)
+  with
+      NotConvertible -> error ()
+
+(* for now we do not allow reorderings *)
+let check_inductive cst env msid1 l info1 mib2 spec2 = 
+  let kn = make_kn (MPself msid1) empty_dirpath l in
+  let error () = error_not_match l spec2 in
+  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*)
+      | _ -> error ()
+  in
+  let check_packet cst p1 p2 =
+    let check f = if f p1 <> f p2 then error () in
+      check (fun p -> p.mind_consnames);
+      check (fun p -> p.mind_typename);
+      (* nf_lc later *)
+      (* 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
+	cst
+  in
+  let check_cons_types i cst p1 p2 =
+    array_fold_left2 
+      (fun cst t1 t2 -> check_conv cst conv env t1 t2)
+      cst
+      (arities_of_specif kn (mib1,p1))
+      (arities_of_specif kn (mib2,p2))
+  in
+  let check f = if f mib1 <> f mib2 then error () in
+  check (fun mib -> mib.mind_finite);
+  check (fun mib -> mib.mind_ntypes);
+  assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
+  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); 
+
+  begin 
+    match mib2.mind_equiv with
+      | None -> ()
+      | Some kn2' -> 
+	  let kn2 = scrape_mind env kn2' in
+	  let kn1 = match mib1.mind_equiv with
+	      None -> kn
+	    | Some kn1' -> scrape_mind env kn1'
+	  in
+	    if kn1 <> kn2 then error ()
+  end;
+  (* we first check simple things *)
+  let cst = 
+    array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
+  in
+  (* and constructor types in the end *)
+  let cst = 
+    array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
+  in
+    cst
+    
+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 rec check_modules cst env msid1 l msb1 msb2 =
+  let mp = (MPdot(MPself msid1,l)) in
+  let mty1 = strengthen env msb1.msb_modtype mp in
+  let cst = check_modtypes cst env mty1 msb2.msb_modtype false in
+  begin
+    match msb1.msb_equiv, msb2.msb_equiv with
+      | _, None -> ()
+      | None, Some mp2 -> 
+	  check_modpath_equiv env mp mp2
+      | Some mp1, Some mp2 ->
+	  check_modpath_equiv env mp1 mp2
+  end;
+  cst
+	
+
+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 check_one_body cst (l,spec2) = 
+    let info1 = 
+      try 
+	Labmap.find l map1 
+      with 
+	  Not_found -> error_no_such_label l 
+    in
+      match spec2 with
+	| SPBconst cb2 ->
+	    check_constant cst env msid1 l info1 cb2 spec2
+	| SPBmind mib2 -> 
+	    check_inductive cst env msid1 l info1 mib2 spec2
+	| SPBmodule msb2 -> 
+	    let msb1 = 
+	      match info1 with
+		| Module msb -> msb
+		| _ -> error_not_match l spec2
+	    in
+	      check_modules cst env msid1 l msb1 msb2
+	| SPBmodtype mtb2 ->
+	    let mtb1 = 
+	      match info1 with
+		| Modtype mtb -> mtb
+		| _ -> error_not_match l spec2
+	    in
+	      check_modtypes cst env mtb1 mtb2 true
+  in
+    List.fold_left check_one_body cst sig2
+    
+and check_modtypes cst env mtb1 mtb2 equiv = 
+  if mtb1==mtb2 then (); (* just in case  :) *)
+  let mtb1' = scrape_modtype env mtb1 in
+  let mtb2' = scrape_modtype env mtb2 in
+    if mtb1'==mtb2' then ();
+    match mtb1', mtb2' with
+      | MTBsig (msid1,list1), 
+	MTBsig (msid2,list2) -> 
+	  let cst = check_signatures cst env (msid1,list1) (msid2,list2) in
+	  if equiv then
+	    check_signatures cst env (msid2,list2) (msid1,list1) 
+	  else
+	    cst
+      | MTBfunsig (arg_id1,arg_t1,body_t1), 
+	MTBfunsig (arg_id2,arg_t2,body_t2) ->
+	  let cst = check_modtypes cst env arg_t2 arg_t1 equiv in 
+	    (* contravariant *)
+	  let env' = 
+	    add_module (MPbound arg_id2) (module_body_of_type arg_t2) env 
+	  in
+	  let body_t1' = 
+	    subst_modtype 
+	      (map_mbid arg_id1 (MPbound arg_id2)) 
+	      body_t1
+	  in
+	  check_modtypes cst env' body_t1' body_t2 equiv
+      | MTBident _ , _ -> anomaly "Subtyping: scrape failed"
+      | _ , MTBident _ -> anomaly "Subtyping: scrape failed"
+      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+	  
+let check_subtypes env sup super = 
+  check_modtypes Constraint.empty env sup super false
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
new file mode 100644
index 00000000..af09dafc
--- /dev/null
+++ b/kernel/subtyping.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: subtyping.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Univ
+open Declarations
+open Environ
+(*i*)
+
+val check_subtypes : env -> module_type_body -> module_type_body -> constraints
+
+
diff --git a/kernel/term.ml b/kernel/term.ml
new file mode 100644
index 00000000..30e73e4f
--- /dev/null
+++ b/kernel/term.ml
@@ -0,0 +1,1186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: term.ml,v 1.95.2.1 2004/07/16 19:30:26 herbelin Exp $ *)
+
+(* This module instanciates the structure of generic deBruijn terms to Coq *)
+
+open Util
+open Pp
+open Names
+open Univ
+open Esubst
+
+(* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *)
+
+type existential_key = int
+type metavariable = int
+
+(* This defines Cases annotations *)
+type pattern_source = DefaultPat of int | RegularPat
+type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_nargs : int; (* number of real args of the inductive type *)
+    style     : case_style;
+    source    : pattern_source array }
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  }
+
+(* Sorts. *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents                      (* proposition types *)
+  | Type of universe
+      
+let mk_Set  = Prop Pos
+let mk_Prop = Prop Null
+
+type sorts_family = InProp | InSet | InType
+
+let family_of_sort = function
+  | Prop Null -> InProp
+  | Prop Pos -> InSet
+  | Type _ -> InType
+
+(********************************************************************)
+(*       Constructions as implemented                               *)
+(********************************************************************)
+
+(* [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
+type ('constr, 'types) prec_declaration =
+    name array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+(* [Var] is used for named variables and [Rel] for variables as
+   de Bruijn indices. *)
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of identifier
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of sorts
+  | Cast      of 'constr * 'types
+  | Prod      of name * 'types * 'types
+  | Lambda    of name * 'types * 'constr
+  | LetIn     of name * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant
+  | Ind       of inductive
+  | Construct of constructor
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+
+(* Experimental *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | 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)
+  | Prod (na,t,c) -> ProdType (na, t, c)
+  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+  | App (c,l) -> AtomicType (c, l)
+  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
+    -> AtomicType (c,[||])
+  | (Lambda _ | Construct _) -> failwith "Not a type"
+
+(* constr is the fixpoint of the previous type. Requires option
+   -rectypes of the Caml compiler to be set *)
+type constr = (constr,constr) kind_of_term
+
+type existential = existential_key * constr array
+type rec_declaration = name array * constr array * constr array
+type fixpoint = (int array * int) * rec_declaration
+type cofixpoint = int * rec_declaration
+
+(***************************)
+(* hash-consing functions  *)                         
+(***************************)
+
+let comp_term t1 t2 =
+  match t1, t2 with
+  | Rel n1, Rel n2 -> n1 = n2
+  | 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
+  | 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) ->
+      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
+  | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2
+  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2
+  | Const c1, Const c2 -> c1 == c2
+  | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
+  | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
+      sp1 == sp2 & i1 = i2 & j1 = j2
+  | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+      ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2
+  | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_for_all2 (==) lna1 lna2
+      & array_for_all2 (==) tl1 tl2
+      & array_for_all2 (==) bl1 bl2
+  | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      ln1 = ln2
+      & array_for_all2 (==) lna1 lna2
+      & array_for_all2 (==) tl1 tl2
+      & array_for_all2 (==) bl1 bl2
+  | _ -> false
+
+let hash_term (sh_rec,(sh_sort,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)
+  | 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)
+  | 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 *)
+      Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      Fix (ln,(Array.map sh_na lna,
+                 Array.map sh_rec tl,
+                 Array.map sh_rec bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      CoFix (ln,(Array.map sh_na lna,
+                   Array.map sh_rec tl,
+                   Array.map sh_rec bl))
+
+module Hconstr =
+  Hashcons.Make(
+    struct
+      type t = constr
+      type u = (constr -> constr) *
+               ((sorts -> sorts) * (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)
+
+(* Constructs a DeBrujin index with number n *)
+let rels =
+  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
+    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
+
+let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
+
+(* Construct a type *)
+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) =
+  match t1 with
+    | Cast (t,_) -> Cast (t,t2)
+    | _ -> Cast (t1,t2)
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd (x,t1,t2) = Prod (x,t1,t2)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* 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
+    match f with
+      | App (g, cl) -> App (g, Array.append cl a)
+      | _ -> App (f, a)
+
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+let mkConst c = Const c
+
+(* Constructs an existential variable *)
+let mkEvar e = Evar e
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+let mkInd m = Ind m
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+let mkConstruct c = Construct c
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
+
+let mkFix fix = Fix fix
+
+let mkCoFix cofix = CoFix cofix
+
+let kind_of_term c = c
+
+(************************************************************************)
+(*    kind_of_term = constructions as seen by the user                 *)
+(************************************************************************)
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+let kind_of_term = kind_of_term
+
+
+(* En vue d'un kind_of_type : constr -> hnftype ??? *)
+type hnftype =
+  | HnfSort   of sorts
+  | HnfProd   of name * constr * constr
+  | HnfAtom   of constr
+  | HnfInd of inductive * constr array
+
+(**********************************************************************)
+(*          Non primitive term destructors                            *)
+(**********************************************************************)
+
+(* Destructor operations : partial functions 
+   Raise invalid_arg "dest*" if the const has not the expected form *)
+
+(* Destructs a DeBrujin index *)
+let destRel c = match kind_of_term c with
+  | Rel n -> n
+  | _ -> invalid_arg "destRel"
+
+(* Destructs an existential variable *)
+let destMeta c = match kind_of_term c with
+  | Meta n -> n
+  | _ -> invalid_arg "destMeta"
+
+let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
+
+(* Destructs a variable *)
+let destVar c = match kind_of_term c with
+  | Var id -> id
+  | _ -> invalid_arg "destVar"
+
+(* Destructs a type *)
+let isSort c = match kind_of_term c with
+  | Sort s -> true
+  | _ -> false
+
+let destSort c = match kind_of_term c with
+  | Sort s -> s
+  | _ -> invalid_arg "destSort"
+
+let rec isprop c = match kind_of_term c with
+  | Sort (Prop _) -> true
+  | 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
+  | _ -> false
+
+let rec is_Set c = match kind_of_term c with
+  | Sort (Prop Pos) -> true
+  | 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
+  | _ -> false
+
+let isType = function
+  | Type _ -> true
+  | _ -> false
+
+let is_small = function
+  | Prop _ -> true
+  | _ -> false
+
+let iskind c = isprop c or is_Type c
+
+let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2)
+
+(* Tests if an evar *)
+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)
+  | _ -> invalid_arg "destCast"
+
+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
+
+(* Tests if a variable *)
+let isVar c = match kind_of_term c with Var _ -> true | _ -> false
+
+(* Tests if an inductive *)
+let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
+
+(* Destructs the product (x:t1)t2 *)
+let destProd c = match kind_of_term c with 
+  | Prod (x,t1,t2) -> (x,t1,t2) 
+  | _ -> invalid_arg "destProd"
+
+(* Destructs the abstraction [x:t1]t2 *)
+let destLambda c = match kind_of_term c with 
+  | Lambda (x,t1,t2) -> (x,t1,t2) 
+  | _ -> invalid_arg "destLambda"
+
+(* Destructs the let [x:=b:t1]t2 *)
+let destLetIn c = match kind_of_term c with 
+  | LetIn (x,b,t1,t2) -> (x,b,t1,t2) 
+  | _ -> invalid_arg "destProd"
+
+(* Destructs an application *)
+let destApplication c = match kind_of_term c with
+  | App (f,a) -> (f, a)
+  | _ -> invalid_arg "destApplication"
+
+let isApp c = match kind_of_term c with App _ -> true | _ -> false
+
+(* Destructs a constant *)
+let destConst c = match kind_of_term c with
+  | Const kn -> kn
+  | _ -> invalid_arg "destConst"
+
+let isConst c = match kind_of_term c with Const _ -> true | _ -> false
+
+(* Destructs an existential variable *)
+let destEvar c = match kind_of_term c with
+  | Evar (kn, a as r) -> r
+  | _ -> invalid_arg "destEvar"
+
+let num_of_evar c = match kind_of_term c with
+  | Evar (n, _) -> n
+  | _ -> anomaly "num_of_evar called with bad args"
+
+(* Destructs a (co)inductive type named kn *)
+let destInd c = match kind_of_term c with
+  | Ind (kn, a as r) -> r
+  | _ -> invalid_arg "destInd"
+
+(* Destructs a constructor *)
+let destConstruct c = match kind_of_term c with
+  | Construct (kn, a as r) -> r
+  | _ -> invalid_arg "dest"
+
+let isConstruct c = match kind_of_term c with
+    Construct _ -> true | _ -> false
+
+(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+let destCase c = match kind_of_term c with
+  | Case (ci,p,c,v) -> (ci,p,c,v)
+  | _ -> anomaly "destCase"
+
+let destFix c = match kind_of_term c with 
+  | Fix fix -> fix
+  | _ -> invalid_arg "destFix"
+	
+let destCoFix c = match kind_of_term c with 
+  | CoFix cofix -> cofix
+  | _ -> invalid_arg "destCoFix"
+
+(******************************************************************)
+(* Flattening and unflattening of embedded applications and casts *)
+(******************************************************************)
+
+(* flattens application lists *)
+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
+	| 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 
+      collapse_rec f cl
+  | _ -> c
+
+let rec decompose_app c =
+  match kind_of_term (collapse_appl c) with
+    | App (f,cl) -> (f, Array.to_list cl)
+    | Cast (c,t) -> decompose_app c
+    | _ -> (c,[])
+
+(* strips head casts and flattens head applications *)
+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)
+      in 
+      collapse_rec f cl
+  | Cast (c,t) -> strip_head_cast c
+  | _ -> c
+
+(****************************************************************************)
+(*              Functions to recur through subterms                         *)
+(****************************************************************************)
+
+(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+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
+  | 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) -> Array.fold_left f acc l
+  | 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
+
+(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+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
+  | Prod (_,t,c) -> f t; f c
+  | Lambda (_,t,c) -> f t; f c
+  | LetIn (_,b,t,c) -> f b; f t; f c
+  | App (c,l) -> f c; Array.iter f l
+  | Evar (_,l) -> Array.iter f l
+  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
+  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+
+(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+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
+  | 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
+  | App (c,l) -> f n c; Array.iter (f n) l
+  | Evar (_,l) -> Array.iter (f n) l
+  | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
+  | Fix (_,(_,tl,bl)) -> 
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+  | CoFix (_,(_,tl,bl)) ->
+      Array.iter (f n) tl;
+      Array.iter (f (iterate g (Array.length tl) n)) bl
+
+(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+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)
+  | 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)
+  | App (c,l) -> mkApp (f c, Array.map f l)
+  | Evar (e,l) -> mkEvar (e, Array.map f l)
+  | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      mkFix (ln,(lna,Array.map f tl,Array.map f bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      mkCoFix (ln,(lna,Array.map f tl,Array.map f bl))
+
+(* [map_constr_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+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)
+  | 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)
+  | App (c,al) -> mkApp (f l c, Array.map (f l) al)
+  | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
+  | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      let l' = iterate g (Array.length tl) l in
+      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let l' = iterate g (Array.length tl) l in
+      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_constr f t1 t2 =
+  match kind_of_term t1, kind_of_term t2 with
+  | Rel n1, Rel n2 -> n1 = n2
+  | 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
+  | 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
+  | App (c1,l1), App (c2,l2) ->
+      if Array.length l1 = Array.length l2 then
+        f c1 c2 & array_for_all2 f l1 l2
+      else
+        let (h1,l1) = decompose_app t1 in        
+        let (h2,l2) = decompose_app t2 in
+        if List.length l1 = List.length l2 then
+          f h1 h2 & List.for_all2 f l1 l2
+        else false
+  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
+  | Const c1, Const c2 -> c1 = c2
+  | Ind c1, Ind c2 -> c1 = c2
+  | Construct c1, Construct c2 -> c1 = c2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
+  | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
+  | _ -> false
+
+(***************************************************************************)
+(*     Type of assumptions                                                 *)
+(***************************************************************************)
+
+type types = constr
+
+let type_app f tt = f tt
+
+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_rel_declaration = map_named_declaration
+
+(****************************************************************************)
+(*              Functions for dealing with constr terms                     *)
+(****************************************************************************)
+
+(*********************)
+(*     Occurring     *)
+(*********************)
+
+exception LocalOccur
+
+(* (closedn n M) raises FreeVar if a variable of height greater than n
+   occurs in M, returns () otherwise *)
+
+let closedn = 
+  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
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+
+let closed0 term =
+  try closedn 0 term; true with LocalOccur -> false
+
+(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
+
+let noccurn n term = 
+  let rec occur_rec n c = match kind_of_term c with
+    | Rel m -> if m = n then raise LocalOccur
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M 
+  for n <= p < n+m *)
+
+let noccur_between 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 LocalOccur
+    | _        -> iter_constr_with_binders succ occur_rec n c
+  in 
+  try occur_rec n term; true with LocalOccur -> false
+
+(* Checking function for terms containing existential variables.
+ The function [noccur_with_meta] considers the fact that
+ each existential variable (as well as each isevar)
+ in the term appears applied to its local context,
+ which may contain the CoFix variables. These occurrences of CoFix variables
+ are not considered *)
+
+let noccur_with_meta 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 LocalOccur
+    | App(f,cl) ->
+	(match kind_of_term f with
+           | Cast (c,_) when isMeta c -> ()
+           | Meta _ -> ()
+	   | _ -> iter_constr_with_binders succ occur_rec n c)
+    | Evar (_, _) -> ()
+    | _ -> iter_constr_with_binders succ occur_rec n c
+  in
+  try (occur_rec n term; true) with LocalOccur -> false
+
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+(* The generic lifting function *)
+let rec exliftn el c = match kind_of_term c with
+  | Rel i -> mkRel(reloc_rel i el)
+  | _ -> map_constr_with_binders el_lift exliftn el c
+
+(* Lifting the binding depth across k bindings *)
+
+let liftn k n = 
+  match el_liftn (pred n) (el_shft k ELID) with
+    | ELID -> (fun c -> c)
+    | el -> exliftn el
+ 
+let lift k = liftn k 1
+
+(*********************)
+(*   Substituting    *)
+(*********************)
+
+(* (subst1 M c) substitutes M for Rel(1) in c 
+   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
+   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
+
+(* 1st : general case *)
+
+type info = Closed | Open | Unknown
+type 'a substituend = { mutable sinfo: info; sit: 'a }
+
+let rec lift_substituend depth s =
+  match s.sinfo with
+    | Closed -> s.sit
+    | Open -> lift depth s.sit
+    | Unknown ->
+        s.sinfo <- if closed0 s.sit then Closed else Open;
+        lift_substituend depth s
+
+let make_substituend c = { sinfo=Unknown; sit=c }
+
+let substn_many lamv n =
+  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
+
+(*
+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 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 subst1_decl lam = substl_decl [lam]
+
+(* (thin_val sigma) removes identity substitutions from sigma *)
+
+let rec thin_val = function
+  | [] -> []
+  | (((id,{ sit = v }) as s)::tl) when isVar v -> 
+      if id = destVar v then thin_val tl else s::(thin_val tl)
+  | h::tl -> h::(thin_val tl)
+
+(* (replace_vars sigma M) applies substitution sigma to term M *)
+let replace_vars var_alist = 
+  let var_alist =
+    List.map (fun (str,c) -> (str,make_substituend c)) var_alist in
+  let var_alist = thin_val var_alist in 
+  let rec substrec n c = match kind_of_term c with
+    | Var x ->
+        (try lift_substituend n (List.assoc x var_alist)
+         with Not_found -> c)
+    | _ -> map_constr_with_binders succ substrec n c
+  in 
+  if var_alist = [] then (function x -> x) else substrec 0
+
+(*
+let repvarkey = Profile.declare_profile "replace_vars";;
+let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
+*)
+
+(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+let subst_var str = replace_vars [(str, mkRel 1)]
+
+(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
+let substn_vars p vars =
+  let _,subst =
+    List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars
+  in replace_vars (List.rev subst)
+
+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 *)
+(*********************)
+
+(* Constructs a DeBrujin index with number n *)
+let mkRel = mkRel
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta = mkMeta
+
+(* Constructs a Variable named id *)
+let mkVar = mkVar
+
+(* Construct a type *)
+let mkProp   = mkSort mk_Prop
+let mkSet    = mkSort mk_Set
+let mkType u = mkSort (Type u)
+let mkSort   = function
+  | Prop Null -> mkProp (* Easy sharing *)
+  | Prop Pos -> mkSet
+  | s -> mkSort s
+
+let prop = mk_Prop
+and spec = mk_Set
+and type_0 = Type prop_univ
+
+(* 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 = mkCast
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd = mkProd
+let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c)
+let mkProd_string   s t c = mkProd (Name (id_of_string s), t, c)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda = mkLambda
+let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c)
+let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn = mkLetIn
+let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2)
+
+(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+let mkProd_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
+
+let mkNamedProd_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedProd id t c
+    | Some b -> mkNamedLetIn id b t c
+
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+let mkLambda_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkLambda (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
+
+let mkNamedLambda_or_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedLambda id t c
+    | Some b -> mkNamedLetIn id b t c
+
+(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
+let mkProd_wo_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na,  t, c)
+    | Some b -> subst1 b c
+
+let mkNamedProd_wo_LetIn (id,body,t) c =
+  match body with
+    | None -> mkNamedProd id t c
+    | Some b -> subst1 b (subst_var id c)
+
+(* non-dependent product t1 -> t2 *)
+let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* We ensure applicative terms have at most one arguments and the
+   function is not itself an applicative term *)
+let mkApp = mkApp
+
+let mkAppA v =
+  let l = Array.length v in
+  if l=0 then anomaly "mkAppA received an empty array"
+  else mkApp (v.(0), Array.sub v 1 (Array.length v -1))
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+let mkConst = mkConst
+
+(* Constructs an existential variable *)
+let mkEvar = mkEvar
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+let mkInd = mkInd
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+let mkConstruct = mkConstruct
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase = mkCase
+let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac)
+
+(* If recindxs = [|i1,...in|] 
+      funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then    
+
+      mkFix ((recindxs,i),(funnames,typarray,bodies))
+   
+   constructs the ith function of the block  
+
+    Fixpoint f1 [ctx1] : t1 := b1
+    with     f2 [ctx2] : t2 := b2
+    ...
+    with     fn [ctxn] : tn := bn.
+
+   where the lenght of the jth context is ij.
+*)
+
+let mkFix = mkFix
+
+(* If funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then 
+
+      mkCoFix (i,(funnames,typsarray,bodies))
+
+   constructs the ith function of the block  
+   
+    CoFixpoint f1 : t1 := b1
+    with       f2 : t2 := b2
+    ...
+    with       fn : tn := bn.
+*)
+let mkCoFix = mkCoFix
+
+(* Construct an implicit *)
+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 *)
+(***************************)
+
+let abs_implicit c = mkLambda (Anonymous, mkImplicit, c)
+let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a)
+let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a)
+
+(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
+let prodn n env b =
+  let rec prodrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> prodrec (n-1,  l, mkProd (v,t,b))
+    | _ -> assert false
+  in 
+  prodrec (n,env,b)
+
+(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *)
+let compose_prod l b = prodn (List.length l) l b
+
+(* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *)
+let lamn n env b =
+  let rec lamrec = function
+    | (0, env, b)        -> b
+    | (n, ((v,t)::l), b) -> lamrec (n-1,  l, mkLambda (v,t,b))
+    | _ -> assert false
+  in 
+  lamrec (n,env,b)
+
+(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *)
+let compose_lam l b = lamn (List.length l) l b
+
+let applist (f,l) = mkApp (f, Array.of_list l)
+
+let applistc f l = mkApp (f, Array.of_list l)
+
+let appvect = mkApp
+	    
+let appvectc f l = mkApp (f,l)
+		     
+(* to_lambda n (x1:T1)...(xn:Tn)T =
+ * [x1:T1]...[xn:Tn]T *)
+let rec to_lambda n prod =
+  if n = 0 then 
+    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
+      | _   -> errorlabstrm "to_lambda" (mt ())                      
+
+let rec to_prod n lam =
+  if n=0 then 
+    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
+      | _   -> errorlabstrm "to_prod" (mt ())                      
+	    
+(* pseudo-reduction rule:
+ * [prod_app  s (Prod(_,B)) N --> B[N]
+ * with an strip_outer_cast on the first argument to produce a product *)
+
+let prod_app t n =
+  match kind_of_term (strip_outer_cast t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ ->
+	errorlabstrm "prod_app"
+	  (str"Needed a product, but didn't find one" ++ fnl ())
+
+
+(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
+let prod_appvect t nL = Array.fold_left prod_app t nL
+
+(* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *)
+let prod_applist t nL = List.fold_left prod_app t nL
+
+(*********************************)
+(* Other term destructors        *)
+(*********************************)
+
+(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
+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
+    | _              -> l,c
+  in 
+  prodec_rec []
+
+(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
+   ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
+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
+    | _                -> l,c
+  in 
+  lamdec_rec []
+
+(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_prod_n n =
+  if n < 0 then error "decompose_prod_n: integer parameter must be positive";
+  let rec prodec_rec l n c = 
+    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
+      | _ -> error "decompose_prod_n: not enough products"
+  in 
+  prodec_rec [] n 
+
+(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T 
+   into the pair ([(xn,Tn);...;(x1,T1)],T) *)
+let decompose_lam_n n =
+  if n < 0 then error "decompose_lam_n: integer parameter must be positive";
+  let rec lamdec_rec l n c = 
+    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
+      | _ -> error "decompose_lam_n: not enough abstractions"
+  in 
+  lamdec_rec [] n 
+
+(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction
+ * gives n (casts are ignored) *)
+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
+    | _ -> n
+  in 
+  nbrec 0
+    
+(* similar to nb_lam, but gives the number of products instead *)
+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
+    | _ -> n
+  in 
+  nbrec 0
+
+(* Rem: end of import from old module Generic *)
+
+(*******************************)
+(*  alpha conversion functions *)                         
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+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 *)
+
+(*******************)
+(*  hash-consing   *)                         
+(*******************)
+
+module Htype =
+  Hashcons.Make(
+    struct
+      type t = types
+      type u = (constr -> constr) * (sorts -> sorts)
+(*
+      let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ}
+      let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ
+*)
+(**)
+      let hash_sub (hc,hs) j = hc j
+      let equal j1 j2 = j1==j2
+(**)
+      let hash = Hashtbl.hash
+    end)
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      type t = sorts
+      type u = universe -> universe
+      let hash_sub huniv = function
+          Prop c -> Prop c
+        | Type u -> Type (huniv u)
+      let equal s1 s2 =
+        match (s1,s2) with
+            (Prop c1, Prop c2) -> c1=c2
+          | (Type u1, Type u2) -> u1 == u2
+          |_ -> false
+      let hash = Hashtbl.hash
+    end)
+
+let hsort = Hsorts.f
+
+let hcons_constr (hkn,hdir,hname,hident,hstr) =
+  let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
+  let hcci = hcons_term (hsortscci,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())
diff --git a/kernel/term.mli b/kernel/term.mli
new file mode 100644
index 00000000..a5e5c081
--- /dev/null
+++ b/kernel/term.mli
@@ -0,0 +1,525 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: term.mli,v 1.101.2.1 2004/07/16 19:30:26 herbelin Exp $ i*)
+
+(*i*)
+open Names
+(*i*)
+
+(*s The sorts of CCI. *)
+
+type contents = Pos | Null
+
+type sorts =
+  | Prop of contents       (* Prop and Set *)
+  | Type of Univ.universe  (* Type *)
+
+val mk_Set  : sorts
+val mk_Prop : sorts
+val type_0  : sorts
+
+(*s The sorts family of CCI. *)
+
+type sorts_family = InProp | InSet | InType
+
+val family_of_sort : sorts -> sorts_family
+
+(*s Useful types *)
+
+(*s Existential variables *)
+type existential_key = int
+
+(*s Existential variables *)
+type metavariable = int
+
+(*s Case annotation *)
+type pattern_source = DefaultPat of int | RegularPat
+type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_nargs : int; (* number of real args of the inductive type *)
+    style     : case_style;
+    source    : pattern_source array }
+(* the integer is the number of real args, needed for reduction *)
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  }
+
+(*s*******************************************************************)
+(* The type of constructions *)
+
+type constr
+
+(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
+   and application grouping *)
+val eq_constr : constr -> constr -> bool
+
+(* [types] is the same as [constr] but is intended to be used where a
+   {\em type} in CCI sense is expected (Rem:plurial form since [type] is a
+   reserved ML keyword) *)
+
+type types = constr
+
+(*s Functions about [types] *)
+
+val type_app : (constr -> constr) -> types -> types
+
+val body_of_type : types -> constr
+
+(*s Functions for dealing with constr terms.
+  The following functions are intended to simplify and to uniform the 
+  manipulation of terms. Some of these functions may be overlapped with
+  previous ones. *)
+
+(*s Term constructors. *)
+
+(* Constructs a DeBrujin index (DB indices begin at 1) *)
+val mkRel : int -> constr
+
+(* Constructs a Variable *)
+val mkVar : identifier -> constr
+
+(* Constructs an patvar named "?n" *)
+val mkMeta : metavariable -> constr
+
+(* Constructs an existential variable *)
+type existential = existential_key * constr array
+val mkEvar : existential -> constr
+
+(* Construct a sort *)
+val mkSort : sorts -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+
+(* 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
+
+(* Constructs the product [(x:t1)t2] *)
+val mkProd : name * types * types -> types
+val mkNamedProd : identifier -> types -> types -> types
+(* non-dependant product $t_1 \rightarrow t_2$, an alias for
+   [(_:t1)t2]. Beware $t_2$ is NOT lifted.
+   Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *)
+val mkArrow : types -> types -> constr
+
+(* Constructs the abstraction $[x:t_1]t_2$ *)
+val mkLambda : name * types * constr -> constr
+val mkNamedLambda : identifier -> types -> constr -> constr
+
+(* Constructs the product [let x = t1 : t2 in t3] *)
+val mkLetIn : name * constr * types * constr -> constr
+val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
+
+(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+   $(f~t_1~\dots~t_n)$. *)
+val mkApp : constr * constr array -> constr
+
+(* Constructs a constant *) 
+(* The array of terms correspond to the variables introduced in the section *)
+val mkConst : constant -> constr
+
+(* Inductive types *)
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+(* The array of terms correspond to the variables introduced in the section *)
+val mkInd : inductive -> constr
+
+(* Constructs the jth constructor of the ith (co)inductive type of the 
+   block named kn. The array of terms correspond to the variables
+   introduced in the section *)
+val mkConstruct : constructor -> constr
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+val mkCase : case_info * constr * constr * constr array -> constr
+
+(* If [recindxs = [|i1,...in|]]
+      [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [|b1,.....bn|]]
+   then [ mkFix ((recindxs,i), funnames, typarray, bodies) ]
+   constructs the $i$th function of the block (counting from 0)
+
+    [Fixpoint f1 [ctx1] = b1
+     with     f2 [ctx2] = b2
+     ...
+     with     fn [ctxn] = bn.]
+
+   \noindent where the length of the $j$th context is $ij$.
+*)
+type rec_declaration = name array * types array * constr array
+type fixpoint = (int array * int) * rec_declaration
+val mkFix : fixpoint -> constr
+
+(* If [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [b1,.....bn]] \par\noindent
+   then [mkCoFix (i, (typsarray, funnames, bodies))]
+   constructs the ith function of the block  
+   
+    [CoFixpoint f1 = b1
+     with       f2 = b2
+     ...
+     with       fn = bn.]
+ *)
+type cofixpoint = int * rec_declaration
+val mkCoFix : cofixpoint -> constr
+
+
+(*s Concrete type for making pattern-matching. *)
+
+(* [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
+type ('constr, 'types) prec_declaration =
+    name array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of identifier
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of sorts
+  | Cast      of 'constr * 'types
+  | Prod      of name * 'types * 'types
+  | Lambda    of name * 'types * 'constr
+  | LetIn     of name * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant
+  | Ind       of inductive
+  | Construct of constructor
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+val kind_of_term : constr -> (constr, types) kind_of_term
+
+(* Experimental *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of name * 'types * 'types
+  | LetInType  of name * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+val kind_of_type : types -> (constr, types) kind_of_type
+
+(*s Simple term case analysis. *)
+
+val isRel  : constr -> bool
+val isVar  : constr -> bool
+val isInd  : constr -> bool
+val isEvar : constr -> bool
+val isMeta : constr -> bool
+val isSort : constr -> bool
+val isCast : constr -> bool
+val isApp : constr -> bool
+val isConst : constr -> bool
+val isConstruct : constr -> bool
+
+val is_Prop : constr -> bool
+val is_Set  : constr -> bool
+val isprop : constr -> bool
+val is_Type : constr -> bool
+val iskind : constr -> bool
+val is_small : sorts -> bool
+
+(*s Term destructors. 
+   Destructor operations are partial functions and
+   raise [invalid_arg "dest*"] if the term has not the expected form. *)
+
+(* Destructs a DeBrujin index *)
+val destRel : constr -> int
+
+(* Destructs an existential variable *)
+val destMeta : constr -> metavariable
+
+(* Destructs a variable *)
+val destVar : constr -> identifier
+
+(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether 
+   [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *)
+val destSort : constr -> sorts
+
+(* Destructs a casted term *)
+val destCast : constr -> constr * types
+
+(* Destructs the product $(x:t_1)t_2$ *)
+val destProd : types -> name * types * types
+
+(* Destructs the abstraction $[x:t_1]t_2$ *)
+val destLambda : constr -> name * types * constr
+
+(* Destructs the let $[x:=b:t_1]t_2$ *)
+val destLetIn : constr -> name * constr * types * constr
+
+(* Destructs an application *)
+val destApplication : constr -> constr * constr array
+(* ... removing casts *)
+val decompose_app : constr -> constr * constr list
+
+(* Destructs a constant *)
+val destConst : constr -> constant
+
+(* Destructs an existential variable *)
+val destEvar : constr -> existential
+
+(* Destructs a (co)inductive type *)
+val destInd : constr -> inductive
+
+(* Destructs a constructor *)
+val destConstruct : constr -> constructor
+
+(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+val destCase : constr -> case_info * constr * constr * constr array
+
+(* Destructs the $i$th function of the block  
+   $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1
+    \mathit{with}     ~ f_2 ~ [ctx_2] = b_2
+    \dots
+    \mathit{with}     ~ f_n ~ [ctx_n] = b_n$,
+   where the lenght of the $j$th context is $ij$.
+*)
+val destFix : constr -> fixpoint
+
+val destCoFix : constr -> cofixpoint
+
+
+(*s A {\em declaration} has the form (name,body,type). It is either an
+    {\em assumption} if [body=None] or a {\em definition} if
+    [body=Some actualbody]. It is referred by {\em name} if [na] is an
+    identifier or by {\em relative index} if [na] is not an identifier
+    (in the latter case, [na] is of type [name] but just for printing
+    purpose *)
+
+type named_declaration = identifier * constr option * types
+type rel_declaration = name * constr option * types
+
+val map_named_declaration :
+  (constr -> constr) -> named_declaration -> named_declaration
+val map_rel_declaration :
+  (constr -> constr) -> rel_declaration -> rel_declaration
+
+(* 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
+val mkNamedProd_wo_LetIn : named_declaration -> types -> types
+
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+val mkLambda_or_LetIn : rel_declaration -> constr -> constr
+val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
+
+(*s Other term constructors. *)
+
+val abs_implicit : constr -> constr
+val lambda_implicit : constr -> constr
+val lambda_implicit_lift : int -> constr -> constr
+
+(* [applist (f,args)] and co work as [mkApp] *)
+
+val applist : constr * constr list -> constr
+val applistc : constr -> constr list -> constr
+val appvect : constr * constr array -> constr
+val appvectc : constr -> constr array -> constr
+
+(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ 
+   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+val prodn : int -> (name * constr) list -> constr -> constr
+
+(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+   Inverse of [decompose_prod]. *)
+val compose_prod : (name * constr) list -> constr -> constr
+
+(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+val lamn : int -> (name * constr) list -> constr -> constr
+
+(* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$
+   where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+   Inverse of [decompose_lam] *)
+val compose_lam : (name * constr) list -> constr -> constr
+
+(* [to_lambda n l] 
+   = $[x_1:T_1]...[x_n:T_n]T$
+   where $l = (x_1:T_1)...(x_n:T_n)T$ *)
+val to_lambda : int -> constr -> constr
+
+(* [to_prod n l] 
+   = $(x_1:T_1)...(x_n:T_n)T$
+   where $l = [x_1:T_1]...[x_n:T_n]T$ *)
+val to_prod : int -> constr -> constr
+
+(* pseudo-reduction rule *)
+
+(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *)
+val prod_appvect : constr -> constr array -> constr
+val prod_applist : constr -> constr list -> constr
+
+(*s Other term destructors. *)
+
+(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair
+   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product.
+   It includes also local definitions *)
+val decompose_prod : constr -> (name*constr) list * constr
+
+(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair
+   $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *)
+val decompose_lam : constr -> (name*constr) list * constr
+
+(* Given a positive integer n, transforms a product term 
+   $(x_1:T_1)..(x_n:T_n)T$
+   into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
+val decompose_prod_n : int -> constr -> (name * constr) list * constr
+
+(* Given a positive integer $n$, transforms a lambda term 
+   $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+val decompose_lam_n : int -> constr -> (name * constr) list * constr
+
+(* [nb_lam] $[x_1:T_1]...[x_n:T_n]c$ where $c$ is not an abstraction
+   gives $n$ (casts are ignored) *)
+val nb_lam : constr -> int
+
+(* similar to [nb_lam], but gives the number of products instead *)
+val nb_prod : constr -> int
+
+(* flattens application lists *)
+val collapse_appl : constr -> constr
+
+
+(* Removes recursively the casts around a term i.e.
+   [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
+val strip_outer_cast : constr -> constr
+
+(* Apply a function letting Casted types in place *)
+val under_casts : (constr -> constr) -> constr -> constr
+
+(*s Occur checks *)
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+val closed0 : constr -> bool
+
+(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
+val noccurn : int -> constr -> bool
+
+(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+  for n <= p < n+m *)
+val noccur_between : int -> int -> constr -> bool
+
+(* Checking function for terms containing existential- or
+   meta-variables.  The function [noccur_with_meta] considers only
+   meta-variable applied to some terms (intented to be its local
+   context) (for existential variables, it is necessarily the case) *)
+val noccur_with_meta : int -> int -> constr -> bool
+
+(*s Relocation and substitution *)
+
+(* [exliftn el c] lifts [c] with lifting [el] *)
+val exliftn : Esubst.lift -> constr -> constr
+
+(* [liftn n k c] lifts by [n] indexes above [k] in [c] *)
+val liftn : int -> int -> constr -> constr
+
+(* [lift n c] lifts by [n] the positive indexes in [c] *)
+val lift : int -> constr -> constr
+
+(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
+    accordingly indexes in [a1],...,[an] *)
+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 replace_vars : (identifier * constr) list -> constr -> constr
+val subst_var : identifier -> constr -> constr
+
+(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+   if two names are identical, the one of least indice is keeped *)
+val subst_vars : identifier list -> constr -> constr
+(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+   if two names are identical, the one of least indice is keeped *)
+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]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
+
+(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val map_constr : (constr -> constr) -> constr -> constr
+
+(* [map_constr_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val map_constr_with_binders :
+  ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val iter_constr : (constr -> unit) -> constr -> unit
+
+(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val iter_constr_with_binders :
+  ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
+   name and Cases annotations are not taken into account *)
+
+val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
+
+(*********************************************************************)
+
+val hcons_constr:
+  (kernel_name -> kernel_name) *
+  (dir_path -> dir_path) *
+  (name -> name) *
+  (identifier -> identifier) *
+  (string -> string) 
+  ->
+    (constr -> constr) *
+    (types -> types)
+
+val hcons1_constr : constr -> constr
+val hcons1_types : types -> types
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
new file mode 100644
index 00000000..5347583f
--- /dev/null
+++ b/kernel/term_typing.ml
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: term_typing.ml,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Reduction
+open Sign
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Type_errors
+open Indtypes
+open Typeops
+
+let constrain_type env j cst1 = function
+  | None -> 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 translate_local_def env (b,topt) =
+  let (j,cst) = infer env b in
+  let (typ,cst) = constrain_type env j cst topt in
+    (j.uj_val,typ,cst)
+
+let translate_local_assum env t =
+  let (j,cst) = infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+    (t,cst)
+
+(*
+
+(* Same as push_named, but check that the variable is not already
+   there. Should *not* be done in Environ because tactics add temporary
+   hypothesis many many times, and the check performed here would
+   cost too much. *)
+let safe_push_named (id,_,_ as d) env =
+  let _ =
+    try
+      let _ = lookup_named id env in 
+      error ("identifier "^string_of_id id^" already defined")
+    with Not_found -> () in
+  push_named d env
+
+let push_named_def = push_rel_or_named_def safe_push_named
+let push_rel_def = push_rel_or_named_def push_rel
+
+let push_rel_or_named_assum push (id,t) env =
+  let (j,cst) = safe_infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+  let env' = add_constraints cst env in
+  let env'' = push (id,None,t) env' in
+  (cst,env'')
+
+let push_named_assum = push_rel_or_named_assum push_named
+let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env)
+
+let push_rels_with_univ vars env =
+  List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars
+*)
+
+
+(* Insertion of constants and parameters in environment. *)
+
+let infer_declaration env dcl =
+  match dcl with
+  | 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
+  | 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
+    | Some b ->
+        Idset.union 
+	  (global_vars_set env (Declarations.force b)) 
+	  (global_vars_set env typ) 
+  in
+  let hyps = keep_hyps env ids in
+    { const_body = body;
+      const_type = typ;
+      const_hyps = hyps;
+      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_recipe env r = 
+  build_constant_declaration env (Cooking.cook_constant env r)
+
+(* Insertion of inductive types. *)
+
+let translate_mind env mie = check_inductive env mie 
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
new file mode 100644
index 00000000..67d479ba
--- /dev/null
+++ b/kernel/term_typing.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: term_typing.mli,v 1.2.8.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Univ
+open Declarations
+open Inductive
+open Environ
+open Entries
+open Typeops
+(*i*)
+
+val translate_local_def : env -> constr * types option -> 
+  constr * types * Univ.constraints
+
+val translate_local_assum : env -> types ->
+  types * Univ.constraints
+
+val translate_constant : env -> constant_entry -> constant_body
+
+val translate_mind : 
+  env -> mutual_inductive_entry -> mutual_inductive_body
+
+val translate_recipe : 
+  env -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
new file mode 100644
index 00000000..c3d4726f
--- /dev/null
+++ b/kernel/type_errors.ml
@@ -0,0 +1,114 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: type_errors.ml,v 1.31.2.1 2004/07/16 19:30:27 herbelin Exp $ *)
+
+open Names
+open Term
+open Sign
+open Environ
+open Reduction
+
+(* Type errors. *)
+
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * types list * constr * unsafe_judgment
+      * (constr * constr * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * types) * unsafe_judgment
+  | ActualType of unsafe_judgment * types
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * types array
+
+exception TypeError of env * type_error
+
+let nfj {uj_val=c;uj_type=ct} =
+  {uj_val=c;uj_type=nf_betaiota ct}
+
+let error_unbound_rel env n =
+  raise (TypeError (env, UnboundRel n))
+
+let error_unbound_var env v =
+  raise (TypeError (env, UnboundVar v))
+
+let error_not_type env j =
+  raise (TypeError (env, NotAType j))
+
+let error_assumption env j =
+  raise (TypeError (env, BadAssumption j))
+
+let error_reference_variables env id =
+  raise (TypeError (env, ReferenceVariables id))
+
+let error_elim_arity env ind aritylst c pj okinds = 
+  raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
+
+let error_case_not_inductive env j = 
+  raise (TypeError (env, CaseNotInductive j))
+
+let error_number_branches env cj expn =
+  raise (TypeError (env, NumberBranches (nfj cj,expn)))
+
+let error_ill_formed_branch env c i actty expty =
+  raise (TypeError (env,
+    IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
+
+let error_generalization env nvar c =
+  raise (TypeError (env, Generalization (nvar,c)))
+
+let error_actual_type env j expty =
+  raise (TypeError (env, ActualType (j,expty)))
+
+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)))
+
+let error_ill_formed_rec_body env why lna i =
+  raise (TypeError (env, IllFormedRecBody (why,lna,i)))
+
+let error_ill_typed_rec_body env i lna vdefj vargs =
+  raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
+
+
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
new file mode 100644
index 00000000..2e8a7138
--- /dev/null
+++ b/kernel/type_errors.mli
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: type_errors.mli,v 1.36.2.1 2004/07/16 19:30:27 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+(*i*)
+
+(* Type errors. \label{typeerrors} *)
+
+(*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
+    notation i*)
+type guard_error =
+  (* Fixpoints *)
+  | NotEnoughAbstractionInFixBody
+  | RecursionNotOnInductiveType
+  | RecursionOnIllegalTerm of int * constr * int list * int list
+  | NotEnoughArgumentsForFixCall of int
+  (* CoFixpoints *)
+  | CodomainNotInductiveType of constr
+  | NestedRecursiveOccurrences
+  | UnguardedRecursiveCall of constr
+  | RecCallInTypeOfAbstraction of constr
+  | RecCallInNonRecArgOfConstructor of constr
+  | RecCallInTypeOfDef of constr
+  | RecCallInCaseFun of constr
+  | RecCallInCaseArg of constr
+  | RecCallInCasePred of constr
+  | NotGuardedForm of constr
+
+type arity_error =
+  | NonInformativeToInformative
+  | StrongEliminationOnNonSmallType
+  | WrongArity
+
+type type_error =
+  | UnboundRel of int
+  | UnboundVar of variable
+  | NotAType of unsafe_judgment
+  | BadAssumption of unsafe_judgment
+  | ReferenceVariables of constr
+  | ElimArity of inductive * types list * constr * unsafe_judgment
+      * (constr * constr * arity_error) option
+  | CaseNotInductive of unsafe_judgment
+  | WrongCaseInfo of inductive * case_info
+  | NumberBranches of unsafe_judgment * int
+  | IllFormedBranch of constr * int * constr * constr
+  | Generalization of (name * types) * unsafe_judgment
+  | ActualType of unsafe_judgment * types
+  | CantApplyBadType of
+      (int * constr * constr) * unsafe_judgment * unsafe_judgment array
+  | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
+  | IllFormedRecBody of guard_error * name array * int
+  | IllTypedRecBody of
+      int * name array * unsafe_judgment array * types array
+
+exception TypeError of env * type_error
+
+val error_unbound_rel : env -> int -> 'a
+
+val error_unbound_var : env -> variable -> 'a
+
+val error_not_type : env -> unsafe_judgment -> 'a
+
+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
+
+val error_case_not_inductive : env -> unsafe_judgment -> 'a
+
+val error_number_branches : env -> unsafe_judgment -> int -> 'a
+
+val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
+
+val error_generalization : env -> name * types -> unsafe_judgment -> 'a
+
+val error_actual_type : env -> unsafe_judgment -> types -> 'a
+
+val error_cant_apply_not_functional : 
+  env -> unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_cant_apply_bad_type : 
+  env -> int * constr * constr -> 
+      unsafe_judgment -> unsafe_judgment array -> 'a
+
+val error_ill_formed_rec_body :
+  env -> guard_error -> name array -> int -> 'a
+
+val error_ill_typed_rec_body  :
+  env -> int -> name array -> unsafe_judgment array -> types array -> 'a
+
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
new file mode 100644
index 00000000..66b2e24d
--- /dev/null
+++ b/kernel/typeops.ml
@@ -0,0 +1,489 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: typeops.ml,v 1.89.2.1 2004/07/16 19:30:28 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Declarations
+open Sign
+open Environ
+open Entries
+open Reduction
+open Inductive
+open Type_errors
+
+
+(* 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
+    | Sort s -> {utj_val = j.uj_val; utj_type = s }
+    | _ -> error_not_type env j
+
+(* This should be a type intended to be assumed. The error message is *)
+(* not as useful as for [type_judgment]. *)
+let assumption_of_judgment env j =
+  try (type_judgment env j).utj_val
+  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;;
+*)
+
+(************************************************)
+(* Incremental typing rules: builds a typing judgement given the *)
+(* judgements for the subterms. *)
+
+(*s Type of sorts *)
+
+(* Prop and Set *)
+
+let judge_of_prop =
+  { uj_val = body_of_type mkProp;
+    uj_type = mkSort type_0 }
+
+let judge_of_set =
+  { uj_val = body_of_type mkSet;
+    uj_type = mkSort type_0 }
+
+let judge_of_prop_contents = function
+  | Null -> judge_of_prop
+  | Pos -> judge_of_set
+
+(* Type of Type(i). *)
+
+let judge_of_type u =
+  let uu = super u in
+  { uj_val = body_of_type (mkType u);
+    uj_type = mkType uu }
+
+(*s Type of a de Bruijn index. *)
+	  
+let judge_of_relative env n = 
+  try
+    let (_,_,typ) = lookup_rel n env in
+    { uj_val  = mkRel n;
+      uj_type = type_app (lift n) typ }
+  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
+    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
+   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
+      if not (eq_constr ty2 ty1) then
+        error "types do not match")
+    sign
+    ~init:()
+
+
+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
+
+
+(* Checks if the given context of variables [hyps] is included in the
+   current context of [env]. *)
+(*
+let check_hyps id env hyps =
+  let hyps' = named_context env in
+  if not (hyps_inclusion env hyps hyps') then
+    error_reference_variables env id
+*)
+(* Instantiation of terms on real arguments. *)
+
+(* 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;;
+*)
+
+(* Type of a lambda-abstraction. *)
+
+(* [judge_of_abstraction env name var j] implements the rule
+
+ env, name:typ |- j.uj_val:j.uj_type     env, |- (name:typ)j.uj_type : s
+ -----------------------------------------------------------------------
+          env |- [name:typ]j.uj_val : (name:typ)j.uj_type
+
+  Since all products are defined in the Calculus of Inductive Constructions
+  and no upper constraint exists on the sort $s$, we don't need to compute $s$
+*)
+
+let judge_of_abstraction env name var j =
+  { uj_val = mkLambda (name, var.utj_val, j.uj_val);
+    uj_type = mkProd (name, var.utj_val, j.uj_type) }
+
+(* Type of let-in. *)
+
+let judge_of_letin env name defj typj j =
+  { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ;
+    uj_type = type_app (subst1 defj.uj_val) j.uj_type }
+
+(* Type of an application. *)
+
+let judge_of_apply env funj argjv =
+  let rec apply_rec n typ cst = function
+    | [] -> 
+	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
+          uj_type = typ },
+	cst
+    | hj::restjl ->
+        (match kind_of_term (whd_betadeltaiota env typ) with
+          | Prod (_,c1,c2) ->
+	      (try 
+		let c = conv_leq env hj.uj_type c1 in
+		let cst' = Constraint.union cst c in
+		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
+	      with NotConvertible -> 
+		error_cant_apply_bad_type env
+		  (n,c1, hj.uj_type)
+		  funj argjv)
+
+          | _ ->
+	      error_cant_apply_not_functional env funj argjv)
+  in 
+  apply_rec 1
+    funj.uj_type
+    Constraint.empty
+    (Array.to_list argjv)
+
+(* Type of product *)
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *) 
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        if engagement env = Some ImpredicativeSet then
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        else
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          domsort
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop _,  Type _)  -> rangsort
+    (* Product rule (Type_i,Type_i,Type_i) *) 
+    | (Type u1, Type u2) -> Type (sup u1 u2)
+
+(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
+
+    env |- typ1:s1       env, name:typ1 |- typ2 : s2
+    -------------------------------------------------------------------------
+         s' >= (s1,s2), env |- (name:typ)j.uj_val : s'
+
+  where j.uj_type is convertible to a sort s2
+*)
+let judge_of_product env name t1 t2 =
+  let s = sort_of_product env t1.utj_type t2.utj_type in
+  { uj_val = mkProd (name, t1.utj_val, t2.utj_val);
+    uj_type = mkSort s }
+
+(* Type of a type cast *)
+
+(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
+
+    env |- c:typ1    env |- typ2:s    env |- typ1 <= typ2
+    ---------------------------------------------------------------------
+         env |- c:typ2
+*)
+
+let judge_of_cast env cj 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);
+      uj_type = expected_type },
+    cst
+  with NotConvertible ->
+    error_actual_type env cj expected_type
+
+(* 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;;
+*)
+
+(* Constructors. *)
+
+let judge_of_constructor env c =
+  let constr = mkConstruct c in
+  let _ =
+    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;;
+*)
+
+(* Case. *)
+
+let check_branch_types env cj (lft,explft) = 
+  try conv_leq_vecti env lft explft
+  with
+      NotConvertibleVect i ->
+        error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i)
+    | Invalid_argument _ ->
+        error_number_branches env cj (Array.length explft)
+
+let judge_of_case env ci pj cj lfj =
+  let indspec =
+    try find_rectype env cj.uj_type
+    with Not_found -> error_case_not_inductive env cj in
+  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
+  ({ 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 *)
+(* the specific guard condition. *)
+
+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)
+  with NotConvertibleVect i ->
+    error_ill_typed_rec_body env i lna vdefj lar
+
+(************************************************************************)
+(************************************************************************)
+
+(* This combinator adds the universe constraints both in the local
+   graph and in the universes of the environment. This is to ensure
+   that the infered local graph is satisfiable. *)
+let univ_combinator (cst,univ) (j,c') =
+  (j,(Constraint.union cst c', merge_constraints c' univ))
+
+(* The typing machine. *)
+    (* ATTENTION : faudra faire le typage du contexte des Const,
+    Ind et Constructsi un jour cela devient des constructions
+    arbitraires et non plus des variables *)
+let rec execute env cstr cu =
+  match kind_of_term cstr with
+    (* Atomic terms *)
+    | Sort (Prop c) -> 
+	(judge_of_prop_contents c, cu)
+
+    | Sort (Type u) ->
+	(judge_of_type u, cu)
+
+    | Rel n -> 
+	(judge_of_relative env n, cu)
+
+    | Var id -> 
+	(judge_of_variable env id, cu)
+
+    | Const c ->
+        (judge_of_constant env c, 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)
+	    
+    | Lambda (name,c1,c2) -> 
+        let (varj,cu1) = execute_type env c1 cu in
+	let env1 = push_rel (name,None,varj.utj_val) env in
+        let (j',cu2) = execute env1 c2 cu1 in 
+        (judge_of_abstraction env name varj j', cu2)
+	  
+    | Prod (name,c1,c2) ->
+        let (varj,cu1) = execute_type env c1 cu in
+	let env1 = push_rel (name,None,varj.utj_val) env in
+        let (varj',cu2) = execute_type env1 c2 cu1 in
+	(judge_of_product env name varj varj', cu2)
+
+    | 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 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) ->
+        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)
+
+    (* Inductive types *)
+    | Ind ind ->
+	(judge_of_inductive env ind, cu)
+
+    | Construct c -> 
+	(judge_of_constructor env c, cu)
+
+    | Case (ci,p,c,lf) ->
+        let (cj,cu1) = execute env c cu in
+        let (pj,cu2) = execute env p cu1 in
+        let (lfj,cu3) = execute_array env lf cu2 in
+        univ_combinator cu3
+          (judge_of_case env ci pj cj lfj)
+  
+    | Fix ((vn,i as vni),recdef) ->
+        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
+        let fix = (vni,recdef') in
+        check_fix env fix;
+	(make_judge (mkFix fix) fix_ty, cu1)
+	  
+    | CoFix (i,recdef) ->
+        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
+        let cofix = (i,recdef') in
+        check_cofix env cofix;
+	(make_judge (mkCoFix cofix) fix_ty, cu1)
+
+    (* Partial proofs: unsupported by the kernel *)
+    | Meta _ ->
+	anomaly "the kernel does not support metavariables"
+
+    | Evar _ ->
+	anomaly "the kernel does not support existential variables"
+
+and execute_type env constr cu = 
+  let (j,cu1) = execute env constr cu in
+  (type_judgment env j, cu1)
+	  
+and execute_recdef env (names,lar,vdef) i cu =
+  let (larj,cu1) = execute_array env lar cu in
+  let lara = Array.map (assumption_of_judgment env) larj in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let (vdefj,cu2) = execute_array env1 vdef cu1 in
+  let vdefv = Array.map j_val vdefj in
+  let cst = type_fixpoint env1 names lara vdefj in
+  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_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)
+
+(* 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)
+
+let infer_type env constr =
+  let (j,(cst,_)) =
+    execute_type env constr (Constraint.empty, universes env) in
+  (j, cst)
+
+let infer_v env cv =
+  let (jv,(cst,_)) =
+    execute_array env cv (Constraint.empty, universes env) in
+  (jv, cst)
+ 
+(* Typing of several terms. *)
+
+let infer_local_decl env id = function
+  | LocalDef c -> 
+      let (j,cst) = infer env c in
+      (Name id, Some j.uj_val, j.uj_type), cst
+  | LocalAssum c ->
+      let (j,cst) = infer env c in
+      (Name id, None, assumption_of_judgment env j), cst
+
+let infer_local_decls env decls =
+  let rec inferec env = function
+  | (id, d) :: l -> 
+      let env, l, cst1 = inferec env l in
+      let d, cst2 = infer_local_decl env id d in
+      push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2
+  | [] -> env, empty_rel_context, Constraint.empty in
+  inferec env decls
+
+(* Exported typing functions *)
+
+let typing env c = 
+  let (j,cst) = infer env c in
+  let _ = add_constraints cst env in
+  j
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
new file mode 100644
index 00000000..ffe9d861
--- /dev/null
+++ b/kernel/typeops.mli
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: typeops.mli,v 1.44.8.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Environ
+open Entries
+(*i*)
+
+(*s Typing functions (not yet tagged as safe) *)
+
+val infer      : env -> constr       -> unsafe_judgment * constraints
+val infer_v    : env -> constr array -> unsafe_judgment array * constraints
+val infer_type : env -> types        -> unsafe_type_judgment * constraints
+
+val infer_local_decls :
+  env -> (identifier * local_entry) list
+    -> env * Sign.rel_context * constraints
+
+(*s Basic operations of the typing machine. *)
+
+(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j]
+   returns the type $c$, checking that $t$ is a sort. *)
+
+val assumption_of_judgment :  env -> unsafe_judgment -> types
+val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
+
+(*s Type of sorts. *)
+val judge_of_prop_contents : contents -> unsafe_judgment
+val judge_of_type          : universe -> unsafe_judgment
+
+(*s Type of a bound variable. *)
+val judge_of_relative : env -> int -> unsafe_judgment
+
+(*s Type of variables *)
+val judge_of_variable : env -> variable -> unsafe_judgment
+
+(*s type of a constant *)
+val judge_of_constant : env -> constant -> unsafe_judgment
+
+(*s Type of application. *)
+val judge_of_apply : 
+  env -> unsafe_judgment -> unsafe_judgment array
+    -> unsafe_judgment * constraints
+
+(*s Type of an abstraction. *)
+val judge_of_abstraction : 
+  env -> name -> unsafe_type_judgment -> unsafe_judgment 
+    -> unsafe_judgment
+
+(*s Type of a product. *)
+val judge_of_product :
+  env -> name -> unsafe_type_judgment -> unsafe_type_judgment 
+    -> unsafe_judgment
+
+(* s Type of a let in. *)
+val judge_of_letin :
+  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment 
+    -> unsafe_judgment
+
+(*s Type of a cast. *)
+val judge_of_cast :
+  env -> unsafe_judgment -> unsafe_type_judgment
+    -> unsafe_judgment * constraints
+
+(*s Inductive types. *)
+
+val judge_of_inductive : env -> inductive -> unsafe_judgment
+
+val judge_of_constructor : env -> constructor -> unsafe_judgment
+
+(*s Type of Cases. *)
+val judge_of_case : env -> case_info
+  -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
+    -> unsafe_judgment * constraints
+
+(* Typecheck general fixpoint (not checking guard conditions) *)
+val type_fixpoint : env -> name array -> types array 
+    -> unsafe_judgment array -> constraints
+
+(* Kernel safe typing but applicable to partial proofs *)
+val typing : env -> constr -> unsafe_judgment
+
diff --git a/kernel/univ.ml b/kernel/univ.ml
new file mode 100644
index 00000000..d46609c8
--- /dev/null
+++ b/kernel/univ.ml
@@ -0,0 +1,469 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: univ.ml,v 1.17.10.1 2004/07/16 19:30:28 herbelin Exp $ *)
+
+(* Universes are stratified by a partial ordering $\ge$.
+   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$.
+
+   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$.
+
+   The equivalence $\~{}$ is represented by a tree structure, as in the
+   union-find algorithm. The assertions $>$ and $\ge$ are represented by
+   adjacency lists *)
+
+open Pp
+open Util
+
+type universe_level =
+    { u_mod : Names.dir_path;
+      u_num : int }
+
+type universe =
+  | Variable of universe_level
+  | Max of universe_level list * universe_level list
+  
+module UniverseOrdered = struct
+  type t = universe_level
+  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 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 pr_uni_level u = str (string_of_univ_level u)
+
+let pr_uni = function
+  | Variable u -> 
+      pr_uni_level u
+  | 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 ")"
+
+(* Returns a fresh universe, juste above u. Does not create new universes
+   for Type_0 (the sort of Prop and Set).
+   Used to type the sort u. *)
+let super = function
+  | Variable u -> 
+      Max ([],[u])
+  | Max _ ->
+      anomaly ("Cannot take the successor of a non variable universes:\n"^
+       "you are probably typing a type already known to be the type\n"^
+       "of a user-provided term; if you really need this, please report")
+
+(* returns the least upper bound of universes u and v. If they are not
+   constrained, then a new universe is created.
+   Used to type the products. *)
+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)
+    | Max (gel,gtl), Max (gel',gtl') ->
+	Max (list_union gel gel',list_union gtl gtl')
+
+(* Comparison on this type is pointer equality *)
+type canonical_arc =
+    { univ: universe_level; gt: universe_level list; ge: universe_level list }
+
+let terminal u = {univ=u; gt=[]; ge=[]}
+
+(* A universe is either an alias for another one, or a canonical one,
+   for which we know the universes that are smaller *)
+type univ_entry =
+    Canonical of canonical_arc
+  | Equiv of universe_level * universe_level
+
+module UniverseMap = Map.Make(UniverseOrdered)
+
+type universes = univ_entry UniverseMap.t
+		   
+let enter_equiv_arc u v g =
+  UniverseMap.add u (Equiv(u,v)) g
+
+let enter_arc ca g =
+  UniverseMap.add ca.univ (Canonical ca) g
+
+let declare_univ u g =
+  if not (UniverseMap.mem u g) then
+    enter_arc (terminal u) g
+  else
+    g
+
+(* When typing Prop and Set, there is no constraint on the level,
+   hence the definition of prop_univ *)
+
+let initial_universes = UniverseMap.empty
+let prop_univ = Max ([],[])
+
+(* Every universe has a unique canonical arc representative *)
+
+(* repr : universes -> universe -> canonical_arc *)
+(* canonical representative : we follow the Equiv links *)
+let repr g u = 
+  let rec repr_rec u =
+    let a =
+      try UniverseMap.find u g
+      with Not_found -> anomalylabstrm "Univ.repr"
+	  (str"Universe " ++ pr_uni_level u ++ str" undefined") 
+    in
+    match a with 
+      | Equiv(_,v) -> repr_rec v
+      | Canonical arc -> arc
+  in
+  repr_rec u
+
+let can g = List.map (repr g)
+
+(* transitive closure : we follow the Greater 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')
+	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')
+	else
+          coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge')
+  in 
+  coll_rec [] [] ([],[arcu])
+
+(* reprgeq : canonical_arc -> canonical_arc list *)
+(* All canonical arcv such that arcu>=arcc with arcv#arcu *)
+let reprgeq g arcu =
+  let rec searchrec w = function
+    | [] -> w
+    | v :: vl ->
+	let arcv = repr g v in
+        if List.memq arcv w || arcu==arcv then 
+	  searchrec w vl
+        else 
+	  searchrec (arcv :: w) vl
+  in 
+  searchrec [] arcu.ge
+
+
+(* between : universe -> 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} *)
+    (* explore b u = (b or "u is good") *)
+  let rec explore ((good, bad, b) as input) arcu =
+    if List.memq arcu good then
+      (good, bad, true) (* b or true *)
+    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 
+      in
+	if b_childs then
+	  arcu::good, bad, true (* b or true *)
+	else 
+	  good, arcu::bad, b    (* b or false *)
+  in
+  let good,_,_ = explore ([arcv],[],false) (repr g u) in
+    good
+      
+(* We assume  compare(u,v) = GE 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
+
+(* compare : universe -> universe -> 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
+    else 
+      NGE
+
+(* 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
+
+   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 *)
+
+
+(* setgt : universe -> universe -> unit *)
+(* forces u > v *)
+let setgt g u v =
+  let arcu = repr g u in
+  enter_arc {arcu with gt=v::arcu.gt} g
+
+(* checks that non-redondant *)
+let setgt_if g u v = match compare g u v with
+  | GT -> g
+  | _ -> setgt g u v
+
+(* setgeq : universe -> universe -> unit *)
+(* forces u >= v *)
+let setgeq g u v =
+  let arcu = repr g u in
+  enter_arc {arcu with ge=v::arcu.ge} g
+
+
+(* checks that non-redondant *)
+let setgeq_if g u v = match compare g u v with
+  | NGE -> setgeq g u v
+  | _ -> g
+
+(* merge : universe -> universe -> unit *)
+(* we assume  compare(u,v) = GE *)
+(* 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
+    | arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
+                 (* 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') 
+	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
+	g'''
+    | [] -> anomaly "Univ.between"
+
+(* merge_disc : universe -> universe -> unit *)
+(* we assume  compare(u,v) = compare(v,u) = NGE *)
+(* 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
+  g'''
+
+(* Universe inconsistency: error raised when trying to enforce a relation
+   that would create a cycle in the graph of universes. *)
+
+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 =
+  let g = declare_univ u g in
+  let g = declare_univ v g in
+  match compare g u v with
+    | NGE -> 
+	(match compare g v u with
+           | GT -> error_inconsistency()
+           | GE -> merge g v u
+           | NGE -> setgeq g u v
+           | EQ -> anomaly "Univ.compare")
+    | _ -> g
+
+(* enforceq : universe -> universe -> unit *)
+(* enforceq 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 -> 
+	(match compare g v u with
+           | GT -> error_inconsistency()
+           | GE -> merge g v u
+           | NGE -> 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 =
+  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
+    | EQ -> error_inconsistency()
+    | NGE -> 
+	(match compare g v u with
+           | NGE -> setgt 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'
+*)
+
+(* Merging 2 universe graphs *)
+(*
+let merge_universes sp u1 u2 =
+  UniverseMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2
+*)
+
+
+(* Constraints and sets of consrtaints. *)
+
+type constraint_type = Gt | Geq | 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,Eq,v) -> enforce_univ_eq u v g
+
+
+module Constraint = Set.Make(
+  struct 
+    type t = univ_constraint 
+    let compare = Pervasives.compare 
+  end)
+		      
+type constraints = Constraint.t
+
+type constraint_function = 
+    universe -> universe -> constraints -> constraints
+
+let enforce_gt u v c = Constraint.add (u,Gt,v) 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"
+
+let enforce_eq u v c =
+  match (u,v) with
+    | Variable u, Variable 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
+
+(* Pretty-printing *)
+
+let num_universes g =
+  UniverseMap.fold (fun _ _ -> succ) g 0
+
+let num_edges g =
+  let reln_len = function
+    | Equiv _ -> 1
+    | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge
+  in
+  UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0
+    
+let pr_arc = function 
+  | Canonical {univ=u; gt=[]; ge=[]} ->
+      mt ()
+  | Canonical {univ=u; gt=gt; ge=ge} ->
+      pr_uni_level u ++ str " " ++
+      v 0
+        (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++
+         prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++
+      fnl ()
+  | Equiv (u,v) -> 
+      pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
+
+let pr_universes g =
+  let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in
+  prlist (function (_,a) -> pr_arc a) graph
+    
+
+(* Dumping constrains to a file *)
+
+let dump_universes output g = 
+  let dump_arc _ = function
+    | Canonical {univ=u; gt=gt; ge=ge} -> 
+	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;
+	  List.iter 
+	    (fun v -> 
+	       Printf.fprintf output "%s >= %s ;\n" u_str
+		 (string_of_univ_level v)) 
+	    ge
+    | 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 
+
+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_sub hdir = function
+	| Variable u -> Variable (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
+	  | Max (gel,gtl), Max (gel',gtl') ->
+	      (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl')
+	  | _ -> false
+      let hash = Hashtbl.hash
+    end)
+
+let hcons1_univ u =
+  let _,hdir,_,_,_ = Names.hcons_names() in
+  Hashcons.simple_hcons Huniv.f hdir u
+
diff --git a/kernel/univ.mli b/kernel/univ.mli
new file mode 100644
index 00000000..e15971eb
--- /dev/null
+++ b/kernel/univ.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: univ.mli,v 1.21.14.1 2004/07/16 19:30:28 herbelin Exp $ i*)
+
+(* Universes. *)
+
+type universe
+
+val prop_univ : universe
+val make_univ : Names.dir_path * int -> universe
+
+(* The type of a universe *)
+val super : universe -> universe
+(* The max of 2 universes *)
+val sup   : universe -> universe -> universe
+
+(*s Graphs of universes. *)
+
+type universes
+
+(* The empty graph of universes *)
+val initial_universes : universes
+
+(*s Constraints. *)
+
+module Constraint : Set.S
+
+type constraints = Constraint.t
+
+type constraint_function = universe -> universe -> constraints -> constraints
+
+val enforce_geq : constraint_function
+val enforce_eq : constraint_function
+
+(*s Merge of constraints in a universes graph. 
+  The function [merge_constraints] merges a set of constraints in a given
+  universes graph. It raises the exception [UniverseInconsistency] if the
+  constraints are not satisfiable. *)
+
+exception UniverseInconsistency
+
+val merge_constraints : constraints -> universes -> universes
+
+(*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
+
+val hcons1_univ : universe -> universe
diff --git a/lib/bignat.ml b/lib/bignat.ml
new file mode 100644
index 00000000..583a027f
--- /dev/null
+++ b/lib/bignat.ml
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..f08ccc39
--- /dev/null
+++ b/lib/bignat.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        *)
+(************************************************************************)
+
+(* $Id: bignat.mli,v 1.4.6.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+(*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
new file mode 100644
index 00000000..d4b995fb
--- /dev/null
+++ b/lib/bstack.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: bstack.ml,v 1.3.2.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+(* Queues of a given length *)
+
+open Util
+
+type 'a t = {mutable pos : int;
+             mutable size : int;
+             stack : 'a array}
+
+let create depth e =
+  {pos = 0;
+   size = 1;
+   stack = Array.create depth e}
+
+(*
+let set_depth bs n = bs.depth <- n
+*)
+
+let incr_pos bs =
+  bs.pos <- if bs.pos = Array.length bs.stack - 1 then 0 else bs.pos + 1
+
+let incr_size bs =
+  if bs.size < Array.length bs.stack then bs.size <- bs.size + 1
+
+let decr_pos bs =
+  bs.pos <- if bs.pos = 0 then Array.length bs.stack - 1 else bs.pos - 1
+
+let push bs e =
+  incr_pos bs;
+  incr_size bs;
+  bs.stack.(bs.pos) <- e
+	  
+let pop bs =
+  if bs.size > 1 then begin
+    bs.size <- bs.size - 1; 
+    let oldpos = bs.pos in
+    decr_pos bs;
+    (* Release the memory at oldpos, by coyping what is at new pos *)
+    bs.stack.(oldpos) <- bs.stack.(bs.pos)
+  end
+
+let top bs =
+  if bs.size >= 1 then bs.stack.(bs.pos)
+  else error "Nothing on the stack"
+	  
+let app_push bs f =
+  if bs.size = 0 then error "Nothing on the stack"
+  else push bs (f (bs.stack.(bs.pos)))
+
+let app_repl bs f =
+  if bs.size = 0 then error "Nothing on the stack"
+  else bs.stack.(bs.pos) <- f (bs.stack.(bs.pos))
+
+let depth bs = bs.size
diff --git a/lib/bstack.mli b/lib/bstack.mli
new file mode 100644
index 00000000..617f7df1
--- /dev/null
+++ b/lib/bstack.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: bstack.mli,v 1.4.2.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+(* Bounded stacks. If the depth is [None], then there is no depth limit. *)
+
+type 'a t
+
+val create : int -> 'a -> 'a t
+val push : 'a t -> 'a -> unit
+val app_push : 'a t -> ('a -> 'a) -> unit
+val app_repl : 'a t -> ('a -> 'a) -> unit
+val pop : 'a t -> unit
+val top : 'a t -> 'a
+val depth : 'a t -> int
diff --git a/lib/compat.ml4 b/lib/compat.ml4
new file mode 100644
index 00000000..5e1c65b4
--- /dev/null
+++ b/lib/compat.ml4
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Compatibility file depending on ocaml version *)
+
+(* IFDEF not available in 3.06; use ifdef instead *)
+
+(* type loc is different in 3.08 *)
+ifdef OCAML308 then
+module M = struct
+type loc = Token.flocation
+let dummy_loc = Token.dummy_loc
+let unloc (b,e) = (b.Lexing.pos_cnum,e.Lexing.pos_cnum)
+let make_loc loc = Token.make_loc loc
+end
+else
+module M = struct
+type loc = int * int
+let dummy_loc = (0,0)
+let unloc x = x
+let make_loc x = x
+end
+
+type loc = M.loc
+let dummy_loc = M.dummy_loc
+let unloc = M.unloc
+let make_loc = M.make_loc
diff --git a/lib/doc.tex b/lib/doc.tex
new file mode 100644
index 00000000..35bd15fa
--- /dev/null
+++ b/lib/doc.tex
@@ -0,0 +1,7 @@
+
+\newpage
+\section*{Utility libraries}
+
+\ocwsection \label{lib}
+This chapter describes the various utility libraries used in the code
+of \Coq.
diff --git a/lib/dyn.ml b/lib/dyn.ml
new file mode 100644
index 00000000..63f00365
--- /dev/null
+++ b/lib/dyn.ml
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: dyn.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+open Util
+
+(* Dynamics, programmed with DANGER !!! *)
+
+type t = string * Obj.t
+
+let dyntab = ref ([] : string list)
+
+let create s =
+  if List.mem s !dyntab then 
+    anomaly ("Dyn.create: already declared dynamic " ^ s);
+  dyntab := s :: !dyntab;
+  ((fun v -> (s,Obj.repr v)),
+   (fun (s',rv) ->
+      if s = s' then Obj.magic rv else failwith "dyn_out"))
+
+let tag (s,_) = s
diff --git a/lib/dyn.mli b/lib/dyn.mli
new file mode 100644
index 00000000..7f46c7e6
--- /dev/null
+++ b/lib/dyn.mli
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: dyn.mli,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+(* Dynamics. Use with extreme care. Not for kids. *)
+
+type t
+
+val create : string -> ('a -> t) * (t -> 'a)
+val tag : t -> string
diff --git a/lib/edit.ml b/lib/edit.ml
new file mode 100644
index 00000000..5020ef5c
--- /dev/null
+++ b/lib/edit.ml
@@ -0,0 +1,111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: edit.ml,v 1.8.2.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+open Pp
+open Util
+
+type ('a,'b,'c) t = {
+  mutable focus : 'a option;
+  mutable last_focused_stk : 'a list;
+  buf : ('a, 'b Bstack.t * 'c) Hashtbl.t }
+
+let empty () = { 
+  focus = None;
+  last_focused_stk = [];
+  buf = Hashtbl.create 17 }
+
+let focus e nd =
+  if not (Hashtbl.mem e.buf nd) then invalid_arg "Edit.focus";
+  begin match e.focus with
+    | Some foc when foc <> nd ->
+        e.last_focused_stk <- foc::(list_except foc e.last_focused_stk);
+    | _ -> ()
+  end;
+  e.focus <- Some nd
+
+let unfocus e =
+  match e.focus with
+    | None -> invalid_arg "Edit.unfocus"
+    | Some foc ->
+	begin
+	  e.last_focused_stk <- foc::(list_except foc e.last_focused_stk);
+	  e.focus <- None
+	end
+    
+let last_focused e =
+  match e.last_focused_stk with
+    | [] -> None
+    | f::_ -> Some f
+
+let restore_last_focus e =
+  match e.last_focused_stk with
+    | [] -> ()
+    | f::_ -> focus e f
+			     
+let focusedp e =
+  match e.focus with
+    | None -> false
+    | _    -> true
+
+let read e =
+  match e.focus with
+    | None -> None
+    | Some d ->
+	let (bs,c) = Hashtbl.find e.buf d in
+	Some(d,Bstack.top bs,c)
+
+let mutate e f =
+  match e.focus with
+    | None -> invalid_arg "Edit.mutate"
+    | Some d ->
+	let (bs,c) = Hashtbl.find e.buf d in
+	Bstack.app_push bs (f c)
+
+let rev_mutate e f =
+  match e.focus with
+    | None -> invalid_arg "Edit.rev_mutate"
+    | Some d ->
+	let (bs,c) = Hashtbl.find e.buf d in
+	Bstack.app_repl bs (f c)
+
+let undo e n =
+  match e.focus with
+    | None -> invalid_arg "Edit.undo"
+    | Some d ->
+	let (bs,_) = Hashtbl.find e.buf d in
+	if Bstack.depth bs = 1 & n > 0 then
+	  errorlabstrm "Edit.undo" (str"Undo stack exhausted");
+        repeat n Bstack.pop bs
+
+let create e (d,b,c,udepth) =
+  if Hashtbl.mem e.buf d then
+    errorlabstrm "Edit.create" 
+      (str"Already editing something of that name");
+  let bs = Bstack.create udepth b in
+  Hashtbl.add e.buf d (bs,c)
+
+let delete e d =
+  if not(Hashtbl.mem e.buf d) then
+    errorlabstrm "Edit.delete" (str"No such editor");
+  Hashtbl.remove e.buf d;
+  e.last_focused_stk <- (list_except d e.last_focused_stk);
+  match e.focus with
+    | Some d' -> if d = d' then (e.focus <- None ; (restore_last_focus e))
+    | None -> ()
+
+let dom e = 
+  let l = ref [] in
+  Hashtbl.iter (fun x _ -> l := x :: !l) e.buf;
+  !l
+	      
+let clear e =
+  e.focus <- None;
+  e.last_focused_stk <- [];
+  Hashtbl.clear e.buf
diff --git a/lib/edit.mli b/lib/edit.mli
new file mode 100644
index 00000000..edf0f67b
--- /dev/null
+++ b/lib/edit.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: edit.mli,v 1.5.2.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+(* The type of editors.
+ * An editor is a finite map, ['a -> 'b], which knows how to apply
+ * modification functions to the value in the range, and how to
+ * focus on a member of the range.
+ * It also supports the notion of a limited-depth undo, and that certain
+ * modification actions do not push onto the undo stack, since they are
+ * reversible. *)
+
+type ('a,'b,'c) t
+
+val empty : unit -> ('a,'b,'c) t
+
+(* sets the focus to the specified domain element *)
+val focus : ('a,'b,'c) t -> 'a -> unit
+
+(* unsets the focus which must not already be unfocused *)
+val unfocus : ('a,'b,'c) t -> unit
+
+(* gives the last focused element or [None] if none *)
+val last_focused : ('a,'b,'c) t -> 'a option
+
+(* are we focused ? *)
+val focusedp : ('a,'b,'c) t -> bool
+
+(* If we are focused, then return the current domain,range pair. *)
+val read : ('a,'b,'c) t -> ('a * 'b * 'c) option
+
+(* mutates the currently-focused range element, pushing its
+ * old value onto the undo stack
+ *)
+val mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit
+
+(* mutates the currently-focused range element, in place. *)
+val rev_mutate : ('a,'b,'c) t -> ('c -> 'b -> 'b) -> unit
+
+(* Pops the specified number of elements off of the undo stack, *
+  reinstating the last popped element. The undo stack is independently
+  managed for each range element. *)
+val undo : ('a,'b,'c) t -> int -> unit
+
+val create : ('a,'b,'c) t -> 'a * 'b * 'c * int -> unit
+val delete : ('a,'b,'c) t -> 'a -> unit
+
+val dom : ('a,'b,'c) t -> 'a list
+
+val clear : ('a,'b,'c) t -> unit
diff --git a/lib/explore.ml b/lib/explore.ml
new file mode 100644
index 00000000..2eaabef8
--- /dev/null
+++ b/lib/explore.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        *)
+(************************************************************************)
+
+(*i $Id: explore.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+open Format
+
+(*s Definition of a search problem. *)
+
+module type SearchProblem = sig
+  type state
+  val branching : state -> state list
+  val success : state -> bool
+  val pp : state -> unit
+end
+
+module Make = functor(S : SearchProblem) -> struct
+
+  type position = int list
+
+  let pp_position p = 
+    let rec pp_rec = function
+      | [] -> ()
+      | [i] -> printf "%d" i
+      | i :: l -> pp_rec l; printf ".%d" i
+    in
+    open_hbox (); pp_rec p; close_box ()
+
+  (*s Depth first search. *)
+
+  let rec depth_first s = 
+    if S.success s then s else depth_first_many (S.branching s)
+  and depth_first_many = function
+    | [] -> raise Not_found
+    | s :: l -> try depth_first s with Not_found -> depth_first_many l
+
+  let debug_depth_first s = 
+    let rec explore p s =
+      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
+      | s :: l -> 
+	  try explore (i::p) s with Not_found -> explore_many (succ i) p l
+    in
+    explore [1] s
+
+  (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
+
+  type 'a queue = 'a list * 'a list
+
+  exception Empty
+
+  let empty = [],[]
+
+  let push x (h,t) = (x::h,t)
+
+  let pop = function
+    | h, x::t -> x, (h,t)
+    | h, [] -> match List.rev h with x::t -> x, ([],t) | [] -> raise Empty
+
+  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
+    and enqueue q = function
+      | [] -> explore q
+      | s :: l -> if S.success s then s else enqueue (push s q) l
+    in
+    enqueue empty [s]
+
+  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
+    and enqueue i p q = function
+      | [] -> 
+	  explore q
+      | s :: l ->
+	  let ps = i::p in 
+	  pp_position ps; S.pp s;
+	  if S.success s then s else enqueue (succ i) p (push (ps,s) q) l
+    in
+    enqueue 1 [] empty [s]
+
+end
diff --git a/lib/explore.mli b/lib/explore.mli
new file mode 100644
index 00000000..1236f06b
--- /dev/null
+++ b/lib/explore.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: explore.mli,v 1.2.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+(*s Search strategies. *)
+
+(*s A search problem implements the following signature [SearchProblem].
+    [state] is the type of states of the search tree.
+    [branching] is the branching function; if [branching s] returns an 
+    empty list, then search from [s] is aborted; successors of [s] are
+    recursively searched in the order they appear in the list.
+    [success] determines whether a given state is a success. 
+
+    [pp] is a pretty-printer for states used in debugging versions of the 
+    search functions. *)
+
+module type SearchProblem = sig
+
+  type state
+
+  val branching : state -> state list
+
+  val success : state -> bool
+
+  val pp : state -> unit
+
+end
+
+(*s Functor [Make] returns some search functions given a search problem.
+    Search functions raise [Not_found] if no success is found. 
+    States are always visited in the order they appear in the
+    output of [branching] (whatever the search method is).
+    Debugging versions of the search functions print the position of the
+    visited state together with the state it-self (using [S.pp]). *)
+
+module Make : functor(S : SearchProblem) -> sig
+
+  val depth_first : S.state -> S.state
+  val debug_depth_first : S.state -> S.state
+
+  val breadth_first : S.state -> S.state
+  val debug_breadth_first : S.state -> S.state
+
+end
diff --git a/lib/gmap.ml b/lib/gmap.ml
new file mode 100644
index 00000000..e5d41034
--- /dev/null
+++ b/lib/gmap.ml
@@ -0,0 +1,125 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gmap.ml,v 1.3.16.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+(* Maps using the generic comparison function of ocaml. Code borrowed from
+   the ocaml standard library. *)
+
+    type ('a,'b) t =
+        Empty
+      | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int
+
+    let empty = Empty
+
+    let height = function
+        Empty -> 0
+      | Node(_,_,_,_,h) -> h
+
+    let create l x d r =
+      let hl = height l and hr = height r in
+      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let bal l x d r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Map.bal"
+        | Node(ll, lv, ld, lr, _) ->
+            if height ll >= height lr then
+              create ll lv ld (create lr x d r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Map.bal"
+              | Node(lrl, lrv, lrd, lrr, _)->
+                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Map.bal"
+        | Node(rl, rv, rd, rr, _) ->
+            if height rr >= height rl then
+              create (create l x d rl) rv rd rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Map.bal"
+              | Node(rll, rlv, rld, rlr, _) ->
+                  create (create l x d rll) rlv rld (create rlr rv rd rr)
+            end
+      end else
+        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    let rec add x data = function
+        Empty ->
+          Node(Empty, x, data, Empty, 1)
+      | Node(l, v, d, r, h) as t ->
+          let c = Pervasives.compare x v in
+          if c = 0 then
+            Node(l, x, data, r, h)
+          else if c < 0 then
+            bal (add x data l) v d r
+          else
+            bal l v d (add x data r)
+
+    let rec find x = function
+        Empty ->
+          raise Not_found
+      | Node(l, v, d, r, _) ->
+          let c = Pervasives.compare x v in
+          if c = 0 then d
+          else find x (if c < 0 then l else r)
+
+    let rec mem x = function
+        Empty ->
+          false
+      | Node(l, v, d, r, _) ->
+          let c = Pervasives.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec 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 rec remove x = function
+        Empty ->
+          Empty
+      | Node(l, v, d, r, h) as t ->
+          let c = Pervasives.compare x v in
+          if c = 0 then
+            merge l r
+          else if c < 0 then
+            bal (remove x l) v d r
+          else
+            bal l v d (remove x r)
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, d, r, _) ->
+          iter f l; f v d; iter f r
+
+    let rec map f = function
+        Empty               -> Empty
+      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
+
+    let rec fold f m accu =
+      match m with
+        Empty -> accu
+      | Node(l, v, d, r, _) ->
+          fold f l (f v d (fold f r accu))
+
+(* Added with respect to ocaml standard library. *)
+
+    let dom m = fold (fun x _ acc -> x::acc) m []
+
+    let rng m = fold (fun _ y acc -> y::acc) m []
+
+    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
+
diff --git a/lib/gmap.mli b/lib/gmap.mli
new file mode 100644
index 00000000..7415a395
--- /dev/null
+++ b/lib/gmap.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gmap.mli,v 1.4.16.1 2004/07/16 19:30:29 herbelin Exp $ i*)
+
+(* Maps using the generic comparison function of ocaml. Same interface as
+   the module [Map] from the ocaml standard library. *)
+
+type ('a,'b) t
+
+val empty : ('a,'b) t
+val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+val find : 'a -> ('a,'b) t -> 'b
+val remove : 'a -> ('a,'b) t -> ('a,'b) t
+val mem :  'a -> ('a,'b) t -> bool
+val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
+val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
+val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
+
+(* Additions with respect to ocaml standard library. *)
+
+val dom : ('a,'b) t -> 'a list
+val rng : ('a,'b) t -> 'b list
+val to_list : ('a,'b) t -> ('a * 'b) list
diff --git a/lib/gmapl.ml b/lib/gmapl.ml
new file mode 100644
index 00000000..dcb2eb94
--- /dev/null
+++ b/lib/gmapl.ml
@@ -0,0 +1,35 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gmapl.ml,v 1.2.16.1 2004/07/16 19:30:29 herbelin Exp $ *)
+
+open Util
+
+type ('a,'b) t = ('a,'b list) Gmap.t
+
+let empty = Gmap.empty
+let mem = Gmap.mem
+let iter = Gmap.iter
+let map = Gmap.map
+let fold = Gmap.fold
+
+let add x y m =
+  try
+    let l = Gmap.find x m in
+    Gmap.add x (if List.mem y l then l else y::l) m
+  with Not_found ->
+    Gmap.add x [y] m
+
+let find x m =
+  try Gmap.find x m with Not_found -> []
+
+let remove x y m =
+  let l = Gmap.find x m in
+  Gmap.add x (if List.mem y l then list_subtract l [y] else l) m
+
+  
diff --git a/lib/gmapl.mli b/lib/gmapl.mli
new file mode 100644
index 00000000..f8855ae4
--- /dev/null
+++ b/lib/gmapl.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gmapl.mli,v 1.4.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+
+(* Maps from ['a] to lists of ['b]. *)
+
+type ('a,'b) t
+
+val empty : ('a,'b) t
+val mem :  'a -> ('a,'b) t -> bool
+val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit
+val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t
+val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
+
+val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+val find : 'a -> ('a,'b) t -> 'b list
+val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
diff --git a/lib/gset.ml b/lib/gset.ml
new file mode 100644
index 00000000..5ea2f82b
--- /dev/null
+++ b/lib/gset.ml
@@ -0,0 +1,242 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gset.ml,v 1.2.16.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+(* Sets using the generic comparison function of ocaml. Code borrowed from
+   the ocaml standard library. *)
+
+    type 'a t = Empty | Node of 'a t * 'a * 'a t * int
+
+    (* Sets are represented by balanced binary trees (the heights of the
+       children differ by at most 2 *)
+
+    let height = function
+        Empty -> 0
+      | Node(_, _, _, h) -> h
+
+    (* Creates a new node with left son l, value x and right son r.
+       l and r must be balanced and | height l - height r | <= 2.
+       Inline expansion of height for better speed. *)
+
+    let create l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as create, but performs one step of rebalancing if necessary.
+       Assumes l and r balanced.
+       Inline expansion of create for better speed in the most frequent case
+       where no rebalancing is required. *)
+
+    let bal l x r =
+      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      if hl > hr + 2 then begin
+        match l with
+          Empty -> invalid_arg "Set.bal"
+        | Node(ll, lv, lr, _) ->
+            if height ll >= height lr then
+              create ll lv (create lr x r)
+            else begin
+              match lr with
+                Empty -> invalid_arg "Set.bal"
+              | Node(lrl, lrv, lrr, _)->
+                  create (create ll lv lrl) lrv (create lrr x r)
+            end
+      end else if hr > hl + 2 then begin
+        match r with
+          Empty -> invalid_arg "Set.bal"
+        | Node(rl, rv, rr, _) ->
+            if height rr >= height rl then
+              create (create l x rl) rv rr
+            else begin
+              match rl with
+                Empty -> invalid_arg "Set.bal"
+              | Node(rll, rlv, rlr, _) ->
+                  create (create l x rll) rlv (create rlr rv rr)
+            end
+      end else
+        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+    (* Same as bal, but repeat rebalancing until the final result
+       is balanced. *)
+
+    let rec join l x r =
+      match bal l x r with
+        Empty -> invalid_arg "Set.join"
+      | Node(l', x', r', _) as t' ->
+          let d = height l' - height r' in
+          if d < -2 or d > 2 then join l' x' r' else t'
+
+    (* Merge two trees l and r into one.
+       All elements of l must precede the elements of r.
+       Assumes | height l - height r | <= 2. *)
+
+    let rec merge t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+    (* Same as merge, but does not assume anything about l and r. *)
+
+    let rec concat t1 t2 =
+      match (t1, t2) with
+        (Empty, t) -> t
+      | (t, Empty) -> t
+      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+          join l1 v1 (join (concat r1 l2) v2 r2)
+
+    (* Splitting *)
+
+    let rec split x = function
+        Empty ->
+          (Empty, None, Empty)
+      | Node(l, v, r, _) ->
+          let c = Pervasives.compare x v in
+          if c = 0 then (l, Some v, r)
+          else if c < 0 then
+            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+          else
+            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+    (* Implementation of the set operations *)
+
+    let empty = Empty
+
+    let is_empty = function Empty -> true | _ -> false
+
+    let rec mem x = function
+        Empty -> false
+      | Node(l, v, r, _) ->
+          let c = Pervasives.compare x v in
+          c = 0 || mem x (if c < 0 then l else r)
+
+    let rec add x = function
+        Empty -> Node(Empty, x, Empty, 1)
+      | Node(l, v, r, _) as t ->
+          let c = Pervasives.compare x v in
+          if c = 0 then t else
+          if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    let rec remove x = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let c = Pervasives.compare x v in
+          if c = 0 then merge l r else
+          if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+    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
+
+    let rec inter s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> Empty
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              concat (inter l1 l2) (inter r1 r2)
+          | (l2, Some _, r2) ->
+              join (inter l1 l2) v1 (inter r1 r2)
+
+    let rec diff s1 s2 =
+      match (s1, s2) with
+        (Empty, t2) -> Empty
+      | (t1, Empty) -> t1
+      | (Node(l1, v1, r1, _), t2) ->
+          match split v1 t2 with
+            (l2, None, r2) ->
+              join (diff l1 l2) v1 (diff r1 r2)
+          | (l2, Some _, r2) ->
+              concat (diff l1 l2) (diff r1 r2)
+
+    let rec compare_aux l1 l2 =
+        match (l1, l2) with
+        ([], []) -> 0
+      | ([], _)  -> -1
+      | (_, []) -> 1
+      | (Empty :: t1, Empty :: t2) ->
+          compare_aux t1 t2
+      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+          let c = compare v1 v2 in
+          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+      | (Node(l1, v1, r1, _) :: t1, t2) ->
+          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
+      | (t1, Node(l2, v2, r2, _) :: t2) ->
+          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+
+    let compare s1 s2 =
+      compare_aux [s1] [s2]
+
+    let equal s1 s2 =
+      compare s1 s2 = 0
+
+    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 = Pervasives.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
+
+    let rec iter f = function
+        Empty -> ()
+      | Node(l, v, r, _) -> iter f l; f v; iter f r
+
+    let rec fold f s accu =
+      match s with
+        Empty -> accu
+      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
+
+    let rec cardinal = function
+        Empty -> 0
+      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+    let rec elements_aux accu = function
+        Empty -> accu
+      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+    let elements s =
+      elements_aux [] s
+
+    let rec min_elt = function
+        Empty -> raise Not_found
+      | Node(Empty, v, r, _) -> v
+      | Node(l, v, r, _) -> min_elt l
+
+    let rec max_elt = function
+        Empty -> raise Not_found
+      | Node(l, v, Empty, _) -> v
+      | Node(l, v, r, _) -> max_elt r
+
+    let choose = min_elt
diff --git a/lib/gset.mli b/lib/gset.mli
new file mode 100644
index 00000000..32d798cc
--- /dev/null
+++ b/lib/gset.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gset.mli,v 1.3.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+
+(* Sets using the generic comparison function of ocaml. Same interface as
+   the module [Set] from the ocaml standard library. *)
+
+type 'a t
+
+val empty : 'a t
+val is_empty : 'a t -> bool
+val mem : 'a -> 'a t -> bool
+val add : 'a -> 'a t -> 'a t
+val singleton : 'a -> 'a t
+val remove : 'a -> 'a t -> 'a t
+val union : 'a t -> 'a t -> 'a t
+val inter : 'a t -> 'a t -> 'a t
+val diff : 'a t -> 'a t -> 'a t
+val compare : 'a t -> 'a t -> int
+val equal : 'a t -> 'a t -> bool
+val subset : 'a t -> 'a t -> bool
+val iter : ('a -> unit) -> 'a t -> unit
+val fold : ('a -> 'a -> 'a) -> 'a t -> 'a -> 'a
+val cardinal : 'a t -> int
+val elements : 'a t -> 'a list
+val min_elt : 'a t -> 'a
+val max_elt : 'a t -> 'a
+val choose : 'a t -> 'a
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
new file mode 100644
index 00000000..5f083459
--- /dev/null
+++ b/lib/hashcons.ml
@@ -0,0 +1,199 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: hashcons.ml,v 1.3.16.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+(* Hash consing of datastructures *)
+
+(* The generic hash-consing functions (does not use Obj) *)
+
+(* [t] is the type of object to hash-cons
+ * [u] is the type of hash-cons functions for the sub-structures
+ *   of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...).
+ * [hash_sub u x] is a function that hash-cons the sub-structures of x using
+ *   the hash-consing functions u provides.
+ * [equal] is a comparison function. It is allowed to use physical equality
+ *   on the sub-terms hash-consed by the hash_sub function.
+ * [hash] is the hash function given to the Hashtbl.Make function 
+ *
+ * Note that this module type coerces to the argument of Hashtbl.Make.
+ *)
+
+module type Comp =
+  sig
+    type t
+    type u
+    val hash_sub :  u -> t -> t
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+(* The output is a function f such that
+ * [f ()] has the side-effect of creating (internally) a hash-table of the
+ *   hash-consed objects. The result is a function taking the sub-hashcons
+ *   functions and an object, and hashcons it. It does not really make sense
+ *   to call f() with different sub-hcons functions. That's why we use the
+ *   wrappers simple_hcons, recursive_hcons, ... The latter just take as
+ *   argument the sub-hcons functions (the tables are created at that moment),
+ *   and returns the hcons function for t.
+ *)
+
+module type S =
+  sig
+    type t
+    type u
+    val f : unit -> (u -> t -> t)
+  end
+
+module Make(X:Comp) =
+  struct
+    type t = X.t
+    type u = X.u
+
+    (* We create the type of hashtables for t, with our comparison fun.
+     * An invariant is that the table never contains two entries equals
+     * w.r.t (=), although the equality on keys is X.equal. This is
+     * granted since we hcons the subterms before looking up in the table.
+     *)
+    module Htbl = Hashtbl.Make(
+      struct type t=X.t
+             type u=X.u
+             let hash=X.hash
+             let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2
+      end)
+
+    (* The table is created when () is applied.
+     * Hashconsing is then very simple:
+     *  1- hashcons the subterms using hash_sub and u
+     *  2- look up in the table, if we do not get a hit, we add it
+     *)
+    let f () =
+      let tab = Htbl.create 97 in
+        (fun u x ->
+           let y = X.hash_sub u x in
+            (* incr acces;*)
+             try let r = Htbl.find tab y in(* incr succes;*) r
+             with Not_found -> Htbl.add tab y y; y)
+  end
+
+(* A few usefull wrappers:
+ * takes as argument the function f above and build a function of type
+ * u -> t -> t that creates a fresh table each time it is applied to the
+ * sub-hcons functions. *)
+
+(* For non-recursive types it is quite easy. *)
+let simple_hcons h u = h () u
+
+(* For a recursive type T, we write the module of sig Comp with u equals
+ * to (T -> T) * u0
+ * The first component will be used to hash-cons the recursive subterms
+ * The second one to hashcons the other sub-structures.
+ * We just have to take the fixpoint of h
+ *)
+let recursive_hcons h u =
+  let hc = h () in
+  let rec hrec x = hc (hrec,u) x in
+  hrec
+
+(* If the structure may contain loops, use this one. *)
+let recursive_loop_hcons h u =
+  let hc = h () in
+  let rec hrec visited x =
+    if List.memq x visited then x
+    else hc (hrec (x::visited),u) x
+  in 
+  hrec []
+
+(* For 2 mutually recursive types *)
+let recursive2_hcons h1 h2 u1 u2 =
+  let hc1 = h1 () in
+  let hc2 = h2 () in
+  let rec hrec1 x = hc1 (hrec1,hrec2,u1) x
+  and hrec2 x = hc2 (hrec1,hrec2,u2) x
+  in (hrec1,hrec2)
+
+(* A set of global hashcons functions *)
+let hashcons_resets = ref []
+let init() = List.iter (fun f -> f()) !hashcons_resets
+
+(* [register_hcons h u] registers the hcons function h, result of the above
+ *   wrappers. It returns another hcons function that always uses the same
+ *   table, which can be reinitialized by init()
+ *)
+let register_hcons h u =
+  let hf = ref (h u) in
+  let reset() = hf := h u in
+  hashcons_resets := reset :: !hashcons_resets;
+  (fun x -> !hf x)
+
+(* Basic hashcons modules for string and obj. Integers do not need be
+   hashconsed.  *)
+
+(* string *)
+module Hstring = Make(
+  struct
+    type t = string
+    type u = unit
+    let hash_sub () s =(* incr accesstr;*) s
+    let equal s1 s2 =(* incr comparaisonstr;
+      if*) s1=s2(* then (incr successtr; true) else false*)
+    let hash = Hashtbl.hash
+  end)
+
+(* Obj.t *)
+exception NotEq
+
+(* From CAMLLIB/caml/mlvalues.h *)
+let no_scan_tag = 251
+let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag)
+
+let comp_obj o1 o2 =
+  if tuple_p o1 & tuple_p o2 then
+    let n1 = Obj.size o1 and n2 = Obj.size o2 in
+      if n1=n2 then
+        try
+          for i = 0 to pred n1 do
+            if not (Obj.field o1 i == Obj.field o2 i) then raise NotEq
+          done; true
+        with NotEq -> false
+      else false
+  else o1=o2
+
+let hash_obj hrec o = 
+  begin
+    if tuple_p o then
+      let n = Obj.size o in
+        for i = 0 to pred n do
+          Obj.set_field o i (hrec (Obj.field o i))
+        done
+  end;
+  o
+
+module Hobj = Make(
+  struct
+    type t = Obj.t
+    type u = (Obj.t -> Obj.t) * unit
+    let hash_sub (hrec,_) = hash_obj hrec
+    let equal = comp_obj
+    let hash = Hashtbl.hash
+  end)
+
+(* Hashconsing functions for string and obj. Always use the same
+ * global tables. The latter can be reinitialized with init()
+ *)
+(* string : string -> string *)
+(* obj : Obj.t -> Obj.t *)
+let string = register_hcons (simple_hcons Hstring.f) ()
+let obj = register_hcons (recursive_hcons Hobj.f) ()
+
+(* The unsafe polymorphic hashconsing function *)
+let magic_hash (c : 'a) =
+  init();
+  let r = obj (Obj.repr c) in
+  init();
+  (Obj.magic r : 'a)
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
new file mode 100644
index 00000000..2e32323a
--- /dev/null
+++ b/lib/hashcons.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: hashcons.mli,v 1.5.16.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+
+(* Generic hash-consing. *)
+
+module type Comp =
+  sig
+    type t
+    type u
+    val hash_sub :  u -> t -> t
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+module type S =
+  sig
+    type t
+    type u
+    val f : unit -> (u -> t -> t)
+  end
+
+module Make(X:Comp) : (S with type t = X.t and type u = X.u)
+
+val simple_hcons : (unit -> 'u -> 't -> 't) -> ('u -> 't -> 't)
+val recursive_hcons : (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
+val recursive_loop_hcons :
+    (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
+val recursive2_hcons :
+  (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u1 -> 't1 -> 't1) ->
+    (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) ->
+      'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2)
+
+(* Declaring and reinitializing global hash-consing functions *)
+
+val init : unit -> unit
+val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't)
+
+module Hstring : (S with type t = string and type u = unit)
+module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+
+val string : string -> string
+val obj : Obj.t -> Obj.t
+
+val magic_hash : 'a -> 'a
+
diff --git a/lib/heap.ml b/lib/heap.ml
new file mode 100644
index 00000000..f0db2943
--- /dev/null
+++ b/lib/heap.ml
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: heap.ml,v 1.1.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+(*s Heaps *)
+
+module type Ordered = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S =sig
+  
+  (* Type of functional heaps *)
+  type t
+
+  (* Type of elements *)
+  type elt
+    
+  (* The empty heap *)
+  val empty : t
+    
+  (* [add x h] returns a new heap containing the elements of [h], plus [x];
+     complexity $O(log(n))$ *)
+  val add : elt -> t -> t
+    
+  (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap]
+     when [h] is empty; complexity $O(1)$ *)
+  val maximum : t -> elt
+    
+  (* [remove h] returns a new heap containing the elements of [h], except
+     the maximum of [h]; raises [EmptyHeap] when [h] is empty; 
+     complexity $O(log(n))$ *) 
+  val remove : t -> t
+    
+  (* usual iterators and combinators; elements are presented in
+     arbitrary order *)
+  val iter : (elt -> unit) -> t -> unit
+    
+  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    
+end
+
+exception EmptyHeap
+
+(*s Functional implementation *)
+
+module Functional(X : Ordered) = struct
+
+  (* Heaps are encoded as complete binary trees, i.e., binary trees
+     which are full expect, may be, on the bottom level where it is filled 
+     from the left. 
+     These trees also enjoy the heap property, namely the value of any node 
+     is greater or equal than those of its left and right subtrees.
+
+     There are 4 kinds of complete binary trees, denoted by 4 constructors:
+     [FFF] for a full binary tree (and thus 2 full subtrees);
+     [PPF] for a partial tree with a partial left subtree and a full
+     right subtree;
+     [PFF] for a partial tree with a full left subtree and a full right subtree
+     (but of different heights);
+     and [PFP] for a partial tree with a full left subtree and a partial
+     right subtree. *)
+
+  type t = 
+    | Empty
+    | FFF of t * X.t * t (* full    (full,    full) *)
+    | PPF of t * X.t * t (* partial (partial, full) *)
+    | PFF of t * X.t * t (* partial (full,    full) *)
+    | PFP of t * X.t * t (* partial (full,    partial) *)
+
+  type elt = X.t
+
+  let empty = Empty
+ 
+  (* smart constructors for insertion *)
+  let p_f l x r = match l with
+    | Empty | FFF _ -> PFF (l, x, r)
+    | _ -> PPF (l, x, r)
+
+  let pf_ l x = function
+    | Empty | FFF _ as r -> FFF (l, x, r)
+    | r -> PFP (l, x, r)
+
+  let rec add x = function
+    | Empty -> 
+	FFF (Empty, x, Empty)
+    (* insertion to the left *)
+    | FFF (l, y, r) | PPF (l, y, r) ->
+	if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r
+    (* insertion to the right *)
+    | PFF (l, y, r) | PFP (l, y, r) ->
+	if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r)
+
+  let maximum = function
+    | Empty -> raise EmptyHeap
+    | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x
+
+  (* smart constructors for removal; note that they are different
+     from the ones for insertion! *)
+  let p_f l x r = match l with
+    | Empty | FFF _ -> FFF (l, x, r)
+    | _ -> PPF (l, x, r)
+
+  let pf_ l x = function
+    | Empty | FFF _ as r -> PFF (l, x, r)
+    | r -> PFP (l, x, r)
+
+  let rec remove = function
+    | Empty -> 
+	raise EmptyHeap
+    | FFF (Empty, _, Empty) -> 
+	Empty
+    | PFF (l, _, Empty) ->
+	l
+    (* remove on the left *)
+    | PPF (l, x, r) | PFF (l, x, r) ->
+        let xl = maximum l in
+	let xr = maximum r in
+	let l' = remove l in
+	if X.compare xl xr >= 0 then 
+	  p_f l' xl r 
+	else 
+	  p_f l' xr (add xl (remove r))
+    (* remove on the right *)
+    | FFF (l, x, r) | PFP (l, x, r) ->
+        let xl = maximum l in
+	let xr = maximum r in
+	let r' = remove r in
+	if X.compare xl xr > 0 then 
+	  pf_ (add xr (remove l)) xl r'
+	else 
+	  pf_ l xr r'
+
+  let rec iter f = function
+    | Empty -> 
+	()
+    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 
+	iter f l; f x; iter f r
+
+  let rec fold f h x0 = match h with
+    | Empty -> 
+	x0
+    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> 
+	fold f l (fold f r (f x x0))
+
+end
diff --git a/lib/heap.mli b/lib/heap.mli
new file mode 100644
index 00000000..c865461e
--- /dev/null
+++ b/lib/heap.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: heap.mli,v 1.1.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+(* Heaps *)
+
+module type Ordered = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S =sig
+  
+  (* Type of functional heaps *)
+  type t
+
+  (* Type of elements *)
+  type elt
+    
+  (* The empty heap *)
+  val empty : t
+    
+  (* [add x h] returns a new heap containing the elements of [h], plus [x];
+     complexity $O(log(n))$ *)
+  val add : elt -> t -> t
+    
+  (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap]
+     when [h] is empty; complexity $O(1)$ *)
+  val maximum : t -> elt
+    
+  (* [remove h] returns a new heap containing the elements of [h], except
+     the maximum of [h]; raises [EmptyHeap] when [h] is empty; 
+     complexity $O(log(n))$ *) 
+  val remove : t -> t
+    
+  (* usual iterators and combinators; elements are presented in
+     arbitrary order *)
+  val iter : (elt -> unit) -> t -> unit
+    
+  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    
+end
+
+exception EmptyHeap
+
+(*S Functional implementation. *)
+
+module Functional(X: Ordered) : S with type elt=X.t
diff --git a/lib/options.ml b/lib/options.ml
new file mode 100644
index 00000000..b5c5efda
--- /dev/null
+++ b/lib/options.ml
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: options.ml,v 1.27.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+open Util
+
+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 boot = ref false
+
+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 term_quality = ref false
+
+let xml_export = ref false
+
+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 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
+
+(* Silent / Verbose *)
+let silent = ref false
+let make_silent flag = silent := flag; ()
+let is_silent () = !silent
+let is_verbose () = not !silent
+
+let silently f x =
+  let oldsilent = !silent in
+  try 
+    silent := true;
+    let rslt = f x in
+    silent := oldsilent; 
+    rslt
+  with e -> begin
+    silent := oldsilent; raise e
+  end
+
+let if_silent f x = if !silent then f x
+let if_verbose f x = if not !silent then f x
+
+(* The number of printed hypothesis in a goal *)
+
+let print_hyps_limit = ref (None : int option)
+let set_print_hyps_limit n = print_hyps_limit := n
+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
+let dump_file = ref ""
+let dump_into_file f = dump := true; dump_file := f
+
+let dump_buffer = Buffer.create 8192
+
+let dump_string = Buffer.add_string dump_buffer
+
+let dump_it () = 
+  if !dump then begin
+    let mode = [Open_wronly; Open_append; Open_creat] in
+    let c = open_out_gen mode 0o666 !dump_file in
+    output_string c (Buffer.contents dump_buffer);
+    close_out c
+  end
+
+let _ = at_exit dump_it
diff --git a/lib/options.mli b/lib/options.mli
new file mode 100644
index 00000000..731b7da4
--- /dev/null
+++ b/lib/options.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: options.mli,v 1.25.2.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+
+(* Global options of the system. *)
+
+val boot : bool ref
+
+val batch_mode : bool ref
+
+val debug : bool ref
+
+val print_emacs : bool ref
+val emacs_str : string -> string
+
+val term_quality : bool ref
+
+val xml_export : bool ref
+
+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
+val is_verbose : unit -> bool
+val silently : ('a -> 'b) -> 'a -> 'b
+val if_silent : ('a -> unit) -> 'a -> unit
+val if_verbose : ('a -> unit) -> 'a -> unit
+
+(* Temporary activate an option ('c must be an atomic type) *)
+val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
+
+(* If [None], no limit *)
+val set_print_hyps_limit : int option -> unit
+val print_hyps_limit : unit -> int option
+
+val add_unsafe : string -> unit
+val is_unsafe : string -> bool
+
+(* Dump of globalization (to be used by coqdoc) *)
+
+val dump : bool ref
+val dump_into_file : string -> unit
+val dump_string : string -> unit
+
diff --git a/lib/pp.ml4 b/lib/pp.ml4
new file mode 100644
index 00000000..25ab9ce8
--- /dev/null
+++ b/lib/pp.ml4
@@ -0,0 +1,287 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pp.ml4,v 1.5.2.1 2004/07/16 19:30:30 herbelin Exp $ *)
+
+open Pp_control
+
+(* The different kinds of blocks are: 
+   \begin{description}
+   \item[hbox:] Horizontal block no line breaking;
+   \item[vbox:] Vertical block each break leads to a new line;
+   \item[hvbox:] Horizontal-vertical block: same as vbox, except if
+      this block is small enough to fit on a single line
+   \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
+      only when necessary to print the content of the block
+   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
+      (except if no mark yet on the reste of the line)
+   \end{description}
+ *)
+ 
+let comments = ref []
+  
+let rec split_com comacc acc pos = function
+    [] -> comments := List.rev acc; comacc
+  | ((b,e),c as com)::coms ->
+      (* Take all comments that terminates before pos, or begin exactly
+         at pos (used to print comments attached after an expression) *)
+      if e<=pos || pos=b then split_com (c::comacc) acc pos coms
+      else  split_com comacc (com::acc) pos coms
+
+
+type block_type =
+  | Pp_hbox of int
+  | Pp_vbox of int
+  | Pp_hvbox of int
+  | Pp_hovbox of int
+  | Pp_tbox
+
+type 'a ppcmd_token =
+  | Ppcmd_print of 'a
+  | Ppcmd_box of block_type * ('a ppcmd_token Stream.t)
+  | Ppcmd_print_break of int * int
+  | Ppcmd_set_tab
+  | Ppcmd_print_tbreak of int * int
+  | Ppcmd_white_space of int
+  | Ppcmd_force_newline
+  | Ppcmd_print_if_broken
+  | Ppcmd_open_box of block_type
+  | Ppcmd_close_box
+  | Ppcmd_close_tbox
+  | Ppcmd_comment of int
+
+type 'a ppdir_token =
+  | Ppdir_ppcmds of 'a ppcmd_token Stream.t
+  | Ppdir_print_newline
+  | Ppdir_print_flush
+
+type ppcmd = (int*string) ppcmd_token
+
+type std_ppcmds = ppcmd Stream.t
+
+type 'a ppdirs = 'a ppdir_token Stream.t
+
+(* Compute length of an UTF-8 encoded string
+   Rem 1 : utf8_length <= String.length (equal if pure ascii)
+   Rem 2 : if used for an iso8859_1 encoded string, the result is
+   wrong in very rare cases. Such a wrong case corresponds to any
+   sequence of a character in range 192..253 immediately followed by a
+   character in range 128..191 (typical case in french is "déçu" which
+   is counted 3 instead of 4); then no real harm to use always
+   utf8_length even if using an iso8859_1 encoding *)
+
+let utf8_length s =
+  let len = String.length s
+  and cnt = ref 0
+  and nc = ref 0
+  and p = ref 0 in
+  while !p < len do
+    begin
+      match s.[!p] with
+      | '\000'..'\127' -> nc := 0 (* ascii char *)
+      | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
+      |	'\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
+      |	'\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
+      |	'\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
+      |	'\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
+      |	'\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
+      |	'\254'..'\255' -> nc := 0 (* invalid byte *)
+    end ;
+    incr p ;
+    while !p < len && !nc > 0 do
+      match s.[!p] with
+      |	'\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
+      |	_ (* not a continuation byte *) -> nc := 0
+    done ;
+    incr cnt
+  done ;
+  !cnt
+
+(* formatting commands *)
+let str s = [< 'Ppcmd_print (utf8_length s,s) >]
+let stras (i,s) = [< 'Ppcmd_print (i,s) >]
+let brk (a,b) = [< 'Ppcmd_print_break (a,b) >]
+let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >]
+let tab () = [< 'Ppcmd_set_tab >]
+let fnl () = [< 'Ppcmd_force_newline >]
+let pifb () = [< 'Ppcmd_print_if_broken >]
+let ws n = [< 'Ppcmd_white_space n >]
+let comment n = [< ' Ppcmd_comment n >]
+
+(* derived commands *)
+let mt () = [< >]
+let spc () = [< 'Ppcmd_print_break (1,0) >]
+let cut () = [< 'Ppcmd_print_break (0,0) >]
+let align () = [< 'Ppcmd_print_break (0,0) >]
+let int n = str (string_of_int n)
+let real r = str (string_of_float r)
+let bool b = str (string_of_bool b)
+
+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
+      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 qs = qstring
+
+(* boxing commands *)
+let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >]
+let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >]
+let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >]
+let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >]
+let t s = [< 'Ppcmd_box(Pp_tbox,s) >]
+
+(* Opening and closing of boxes *)
+let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >]
+let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >]
+let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >]
+let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >]
+let tb () = [< 'Ppcmd_open_box Pp_tbox >]
+let close () = [< 'Ppcmd_close_box >]
+let tclose () = [< 'Ppcmd_close_tbox >]
+
+let (++) = Stream.iapp
+
+(* This flag tells if the last printed comment ends with a newline, to
+  avoid empty lines *)
+let com_eol = ref false
+
+let com_brk ft = com_eol := false
+let com_if ft f =
+  if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
+  else Lazy.force f
+
+let rec pr_com ft s =
+  let (s1,os) =
+    try
+      let n = String.index s '\n' in
+      String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
+    with Not_found -> s,None in
+  com_if ft (Lazy.lazy_from_val());
+(*  let s1 =
+    if String.length s1 <> 0 && s1.[0] = ' ' then
+      (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
+    else s1 in*)
+  Format.pp_print_as ft (utf8_length s1) s1;
+  match os with
+      Some s2 ->
+        if String.length s2 = 0 then (com_eol := true)
+        else
+          (Format.pp_force_newline ft (); pr_com ft s2)
+    | None -> ()
+
+(* 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
+    | Pp_hvbox n  -> Format.pp_open_hvbox ft n
+    | Pp_hovbox n -> Format.pp_open_hovbox ft n
+    | Pp_tbox     -> Format.pp_open_tbox ft () 
+  in
+  let rec pp_cmd = function
+    | Ppcmd_print(n,s)        ->
+        com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
+        com_if ft (Lazy.lazy_from_val());
+        pp_open_box bty ;
+        if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss;
+        Format.pp_close_box ft ()
+    | Ppcmd_open_box bty      -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
+    | Ppcmd_close_box         -> Format.pp_close_box ft ()
+    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
+    | Ppcmd_white_space n     ->
+        com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
+    | Ppcmd_print_break(m,n)  ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
+    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
+    | Ppcmd_print_tbreak(m,n) ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
+    | Ppcmd_force_newline     ->
+        com_brk ft; Format.pp_force_newline ft ()
+    | Ppcmd_print_if_broken   ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
+    | Ppcmd_comment i         ->
+        let coms = split_com [] [] i !comments in
+(*        Format.pp_open_hvbox ft 0;*)
+        List.iter (pr_com ft) coms(*;
+        Format.pp_close_box ft ()*)
+  in
+  let pp_dir = function
+    | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream
+    | Ppdir_print_newline    ->
+        com_brk ft; Format.pp_print_newline ft ()
+    | Ppdir_print_flush      -> Format.pp_print_flush ft () 
+  in
+  fun dirstream ->
+    try  
+      Stream.iter pp_dir dirstream; com_brk ft
+    with 
+      | e -> Format.pp_print_flush ft () ; raise e
+
+
+(* pretty print on stdout and stderr *)
+
+let pp_std_dirs = pp_dirs !std_ft
+let pp_err_dirs = pp_dirs err_ft
+
+let ppcmds x = Ppdir_ppcmds x
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp_with ft strm =
+  pp_dirs ft [< 'Ppdir_ppcmds strm >]
+
+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 >]
+
+let warn_with ft pps =
+  ppnl_with ft [< str "Warning: " ; pps >]
+
+let pp_flush_with ft =
+  Format.pp_print_flush ft
+
+
+(* pretty printing functions WITH FLUSH *)
+let msg_with ft strm =
+  pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >]
+
+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>]; 
+		'Ppdir_print_newline >]
+
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp        x = pp_with !std_ft x
+let ppnl      x = ppnl_with !std_ft x
+let pperr     = pp_with err_ft
+let pperrnl   = ppnl_with err_ft
+let message s = ppnl (str s)
+let warning   x = warning_with err_ft x
+let warn      x = warn_with err_ft x
+let pp_flush  x = Format.pp_print_flush !std_ft x
+let flush_all() = flush stderr; flush stdout; pp_flush()
+
+(* pretty printing functions WITH FLUSH *)
+let msg x = msg_with !std_ft x
+let msgnl x = msgnl_with !std_ft x
+let msgerr = msg_with err_ft
+let msgerrnl = msgnl_with err_ft
+let msg_warning x = msg_warning_with err_ft x
diff --git a/lib/pp.mli b/lib/pp.mli
new file mode 100644
index 00000000..417ea107
--- /dev/null
+++ b/lib/pp.mli
@@ -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: pp.mli,v 1.8.2.1 2004/07/16 19:30:30 herbelin Exp $ i*)
+
+(*i*)
+open Pp_control
+(*i*)
+
+(* Pretty-printers. *)
+
+type ppcmd
+
+type std_ppcmds = ppcmd Stream.t
+
+(*s Formatting commands. *)
+
+val str  : string -> std_ppcmds
+val stras : int * string -> std_ppcmds
+val brk : int * int -> std_ppcmds
+val tbrk : int * int -> std_ppcmds
+val tab : unit -> std_ppcmds
+val fnl : unit -> std_ppcmds
+val pifb : unit -> std_ppcmds
+val ws : int -> std_ppcmds
+val mt : unit -> std_ppcmds
+
+val comment : int -> std_ppcmds
+val comments : ((int * int) * string) list ref
+
+(*s Concatenation. *)
+
+val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+
+(*s Derived commands. *)
+
+val spc : unit -> std_ppcmds
+val cut : unit -> std_ppcmds
+val align : unit -> std_ppcmds
+val int : int -> std_ppcmds
+val real : float -> std_ppcmds
+val bool : bool -> std_ppcmds
+val qstring : string -> std_ppcmds
+val qs : string -> std_ppcmds
+
+(*s Boxing commands. *)
+
+val h : int -> std_ppcmds -> std_ppcmds
+val v : int -> std_ppcmds -> std_ppcmds
+val hv : int -> std_ppcmds -> std_ppcmds
+val hov : int -> std_ppcmds -> std_ppcmds
+val t : std_ppcmds -> std_ppcmds
+
+(*s Opening and closing of boxes. *)
+
+val hb : int -> std_ppcmds
+val vb : int -> std_ppcmds
+val hvb : int -> std_ppcmds
+val hovb : int -> std_ppcmds
+val tb : unit -> std_ppcmds
+val close : unit -> std_ppcmds
+val tclose : unit -> std_ppcmds
+
+(*s Pretty-printing functions \emph{without flush}. *)
+
+val pp_with : Format.formatter -> std_ppcmds -> unit
+val ppnl_with : Format.formatter -> std_ppcmds -> unit
+val warning_with : Format.formatter -> string -> unit
+val warn_with : Format.formatter -> std_ppcmds -> unit
+val pp_flush_with : Format.formatter -> unit -> unit
+
+(*s Pretty-printing functions \emph{with flush}. *)
+
+val msg_with : Format.formatter -> std_ppcmds -> unit
+val msgnl_with : Format.formatter -> std_ppcmds -> unit
+
+
+(*s The following functions are instances of the previous ones on
+  [std_ft] and [err_ft]. *)
+
+(*s Pretty-printing functions \emph{without flush} on [stdout] and [stderr]. *)
+
+val pp : std_ppcmds -> unit
+val ppnl : std_ppcmds -> unit
+val pperr : std_ppcmds -> unit
+val pperrnl : std_ppcmds -> unit
+val message : string -> unit       (* = pPNL *)
+val warning : string -> unit
+val warn : std_ppcmds -> unit
+val pp_flush : unit -> unit
+val flush_all: unit -> unit
+
+(*s Pretty-printing functions \emph{with flush} on [stdout] and [stderr]. *)
+
+val msg : std_ppcmds -> unit
+val msgnl : std_ppcmds -> unit
+val msgerr : std_ppcmds -> unit
+val msgerrnl : std_ppcmds -> unit
+val msg_warning : std_ppcmds -> unit
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
new file mode 100644
index 00000000..85303f74
--- /dev/null
+++ b/lib/pp_control.ml
@@ -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        *)
+(************************************************************************)
+
+(* $Id: pp_control.ml,v 1.8.2.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+(* Parameters of pretty-printing *)
+
+type pp_global_params = {
+  margin : int;
+  max_indent : int;
+  max_depth : int;
+  ellipsis : string }
+
+(* Default parameters of pretty-printing *)
+
+let dflt_gp = { 
+  margin     = 78;
+  max_indent = 50;
+  max_depth  = 50;
+  ellipsis   = ".." }
+
+(* A deeper pretty-printer to print proof scripts *)
+
+let deep_gp = { 
+  margin     = 78;
+  max_indent = 50;
+  max_depth  = 10000;
+  ellipsis   = "..." }
+
+(* set_gp : Format.formatter -> pp_global_params -> unit
+ * set the parameters of a formatter *)
+
+let set_gp ft gp = 
+  Format.pp_set_margin ft gp.margin ;
+  Format.pp_set_max_indent ft gp.max_indent ;
+  Format.pp_set_max_boxes ft gp.max_depth ;
+  Format.pp_set_ellipsis_text ft gp.ellipsis
+
+let set_dflt_gp ft = set_gp ft dflt_gp 
+
+let get_gp ft =
+  { margin = Format.pp_get_margin ft ();
+    max_indent = Format.pp_get_max_indent ft ();
+    max_depth = Format.pp_get_max_boxes ft ();
+    ellipsis = Format.pp_get_ellipsis_text ft () }
+
+
+(* Output functions of pretty-printing *)
+
+type 'a pp_formatter_params = {
+  fp_output : out_channel ;
+  fp_output_function : string -> int -> int -> unit ;
+  fp_flush_function : unit -> unit }
+				
+(* Output functions for stdout and stderr *)
+
+let std_fp = {
+  fp_output = stdout ;
+  fp_output_function = output stdout;
+  fp_flush_function = (fun () -> flush stdout) }
+
+let err_fp = {
+  fp_output = stderr ;
+  fp_output_function = output stderr;
+  fp_flush_function = (fun () -> flush stderr) }
+
+(* with_fp : 'a pp_formatter_params -> Format.formatter 
+ * returns of formatter for given formatter functions *)
+
+let with_fp fp =
+  let ft = Format.make_formatter fp.fp_output_function fp.fp_flush_function in
+  Format.pp_set_formatter_out_channel ft fp.fp_output;
+  ft
+
+(* Output on a channel ch *)
+
+let with_output_to ch =
+  let ft = with_fp { fp_output = ch ;
+      	             fp_output_function = (output ch) ;
+	             fp_flush_function = (fun () -> flush ch) } in
+  set_gp ft deep_gp; 
+  ft
+
+let std_ft = ref Format.std_formatter
+let _ = set_dflt_gp !std_ft
+
+let err_ft = with_output_to stderr
+
+let deep_ft = with_output_to stdout
+let _ = set_gp deep_ft deep_gp
+
+(* For parametrization through vernacular *)
+let default = Format.pp_get_max_boxes !std_ft ()
+let default_margin = Format.pp_get_margin !std_ft ()
+
+let get_depth_boxes () = Some (Format.pp_get_max_boxes !std_ft ())
+let set_depth_boxes v =
+  Format.pp_set_max_boxes !std_ft (match v with None -> default | Some v -> v)
+
+let get_margin () = Some (Format.pp_get_margin !std_ft ())
+let set_margin v =
+  Format.pp_set_margin !std_ft (match v with None -> default_margin | Some v -> v)
+
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
new file mode 100644
index 00000000..3588847d
--- /dev/null
+++ b/lib/pp_control.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        *)
+(************************************************************************)
+
+(*i $Id: pp_control.mli,v 1.7.2.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+
+(* Parameters of pretty-printing. *)
+
+type pp_global_params = { 
+  margin : int;
+  max_indent : int;
+  max_depth : int;
+  ellipsis : string }
+
+val dflt_gp : pp_global_params
+val deep_gp : pp_global_params
+val set_gp : Format.formatter -> pp_global_params -> unit
+val set_dflt_gp : Format.formatter -> unit
+val get_gp : Format.formatter -> pp_global_params
+
+
+(*s Output functions of pretty-printing. *)
+
+type 'a pp_formatter_params = { 
+  fp_output : out_channel;
+  fp_output_function : string -> int -> int -> unit;
+  fp_flush_function : unit -> unit }
+
+val std_fp : (int*string) pp_formatter_params
+val err_fp : (int*string) pp_formatter_params
+
+val with_fp : 'a pp_formatter_params -> Format.formatter
+val with_output_to : out_channel -> Format.formatter
+
+val std_ft : Format.formatter ref
+val err_ft : Format.formatter
+val deep_ft : Format.formatter
+
+(*s For parametrization through vernacular. *)
+
+val set_depth_boxes : int option -> unit
+val get_depth_boxes : unit -> int option
+
+val set_margin : int option -> unit
+val get_margin : unit -> int option
diff --git a/lib/predicate.ml b/lib/predicate.ml
new file mode 100644
index 00000000..1eaa20ce
--- /dev/null
+++ b/lib/predicate.ml
@@ -0,0 +1,99 @@
+(************************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License.         *)
+(*                                                                     *)
+(************************************************************************)
+
+(* $Id: predicate.ml,v 1.1.14.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+(* Sets over ordered types *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+
+module type S =
+  sig
+    type elt
+    type t
+    val empty: t
+    val full: t
+    val is_empty: t -> bool
+    val is_full: t -> bool
+    val mem: elt -> t -> bool
+    val singleton: elt -> t
+    val add: elt -> t -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val complement: t -> t
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val elements: t -> bool * elt list
+  end
+
+module Make(Ord: OrderedType) =
+  struct
+    module EltSet = Set.Make(Ord)
+ 
+    (* when bool is false, the denoted set is the complement of
+       the given set *)
+    type elt = Ord.t
+    type t = bool * EltSet.t
+
+    let elements (b,s) = (b, EltSet.elements s)
+
+    let empty = (false,EltSet.empty)
+    let full = (true,EltSet.empty)
+
+    (* assumes the set is infinite *)
+    let is_empty (b,s) = not b & EltSet.is_empty s
+    let is_full (b,s) = b & EltSet.is_empty s
+
+    let mem x (b,s) =
+      if b then not (EltSet.mem x s) else EltSet.mem x s
+
+    let singleton x = (false,EltSet.singleton x)
+
+    let add x (b,s) =
+      if b then (b,EltSet.remove x s)
+      else (b,EltSet.add x s)
+
+    let remove x (b,s) =
+      if b then (b,EltSet.add x s)
+      else (b,EltSet.remove x s)
+
+    let complement (b,s) = (not b, s)
+
+    let union s1 s2 =
+      match (s1,s2) with
+          ((false,p1),(false,p2)) -> (false,EltSet.union p1 p2)
+        | ((true,n1),(true,n2)) -> (true,EltSet.inter n1 n2)
+        | ((false,p1),(true,n2)) -> (true,EltSet.diff n2 p1)
+        | ((true,n1),(false,p2)) -> (true,EltSet.diff n1 p2)
+
+    let inter s1 s2 =
+      complement (union (complement s1) (complement s2))
+
+    let diff s1 s2 = inter s1 (complement s2)
+
+    let subset s1 s2 =
+      match (s1,s2) with
+          ((false,p1),(false,p2)) -> EltSet.subset p1 p2
+        | ((true,n1),(true,n2)) -> EltSet.subset n2 n1
+        | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2)
+        | ((true,_),(false,_)) -> false
+
+    let equal (b1,s1) (b2,s2) =
+      b1=b2 & EltSet.equal s1 s2
+
+  end
diff --git a/lib/predicate.mli b/lib/predicate.mli
new file mode 100644
index 00000000..160fa648
--- /dev/null
+++ b/lib/predicate.mli
@@ -0,0 +1,69 @@
+
+(* $Id: predicate.mli,v 1.1 2001/09/20 18:10:43 barras Exp $ *)
+
+(* Module [Pred]: sets over infinite ordered types with complement. *)
+
+(* This module implements the set data structure, given a total ordering
+   function over the set elements. All operations over sets
+   are purely applicative (no side-effects).
+   The implementation uses the Set library. *)
+
+module type OrderedType =
+  sig
+    type t
+    val compare: t -> t -> int
+  end
+          (* The input signature of the functor [Pred.Make].
+             [t] is the type of the set elements.
+             [compare] is a total ordering function over the set elements.
+             This is a two-argument function [f] such that
+             [f e1 e2] is zero if the elements [e1] and [e2] are equal,
+             [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+             and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+             Example: a suitable ordering function is
+             the generic structural comparison function [compare]. *)
+
+module type S =
+  sig
+    type elt
+          (* The type of the set elements. *)
+    type t
+          (* The type of sets. *)
+    val empty: t
+          (* The empty set. *)
+    val full: t
+          (* The whole type. *)
+    val is_empty: t -> bool
+        (* Test whether a set is empty or not. *)
+    val is_full: t -> bool
+        (* Test whether a set contains the whole type or not. *)
+    val mem: elt -> t -> bool
+        (* [mem x s] tests whether [x] belongs to the set [s]. *)
+    val singleton: elt -> t
+        (* [singleton x] returns the one-element set containing only [x]. *)
+    val 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. *)
+    val 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. *)
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val complement: t -> t
+        (* Union, intersection, difference and set complement. *)
+    val equal: t -> t -> bool
+        (* [equal s1 s2] tests whether the sets [s1] and [s2] are
+           equal, that is, contain equal elements. *)
+    val subset: t -> t -> bool
+        (* [subset s1 s2] tests whether the set [s1] is a subset of
+           the set [s2]. *)
+    val elements: t -> bool * elt list
+        (* Gives a finite representation of the predicate: if the
+           boolean is false, then the predicate is given in extension.
+           if it is true, then the complement is given *)
+  end
+
+module Make(Ord: OrderedType): (S with type elt = Ord.t)
+        (* Functor building an implementation of the set structure
+           given a totally ordered type. *)
diff --git a/lib/profile.ml b/lib/profile.ml
new file mode 100644
index 00000000..f55388f8
--- /dev/null
+++ b/lib/profile.ml
@@ -0,0 +1,742 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: profile.ml,v 1.13.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+open Gc
+
+let word_length = Sys.word_size / 8
+let int_size = Sys.word_size - 1
+
+let float_of_time t = float_of_int t /. 100.
+let time_of_float f = int_of_float (f *. 100.)
+
+let get_time () =
+  let  {Unix.tms_utime = ut;Unix.tms_stime = st} = Unix.times () in
+  time_of_float (ut +. st)
+
+(* Since ocaml 3.01, gc statistics are in float *)
+let get_alloc () =
+  (* If you are unlucky, a minor collection can occur between the *)
+  (* measurements and produces allocation; we trigger a minor *)
+  (* collection in advance to be sure the measure is not corrupted *)
+  Gc.minor ();
+  Gc.allocated_bytes ()
+
+(* Rem: overhead was 16 bytes in ocaml 3.00 (long int) *)
+(* Rem: overhead is 100 bytes in ocaml 3.01 (double) *)
+
+let get_alloc_overhead =
+  let mark1 = get_alloc () in
+  let mark2 = get_alloc () in
+  let mark3 = get_alloc () in
+  (* If you are unlucky, a major collection can occur between the *)
+  (* measurements; with two measures the risk decreases *)
+  min (mark2 -. mark1) (mark3 -. mark2)
+
+let last_alloc = ref 0.0 (* set by init_profile () *)
+
+let spent_alloc () =
+  let now = get_alloc () in
+  let before = !last_alloc in
+  last_alloc := now;
+  now -. before -. get_alloc_overhead
+
+(* Profile records *)
+
+type profile_key = {
+  mutable owntime : int;
+  mutable tottime : int;
+  mutable ownalloc : float;
+  mutable totalloc : float;
+  mutable owncount : int;
+  mutable intcount : int;
+  mutable immcount : int;
+}
+
+let create_record () = {
+  owntime=0;
+  tottime=0;
+  ownalloc=0.0;
+  totalloc=0.0;
+  owncount=0;
+  intcount=0;
+  immcount=0
+}
+
+let ajoute_totalloc e dw = e.totalloc <- e.totalloc +. dw
+let ajoute_ownalloc e dw = e.ownalloc <- e.ownalloc +. dw
+
+let reset_record (n,e) =
+  e.owntime <- 0;
+  e.tottime <- 0;
+  e.ownalloc <- 0.0;
+  e.totalloc <- 0.0;
+  e.owncount <- 0;
+  e.intcount <- 0;
+  e.immcount <- 0
+
+(* Profile tables *)
+
+let prof_table = ref []
+let stack = ref []
+let init_time = ref 0
+let init_alloc = ref 0.0
+
+let reset_profile () = List.iter reset_record !prof_table
+
+let init_profile () =
+  let outside = create_record () in
+  stack := [outside];
+  last_alloc := get_alloc ();
+  init_alloc := !last_alloc;
+  init_time := get_time ();
+  outside.tottime <- - !init_time;
+  outside.owntime <- - !init_time
+
+let ajoute n o =
+  o.owntime <- o.owntime + n.owntime;
+  o.tottime <- o.tottime + n.tottime;
+  ajoute_ownalloc o n.ownalloc;
+  ajoute_totalloc o n.totalloc;
+  o.owncount <- o.owncount + n.owncount;
+  o.intcount <- o.intcount + n.intcount;
+  o.immcount <- o.immcount + n.immcount
+
+let ajoute_to_list ((name,n) as e) l =
+  try ajoute n (List.assoc name l); l
+  with Not_found -> e::l
+
+let magic = 1249
+  
+let merge_profile filename (curr_table, curr_outside, curr_total as new_data) =
+  let (old_table, old_outside, old_total) =
+    try 
+      let c = open_in filename in
+      if input_binary_int c <> magic 
+      then Printf.printf "Incompatible recording file: %s\n" filename;
+      let old_data = input_value c in
+      close_in c;
+      old_data
+    with Sys_error msg ->
+      (Printf.printf "Unable to open %s: %s\n" filename msg;
+       new_data) in
+  let updated_data =
+    let updated_table = List.fold_right ajoute_to_list curr_table old_table in
+    ajoute curr_outside old_outside;
+    ajoute curr_total old_total;
+    (updated_table, old_outside, old_total) in
+  begin
+    (try
+       let c =
+	 open_out_gen 
+           [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in
+       output_binary_int c magic;
+       output_value c updated_data;
+       close_out c
+     with Sys_error _ -> Printf.printf "Unable to create recording file");
+    updated_data
+  end
+
+(************************************************)
+(* Compute a rough estimation of time overheads *)
+
+(* Time and space are not measured in the same way *)
+
+(* Byte allocation is an exact number and for long runs, the total
+   number of allocated bytes may exceed the maximum integer capacity
+   (2^31 on 32-bits architectures);  therefore, allocation is measured
+   by small steps, total allocations are computed by adding elementary
+   measures and carries are controled from step to step *)
+
+(* Unix measure of time is approximative and shoitt delays are often
+   unperceivable; therefore, total times are measured in one (big)
+   step to avoid rounding errors and to get the best possible
+   approximation *)
+
+(*
+----------        start profile for f1
+overheadA|        ...
+  ---------- [1w1]  1st call to get_time for f1
+  overheadB|        ...
+  ----------        start f1
+   real 1  |        ...
+  ----------        start profile for 1st call to f2 inside f1
+  overheadA|        ...
+    ---------- [2w1]  1st call to get_time for 1st f2
+    overheadB|        ...
+    ----------        start 1st f2
+     real 2  |        ...
+    ----------        end 1st f2
+    overheadC|        ...
+    ---------- [2w1]  2nd call to get_time for 1st f2
+  overheadD|        ...
+  ----------        end profile for 1st f2
+   real 1  |        ...
+  ----------        start profile for 2nd call to f2 inside f1
+  overheadA|        ...
+    ---------- [2'w1] 1st call to get_time for 2nd f2
+    overheadB|        ...
+    ----------        start 2nd f2
+     real 2' |        ...
+    ----------        end 2nd f2
+    overheadC|        ...
+    ---------- [2'w2]  2nd call to get_time for 2nd f2 
+  overheadD|        ...
+  ----------        end profile for f2
+   real 1  |        ...
+  ----------        end f1
+  overheadC|        ...
+---------- [1w1'] 2nd call to get_time for f1
+overheadD|        ...
+----------        end profile for f1
+
+When profiling f2, overheadB + overheadC should be subtracted from measure
+and overheadA + overheadB + overheadC + overheadD should be subtracted from
+the amount for f1
+
+Then the relevant overheads are :
+
+  "overheadB + overheadC" to be subtracted to the measure of f as many time as f is called and
+
+  "overheadA + overheadB + overheadC + overheadD" to be subtracted to
+  the measure of f as many time as f calls a profiled function (itself
+  included)
+*)
+
+let dummy_last_alloc = ref 0.0
+let dummy_spent_alloc () =
+  let now = get_alloc () in
+  let before = !last_alloc in
+  last_alloc := now;
+  now -. before
+let dummy_f x = x
+let dummy_stack = ref [create_record ()]
+let dummy_ov = 0
+
+let loops = 10000
+
+let time_overhead_A_D () =
+  let e = create_record () in
+  let before = get_time () in
+  for i=1 to loops do
+    (* This is a copy of profile1 for overhead estimation *)
+    let dw = dummy_spent_alloc () in
+    match !dummy_stack with [] -> assert false | p::_ ->
+      ajoute_ownalloc p dw;
+      ajoute_totalloc p dw;
+      e.owncount <- e.owncount + 1;
+      if not (p==e) then stack := e::!stack;
+      let totalloc0 = e.totalloc in
+      let intcount0 = e.intcount in
+      let dt = get_time () - 1 in
+      e.tottime <- dt + dummy_ov; e.owntime <- e.owntime + e.tottime;
+      ajoute_ownalloc p dw;
+      ajoute_totalloc p dw;
+      p.owntime <- p.owntime - e.tottime;
+      ajoute_totalloc p (e.totalloc-.totalloc0);
+      p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+      p.immcount <- p.immcount + 1;
+      if not (p==e) then 
+	(match !dummy_stack with [] -> assert false | _::s -> stack := s);
+      dummy_last_alloc := get_alloc ()
+  done;
+  let after = get_time () in
+  let beforeloop =  get_time () in
+  for i=1 to loops do () done;
+  let afterloop = get_time () in
+  float_of_int ((after - before) - (afterloop - beforeloop))
+  /. float_of_int loops
+
+let time_overhead_B_C () =
+  let dummy_x = 0 in
+  let before = get_time () in
+  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
+      ()
+    with _ -> assert false
+  done;
+  let after = get_time () in
+  let beforeloop =  get_time () in
+  for i=1 to loops do () done;
+  let afterloop = get_time () in
+  float_of_int ((after - before) - (afterloop - beforeloop))
+  /. float_of_int loops
+
+let compute_alloc lo = lo /. (float_of_int word_length)
+
+(************************************************)
+(* End a profiling session and print the result *)
+
+let format_profile (table, outside, total) =
+  print_newline ();
+  Printf.printf 
+    "%-23s  %9s %9s %10s %10s %10s\n"
+    "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls ";
+  let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in
+  List.iter (fun (name,e) ->
+    Printf.printf
+      "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n"
+      name
+      (float_of_time e.owntime) (float_of_time e.tottime)
+      (compute_alloc e.ownalloc)
+      (compute_alloc e.totalloc)
+      e.owncount e.intcount)
+    l;
+  Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f        %6d\n"
+    "others" 
+    (float_of_time outside.owntime) (float_of_time outside.tottime)
+    (compute_alloc outside.ownalloc)
+    (compute_alloc outside.totalloc)
+    outside.intcount;
+  (* Here, own contains overhead time/alloc *)
+  Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f\n"
+    "Est. overhead/total"
+    (float_of_time total.owntime) (float_of_time total.tottime)
+    (compute_alloc total.ownalloc)
+    (compute_alloc total.totalloc);
+  Printf.printf
+    "Time in seconds and allocation in words (1 word = %d bytes)\n" 
+    word_length
+
+let recording_file = ref ""
+let set_recording s = recording_file := s
+
+let adjust_time ov_bc ov_ad e =
+  let bc_imm = float_of_int e.owncount *. ov_bc in
+  let ad_imm = float_of_int e.immcount *. ov_ad in
+  let abcd_all = float_of_int e.intcount *. (ov_ad +. ov_bc) in
+  {e with
+     tottime = e.tottime - int_of_float (abcd_all +. bc_imm);
+     owntime = e.owntime - int_of_float (ad_imm +. bc_imm) }
+
+let close_profile print = 
+  let dw = spent_alloc () in
+  let t = get_time () in
+  match !stack with
+    | [outside] ->
+	outside.tottime <- outside.tottime + t;
+	outside.owntime <- outside.owntime + t;
+	ajoute_ownalloc outside dw;
+	ajoute_totalloc outside dw;
+	if List.length !prof_table <> 0 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
+	  let adjtable = List.map adjust !prof_table in
+	  let adjoutside = adjust_time ov_bc ov_ad outside in
+	  let totalloc = !last_alloc -. !init_alloc in
+	  let total = create_record () in
+	  total.tottime <- outside.tottime;
+	  total.totalloc <- totalloc;
+	  (* We compute estimations of overhead, put into "own" fields *)
+	  total.owntime <- outside.tottime - adjoutside.tottime;
+	  total.ownalloc <- totalloc -. outside.totalloc;
+	  let current_data = (adjtable, adjoutside, total) in
+	  let updated_data =
+	    match !recording_file with
+	      |	"" -> current_data
+	      | name -> merge_profile !recording_file current_data
+	  in
+	  if print then format_profile updated_data;
+	  init_profile ()
+	end
+    | _ -> failwith "Inconsistency"
+
+let append_profile () = close_profile false
+let print_profile () = close_profile true
+
+let declare_profile name =
+  if name = "___outside___" or name = "___total___" then
+    failwith ("Error: "^name^" is a reserved keyword");
+  let e = create_record () in
+  prof_table := (name,e)::!prof_table;
+  e
+
+(* Default initialisation, may be overriden *)
+let _ = init_profile ()
+
+(******************************)
+(* Entry points for profiling *)
+let profile1 e f a =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile2 e f a b =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile3 e f a b c =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile4 e f a b c d =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile5 e f a b c d g =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d g in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile6 e f a b c d g h =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d g h in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+let profile7 e f a b c d g h i =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d g h i in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with exn ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then 
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise exn
+
+(* Some utilities to compute the logical and physical sizes and depth
+   of ML objects *)
+
+open Obj
+
+let c = ref 0
+let s = ref 0
+let b = ref 0
+let m = ref 0
+
+let rec obj_stats d t =
+  if is_int t then m := max d !m
+  else if tag t >= no_scan_tag then
+    if tag t = string_tag then
+      (c := !c + size t; b := !b + 1; m := max d !m)
+    else if tag t = double_tag then
+      (s := !s + 2; b := !b + 1; m := max d !m)
+    else if tag t = double_array_tag then
+      (s := !s + 2 * size t; b := !b + 1; m := max d !m)
+    else (b := !b + 1; m := max d !m)
+  else
+    let n = Obj.size t in
+    s := !s + n; b := !b + 1;
+    block_stats (d + 1) (n - 1) t
+
+and block_stats d i t =
+  if i >= 0 then (obj_stats d (field t i); block_stats d (i-1) t)
+
+let obj_stats a =
+  c := 0; s:= 0; b:= 0; m:= 0;
+  obj_stats 0 (Obj.repr a);
+  (!c, !s + !b, !m)
+
+module H = Hashtbl.Make(
+  struct 
+    type t = Obj.t 
+    let equal = (==) 
+    let hash o = Hashtbl.hash (magic o : int)
+  end)
+
+let tbl = H.create 13
+
+let rec obj_shared_size s t =
+  if is_int t then s
+  else if H.mem tbl t then s
+  else begin
+    H.add tbl t ();
+    let n = Obj.size t in
+    if tag t >= no_scan_tag then
+      if tag t = string_tag then (c := !c + n; s + 1)
+      else if tag t = double_tag then s + 3
+      else if tag t = double_array_tag then s + 2 * n + 1
+      else s + 1
+    else
+      block_shared_size (s + n + 1) (n - 1) t
+  end
+
+and block_shared_size s i t =
+  if i < 0 then s
+  else block_shared_size (obj_shared_size s (field t i)) (i-1) t
+
+let obj_shared_size a =
+  H.clear tbl;
+  c := 0;
+  let s = obj_shared_size 0 (Obj.repr a) in
+  (!c, s)
+
+let print_logical_stats a =
+  let (c, s, d) = obj_stats a in
+  Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d
+
+let print_stats a =
+  let (c1, s, d) = obj_stats a in
+  let (c2, o) = obj_shared_size a in
+  Printf.printf "Size: %8d (str: %8d) (exp: %10d)  Depth: %6d\n"
+    (o + c2) c2 (s + c1) d
+(*
+let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 }
+*)
diff --git a/lib/profile.mli b/lib/profile.mli
new file mode 100644
index 00000000..e0488de3
--- /dev/null
+++ b/lib/profile.mli
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: profile.mli,v 1.7.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+(*s This program is a small time and allocation profiler for Objective Caml *)
+
+(*i It requires the UNIX library *)
+
+(* Adapted from Christophe Raffalli *)
+
+(* To use it, link it with the program you want to profile (do not forget
+"-cclib -lunix -custom unix.cma" among the link options).
+
+To trace a function "f" you first need to get a key for it by using :
+
+let fkey = declare_profile "f";;
+
+(the string is used to print the profile infomation). Warning: this
+function does a side effect. Choose the ident you want instead "fkey".
+
+Then if the function has ONE argument add the following just after
+the definition of "f" or just after the declare_profile if this one
+follows the definition of f.
+
+let f = profile1 fkey f;;
+
+If f has two arguments do the same with profile2, idem with 3, ...
+For more arguments than provided in this module, make a new copy of
+function profile and adapt for the needed arity.
+
+If you want to profile two mutually recursive functions, you had better
+to rename them :
+
+let fkey = declare_profile "f";;
+let gkey = declare_profile "g";;
+let f' = .... f' ... g'
+and g' = .... f' .... g'
+;;
+
+let f = profile fkey f';;
+let g = profile gkey g';;
+
+Before the program quits, you should call "print_profile ();;". It
+produces a result of the following kind:
+
+Function name              Own time Total time  Own alloc Tot. alloc     Calls 
+f                            0.28      0.47        116        116      5      4
+h                            0.19      0.19          0          0      4      0
+g                            0.00      0.00          0          0      0      0
+others                       0.00      0.47        392        508             9
+Est. overhead/total          0.00      0.47       2752       3260
+
+- The first column is the name of the function.
+- The third column give the time (utime + stime) spent inside the function.
+- The second column give the time spend inside the function minus the
+  time spend in other profiled functions called by it
+- The 4th and 5th columns give the same for allocated words
+- The 6th and 7th columns give the number of calls to the function and
+  the number of calls to profiled functions inside the scope of the
+  current function
+
+Remarks: 
+
+- If a function has a polymorphic type, you need to supply it with at
+  least one argument as in "let f a = profile1 fkey f a;;" (instead of
+  "let f = profile1 fkey f;;") in order to get generalization of the
+  type.
+- Each line of the form "let f a = profile1 fkey f a;;" in your code
+  counts for 5 words and each line of the form "let f
+  = profile1 fkey f;;" counts for 6 words (a word is 4 or 8 bytes
+  according to the architecture); this is counted for "others".
+- Time fields for functions doing a little job is usually non pertinent.
+
+i*)
+
+type profile_key
+
+val set_recording : string -> unit
+
+val print_profile : unit -> unit
+val reset_profile : unit -> unit
+val init_profile : unit -> unit
+val declare_profile : string -> profile_key
+
+val profile1 : profile_key -> ('a -> 'b) -> 'a -> 'b
+val profile2 : profile_key -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
+val profile3 :
+  profile_key -> ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd
+val profile4 :
+  profile_key -> ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e
+val profile5 :
+  profile_key ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f
+val profile6 :
+  profile_key ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g)
+    -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g
+val profile7 :
+  profile_key ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) 
+    -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
+
+
+(* Some utilities to compute the logical and physical sizes and depth
+   of ML objects *)
+
+(* Print logical size (in words) and depth of its argument *)
+(* This function does not disturb the heap *)
+val print_logical_stats : 'a -> unit
+
+(* Print physical size, logical size (in words) and depth of its argument *)
+(* This function allocates itself a lot (the same order of magnitude
+   as the physical size of its argument) *)
+val print_stats : 'a -> unit
+
+(* Return logical size (first for strings, then for not strings),
+   (in words) and depth of its argument *)
+(* This function allocates itself a lot *)
+val obj_stats : 'a -> int * int * int
+
+(* Return physical size of its argument (string part and rest) *)
+(* This function allocates itself a lot *)
+val obj_shared_size : 'a -> int * int
diff --git a/lib/rtree.ml b/lib/rtree.ml
new file mode 100644
index 00000000..53cc372f
--- /dev/null
+++ b/lib/rtree.ml
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rtree.ml,v 1.2.8.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+
+
+(* Type of regular trees:
+   - Param denotes tree variables (like de Bruijn indices)
+   - Node denotes the usual tree node, labelles 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
+     current Rec node (as usual in de Bruijn binding system)
+ *)
+type 'a t =
+    Param of int 
+  | Node of 'a * 'a t array
+  | Rec of int * 'a t array
+
+(* Building trees *)
+let mk_param i = Param i
+let mk_node lab sons = Node (lab, sons)
+
+(* Given a vector of n bodies, builds the n mutual recursive trees.
+   Recursive calls are made with parameters 0 to n-1. We check
+   the bodies actually build something by checking it is not
+   directly one of the parameters 0 to n-1. *)
+let mk_rec defs =
+  Array.mapi
+    (fun i d ->
+      (match d with
+          Param k when k < Array.length defs -> failwith "invalid rec call"
+        | _ -> ());
+      Rec(i,defs))
+    defs
+
+(* The usual lift operation *)
+let rec lift_rtree_rec depth n = function
+    Param i -> if i < depth then Param i else Param (i+n)
+  | Node (l,sons) -> Node (l,Array.map (lift_rtree_rec depth n) sons)
+  | Rec(j,defs) ->
+      Rec(j, Array.map (lift_rtree_rec (depth+Array.length defs) n) defs)
+
+let lift n t = if n=0 then t else lift_rtree_rec 0 n t
+
+(* The usual subst operation *)
+let rec subst_rtree_rec depth sub = function
+    Param i ->
+      if i < depth then Param i
+      else if i-depth < Array.length sub then lift depth sub.(i-depth)
+      else Param (i-Array.length sub)
+  | Node (l,sons) -> Node (l,Array.map (subst_rtree_rec depth sub) sons)
+  | Rec(j,defs) ->
+      Rec(j, Array.map (subst_rtree_rec (depth+Array.length defs) sub) defs)
+
+let subst_rtree sub t = subst_rtree_rec 0 sub t
+
+let rec map f t = match t with
+    Param i -> Param i
+  | Node (a,sons) -> Node (f a, Array.map (map f) sons)
+  | Rec(j,defs) -> Rec (j, Array.map (map f) defs)
+
+let rec smartmap f t = match t with
+    Param i -> t
+  | Node (a,sons) -> 
+      let a'=f a and sons' = Util.array_smartmap (map f) sons in
+	if a'==a && sons'==sons then
+	  t
+	else
+	  Node (a',sons')
+  | Rec(j,defs) -> 
+      let defs' = Util.array_smartmap (map f) defs in
+	if defs'==defs then
+	  t
+	else
+	  Rec(j,defs')
+
+(* To avoid looping, we must check that every body introduces a node 
+   or a parameter *)
+let rec expand_rtree = function
+  | Rec(j,defs) ->
+      let sub = Array.init (Array.length defs) (fun i -> Rec(i,defs)) in
+      expand_rtree (subst_rtree sub defs.(j))
+  | t -> t
+
+(* Tree destructors, expanding loops when necessary *)
+let dest_param t = 
+  match expand_rtree t with
+      Param i -> i
+    | _ -> failwith "dest_param"
+
+let dest_node t = 
+  match expand_rtree t with
+      Node (l,sons) -> (l,sons)
+    | _ -> failwith "dest_node"
+
+(* Tests if a given tree is infinite or not. It proceeds *)
+let rec is_infinite = function
+    Param i -> i = (-1)
+  | Node(_,sons) -> Util.array_exists is_infinite sons
+  | Rec(j,defs) ->
+      let newdefs =
+        Array.mapi (fun i def -> if i=j then Param (-1) else def) defs in
+      let sub =
+        Array.init (Array.length defs)
+          (fun i -> if i=j then Param (-1) else Rec(i,newdefs)) in
+      is_infinite (subst_rtree sub defs.(j))
+
+(* Pretty-print a tree (not so pretty) *)
+open Pp
+
+let rec pp_tree prl t =
+  match t with
+      Param k -> str"#"++int k
+    | Node(lab,[||]) -> hov 2 (str"("++prl lab++str")")
+    | Node(lab,v) ->
+        hov 2 (str"("++prl lab++str","++brk(1,0)++
+               Util.prvect_with_sep Util.pr_coma (pp_tree prl) v++str")")
+    | Rec(i,v) ->
+        if Array.length v = 0 then str"Rec{}"
+        else if Array.length v = 1 then
+          hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}")
+        else
+          hov 2 (str"Rec{"++int i++str","++brk(1,0)++
+                 Util.prvect_with_sep Util.pr_coma (pp_tree prl) v++str"}")
diff --git a/lib/rtree.mli b/lib/rtree.mli
new file mode 100644
index 00000000..0f854bc0
--- /dev/null
+++ b/lib/rtree.mli
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rtree.mli,v 1.2.8.1 2004/07/16 19:30:31 herbelin Exp $ i*)
+
+(* Type of regular tree with nodes labelled by values of type 'a *)
+type 'a t
+
+(* Building trees *)
+(* build a recursive call *) 
+val mk_param : int -> 'a t
+(* build a node given a label and the vector of sons *)
+val mk_node  : 'a -> 'a t array -> 'a t
+(* build mutually dependent trees *)
+val mk_rec   : 'a t array -> 'a t array
+
+(* [lift k t] increases of [k] the free parameters of [t]. Needed
+   to avoid captures when a tree appears under mk_rec *) 
+val lift : int -> 'a t -> 'a t
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+
+(* [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
+val smartmap : ('a -> 'a) -> 'a t -> 'a t
+
+(* Destructors (recursive calls are expanded) *)
+val dest_param : 'a t -> int
+val dest_node  : 'a t -> 'a * 'a t array
+
+(* Tells if a tree has an infinite branch *)
+val is_infinite : 'a t -> bool
+
+(* A rather simple minded pretty-printer *)
+val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
diff --git a/lib/stamps.ml b/lib/stamps.ml
new file mode 100644
index 00000000..1697c309
--- /dev/null
+++ b/lib/stamps.ml
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $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
new file mode 100644
index 00000000..36f238b9
--- /dev/null
+++ b/lib/stamps.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100644
index 00000000..fd782fe6
--- /dev/null
+++ b/lib/system.ml
@@ -0,0 +1,208 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: system.ml,v 1.31.8.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+open Pp
+open Util
+open Unix
+
+(* Expanding shell variables and home-directories *)
+
+let safe_getenv_def var def =
+  try 
+    Sys.getenv var
+  with Not_found ->
+    warning ("Environment variable "^var^" not found: using '"^def^"' .");
+    flush Pervasives.stdout;
+    def
+
+let home = (safe_getenv_def "HOME" ".")
+
+let safe_getenv n = safe_getenv_def n ("$"^n)
+
+let rec expand_atom s i =
+  let l = String.length s in
+  if i<l && (is_digit s.[i] or is_letter s.[i] or s.[i] = '_')
+  then expand_atom s (i+1)
+  else i
+
+let rec expand_macros b s i =
+  let l = String.length s in
+  if i=l then s else
+    match s.[i] with
+      | '$' -> 
+	  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)
+      | '~' ->
+	  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)
+
+let glob s = expand_macros true s 0
+
+(* Files and load path. *)
+
+type physical_path = string
+type load_path = physical_path list
+
+(* All subdirectories, recursively *)
+
+let exists_dir dir =
+  try let _ = opendir dir in true with Unix_error _ -> false
+
+let all_subdirs ~unix_path:root =
+  let l = ref [] in
+  let add f rel = l := (f, rel) :: !l in
+  let rec traverse dir rel =
+    let dirh = opendir dir in
+    try
+      while true do
+	let f = readdir dirh in
+	if f <> "" && f.[0] <> '.' && (not Coq_config.local or (f <> "CVS"))
+        then
+	  let file = Filename.concat dir f in
+	  try 
+	    if (stat file).st_kind = S_DIR then begin
+	      let newrel = rel@[f] in
+	      add file newrel;
+	      traverse file newrel
+	    end
+	  with Unix_error (e,s1,s2) -> ()
+      done
+    with End_of_file ->
+      closedir dirh
+  in
+  if exists_dir root then
+   begin
+     add root [];
+     traverse root []
+   end ;
+  List.rev !l
+
+let search_in_path path filename =
+  let rec search = function
+    | lpe :: rem ->
+	let f = glob (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
+  else 
+    try 
+      search_in_path paths name
+    with Not_found ->
+      errorlabstrm "System.find_file_in_path"
+	(hov 0 (str "Can't find file" ++ spc () ++ str name ++ spc () ++ 
+		str "on loadpath"))
+
+let is_in_path lpath filename =
+  try
+    let _ = search_in_path lpath filename in 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 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 try_remove f =
+  try Sys.remove f
+  with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++
+                   str f ++ str" which is corrupted!" )
+
+let marshal_out ch v = Marshal.to_channel ch v []
+let marshal_in ch =
+  try Marshal.from_channel ch
+  with End_of_file -> error "corrupted file: reached end of file"
+
+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
+    output_binary_int channel magic;
+    filec
+  and intern_state fname = 
+    let channel = open_in_bin fname in
+    if input_binary_int channel <> magic then
+      raise (Bad_magic_number fname);
+    channel
+  in 
+  (extern_state,intern_state)
+
+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
+      try
+        marshal_out channel val_0;
+        close_out channel
+      with e -> 
+	begin try_remove fname; 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 v = marshal_in channel in
+      close_in channel; 
+      v
+    with Sys_error s -> 
+      error("System error: " ^ s)
+  in 
+  (extern_state,intern_state)
+
+
+(* Time stamps. *)
+
+type time = float * float * float
+
+let process_time () = 
+  let t = times ()  in
+  (t.tms_utime, t.tms_stime)
+
+let get_time () = 
+  let t = times ()  in
+  (time(), t.tms_utime, t.tms_stime)
+
+let time_difference (t1,_,_) (t2,_,_) = t2 -. t1
+			      
+let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) =
+  real (stopreal -. startreal) ++ str " secs " ++
+  str "(" ++
+  real ((-.) ustop ustart) ++ str "u" ++
+  str "," ++
+  real ((-.) sstop sstart) ++ str "s" ++
+  str ")"
diff --git a/lib/system.mli b/lib/system.mli
new file mode 100644
index 00000000..86d78b52
--- /dev/null
+++ b/lib/system.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: system.mli,v 1.17.16.1 2004/07/16 19:30:31 herbelin Exp $ 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
+    [directory]), the root path and the path relative to the root. *)
+
+
+type physical_path = string
+type load_path = physical_path list
+
+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 make_suffix : string -> string -> string
+val file_readable_p : string -> bool
+
+val glob : string -> string
+
+val home : string
+
+val exists_dir : string -> bool
+
+val find_file_in_path : load_path -> string -> physical_path * string
+
+(*s Generic input and output functions, parameterized by a magic number
+  and a suffix. The intern functions raise the exception [Bad_magic_number]
+  when the check fails, with the full file name. *)
+
+val marshal_out : out_channel -> 'a -> unit
+val marshal_in : in_channel -> 'a
+
+exception Bad_magic_number of string
+
+val raw_extern_intern : int -> string -> 
+  (string -> string * out_channel) * (string -> in_channel)
+
+val extern_intern : 
+  int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a)
+
+(*s Time stamps. *)
+
+type time
+
+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
new file mode 100644
index 00000000..23021be4
--- /dev/null
+++ b/lib/tlm.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tlm.ml,v 1.3.16.1 2004/07/16 19:30:31 herbelin Exp $ *)
+
+type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t
+
+let empty = Node (Gset.empty, Gmap.empty)
+
+let map (Node (_,m)) lbl = Gmap.find lbl m
+
+let xtract (Node (hereset,_)) = Gset.elements hereset
+
+let dom (Node (_,m)) = Gmap.dom m
+
+let in_dom (Node (_,m)) lbl = Gmap.mem lbl m
+
+let is_empty_node (Node(a,b)) = (Gset.elements a = []) & (Gmap.to_list b = [])
+
+let assure_arc m lbl =
+  if Gmap.mem lbl m then 
+    m
+  else 
+    Gmap.add lbl (Node (Gset.empty,Gmap.empty)) m
+
+let cleanse_arcs (Node (hereset,m)) =
+  let l = Gmap.rng m in 
+  Node(hereset, if List.for_all is_empty_node l then Gmap.empty else m)
+
+let rec at_path f (Node (hereset,m)) = function
+  | [] -> 
+      cleanse_arcs (Node(f hereset,m))
+  | h::t ->
+      let m = assure_arc m h in 
+      cleanse_arcs (Node(hereset,
+                         Gmap.add h (at_path f (Gmap.find h m) t) m))
+
+let add tm (path,v) =
+  at_path (fun hereset -> Gset.add v hereset) tm path
+    
+let rmv tm (path,v) =
+  at_path (fun hereset -> Gset.remove v hereset) tm path
+
+let app f tlm = 
+  let rec apprec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in 
+    Gset.iter (fun v -> f(path,v)) hereset;
+    Gmap.iter (fun l tm -> apprec (l::pfx) tm) m
+  in 
+  apprec [] tlm
+    
+let to_list tlm = 
+  let rec torec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in 
+    List.flatten((List.map (fun v -> (path,v)) (Gset.elements hereset))::
+		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (Gmap.to_list m)))
+  in 
+  torec [] tlm
diff --git a/lib/tlm.mli b/lib/tlm.mli
new file mode 100644
index 00000000..a3011932
--- /dev/null
+++ b/lib/tlm.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tlm.mli,v 1.5.16.1 2004/07/16 19:30:31 herbelin Exp $ 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]. *)
+
+type ('a,'b) t
+
+val empty : ('a,'b) t
+
+(* Work on labels, not on paths. *)
+
+val map : ('a,'b) t -> 'a -> ('a,'b) t
+val xtract : ('a,'b) t -> 'b list
+val dom : ('a,'b) t -> 'a list
+val in_dom : ('a,'b) t -> 'a -> bool
+
+(* Work on paths, not on labels. *)
+
+val add : ('a,'b) t -> 'a list * 'b -> ('a,'b) t
+val rmv : ('a,'b) t -> ('a list * 'b) -> ('a,'b) t
+
+val app : (('a list * 'b) -> unit) -> ('a,'b) t -> unit
+val to_list : ('a,'b) t -> ('a list * 'b) list
+
diff --git a/lib/util.ml b/lib/util.ml
new file mode 100644
index 00000000..37568f9b
--- /dev/null
+++ b/lib/util.ml
@@ -0,0 +1,824 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: util.ml,v 1.84.2.2 2004/07/16 20:43:46 herbelin Exp $ *)
+
+open Pp
+
+(* Errors *)
+
+exception Anomaly of string * std_ppcmds  (* System errors *)
+let anomaly string = raise (Anomaly(string, str string))
+let anomalylabstrm string pps = raise (Anomaly(string,pps))
+
+exception UserError of string * std_ppcmds (* User errors *)
+let error string = raise (UserError(string, str string))
+let errorlabstrm l pps = raise (UserError(l,pps))
+
+let todo s = prerr_string ("TODO: "^s^"\n")
+
+type loc = Compat.loc
+let dummy_loc = Compat.dummy_loc
+let unloc = Compat.unloc
+let make_loc = Compat.make_loc
+
+(* raising located exceptions *)
+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,_) (_,fin2) = (deb1,fin2)
+
+(* Like Exc_located, but specifies the outermost file read, the filename
+   associated to the location of the error, and the error itself. *)
+
+exception Error_in_file of string * (bool * string * loc) * exn
+
+(* Projections from triplets *)
+
+let pi1 (a,_,_) = a
+let pi2 (_,a,_) = a
+let pi3 (_,_,a) = a
+
+(* Characters *)
+
+let is_letter c =
+  (c >= 'a' && c <= 'z') or
+  (c >= 'A' && c <= 'Z') or
+  (c >= '\248' && c <= '\255') or
+  (c >= '\192' && c <= '\214') or
+  (c >= '\216' && c <= '\246')
+
+let is_digit c = (c >= '0' && c <= '9')
+
+let is_ident_tail c =
+  is_letter c or is_digit c or c = '\'' or c = '_'
+
+(* Strings *)
+
+let explode s = 
+  let rec explode_rec n =
+    if n >= String.length s then
+      []
+    else 
+      String.make 1 (String.get s n) :: explode_rec (succ n)
+  in 
+  explode_rec 0
+
+let implode sl = String.concat "" sl
+
+(* substring searching... *)
+
+(* gdzie = where, co = what *)
+(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
+let rec is_sub gdzie gl gi co cl ci = 
+  (ci>=cl) ||
+  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && 
+   (is_sub gdzie gl (gi+1) co cl (ci+1)))
+
+let rec raw_str_index i gdzie l c co cl = 
+  let i' = String.index_from gdzie i c in
+    if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
+      raw_str_index (i'+1) gdzie l c co cl
+
+let string_index_from gdzie i co = 
+  if co="" then i else
+    raw_str_index i gdzie (String.length gdzie)
+      (String.unsafe_get co 0) co (String.length co)
+
+let string_string_contains ~where ~what =
+  try
+    let _ = string_index_from where 0 what in true
+  with
+      Not_found -> false
+
+(* string parsing *)
+
+let parse_loadpath s =
+  let len = String.length s in
+  let rec decoupe_dirs n =
+    try  
+      let pos = String.index_from s n '/' in
+      if pos = n then
+	invalid_arg "parse_loadpath: find an empty dir in loadpath";
+      let dir = String.sub s n (pos-n) in
+      dir :: (decoupe_dirs (succ pos))
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if len = 0 then [] else decoupe_dirs 0
+
+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
+
+let list_intersect l1 l2 = 
+  List.filter (fun x -> List.mem x l2) l1
+
+let list_union l1 l2 = 
+  let rec urec = function
+    | [] -> l2
+    | a::l -> if List.mem a l2 then urec l else a::urec l
+  in 
+  urec l1
+
+let list_unionq l1 l2 = 
+  let rec urec = function
+    | [] -> l2
+    | a::l -> if List.memq a l2 then urec l else a::urec l
+  in 
+  urec l1
+
+let list_subtract l1 l2 =
+  if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
+
+let list_subtractq l1 l2 = 
+  if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
+
+let list_chop n l = 
+  let rec chop_aux acc = function
+    | (0, l2) -> (List.rev acc, l2)
+    | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
+    | (_, []) -> failwith "list_chop"
+  in 
+  chop_aux [] (n,l)
+
+let list_tabulate f len = 
+  let rec tabrec n =
+    if n = len then [] else (f n)::(tabrec (n+1))
+  in 
+  tabrec 0
+
+let list_assign l n e = 
+  let rec assrec stk = function
+    | ((h::t), 0) -> List.rev_append stk (e::t)
+    | ((h::t), n) -> assrec (h::stk) (t, n-1)
+    | ([], _) -> failwith "list_assign"
+  in 
+  assrec [] (l,n)
+
+let rec list_smartmap f l = match l with
+    [] -> l
+  | h::tl -> 
+      let h' = f h and tl' = list_smartmap f tl in
+	if h'==h && tl'==tl then l
+	else h'::tl'
+
+let list_map_left f = (* ensures the order in case of side-effects *)
+  let rec map_rec = function
+    | [] -> [] 
+    | x::l -> let v = f x in v :: map_rec l
+  in 
+  map_rec
+
+let list_map_i f = 
+  let rec map_i_rec i = function
+    | [] -> [] 
+    | x::l -> let v = f i x in v :: map_i_rec (i+1) l
+  in 
+  map_i_rec
+
+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))
+    | (_, _) -> invalid_arg "map2_i"
+  in 
+  map_i 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))
+    | (_, _, _) -> invalid_arg "map3"
+  in 
+  map (l1,l2,l3)
+
+let list_index x = 
+  let rec index_x n = function
+    | y::l -> if x = y then 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 
+    | b::l -> it_list_f (i+1) (f i a b) l
+  in 
+  it_list_f 
+
+(* [list_fold_right_and_left f [a1;...;an] hd =
+   f (f (... (f (f hd
+                   an
+                   [an-1;...;a1])
+              an-1
+              [an-2;...;a1])
+         ...)
+        a2
+        [a1])
+     a1
+     []] *)
+
+let rec list_fold_right_and_left f l hd =
+  let rec aux tl = function
+    | [] -> hd
+    | a::l -> let hd = aux (a::tl) l in f hd a tl
+   in aux [] l
+
+let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
+
+let list_for_all_i p = 
+  let rec for_all_p i = function
+    | [] -> true 
+    | a::l -> p i a && for_all_p (i+1) l
+  in 
+  for_all_p
+
+let list_except x l = List.filter (fun y -> not (x = y)) l
+
+let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Failure _ -> false
+
+let list_map_i f = 
+  let rec map_i_rec i = function
+    | [] -> [] 
+    | x::l -> let v = f i x in v::map_i_rec (i+1) l
+  in 
+  map_i_rec
+
+let rec list_sep_last = function
+  | [] -> failwith "sep_last"
+  | hd::[] -> (hd,[])
+  | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
+
+let list_try_find_i f = 
+  let rec try_find_f n = function
+    | [] -> failwith "try_find_i"
+    | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
+  in 
+  try_find_f
+
+let list_try_find f = 
+  let rec try_find_f = function
+    | [] -> failwith "try_find"
+    | h::t -> try f h with Failure _ -> try_find_f t
+  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 rec list_distinct = function
+  | h::t -> (not (List.mem h t)) && list_distinct t
+  | _ -> true
+
+let rec list_filter2 f = function
+  | [], [] as p -> p
+  | d::dp, l::lp ->
+     let (dp',lp' as p) = list_filter2 f (dp,lp) in
+      if f d l then d::dp', l::lp' else p
+  | _ -> invalid_arg "list_filter2"
+
+let list_subset l1 l2 =
+  let t2 = Hashtbl.create 151 in
+  List.iter (fun x -> Hashtbl.add t2 x ()) l2;
+  let rec look = function
+    | [] -> true
+    | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
+  in 
+  look l1
+
+let list_splitby p = 
+  let rec splitby_loop x y = 
+    match y with 
+      | []      -> ([],[])
+      | (a::l)  -> if (p a) then (x,y) else (splitby_loop (x@[a]) l)
+  in 
+  splitby_loop []
+
+let rec list_split3 = function
+  | [] -> ([], [], [])
+  | (x,y,z)::l ->
+      let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz)
+
+let list_firstn n l =
+  let rec aux acc = function
+    | (0, l) -> List.rev acc
+    | (n, (h::t)) -> aux (h::acc) (pred n, t)
+    | _ -> failwith "firstn"
+  in 
+  aux [] (n,l)
+
+let rec list_last = function
+  | [] -> failwith "list_last"
+  | [x] -> x
+  | _ :: l -> list_last l
+
+let list_lastn n l =
+  let len = List.length l in
+  let rec aux m l =
+    if m = n then l else aux (m - 1) (List.tl l)
+  in
+  if len < n then failwith "lastn" else aux len l
+
+let rec list_skipn n l = match n,l with 
+  | 0, _ -> l 
+  | _, [] -> failwith "list_fromn"
+  | n, _::l -> list_skipn (pred n) l
+
+let list_prefix_of prefl l = 
+  let rec prefrec = function
+    | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
+    | ([], _) -> true
+    | (_, _) -> false
+  in 
+  prefrec (prefl,l)
+
+let list_map_append f l = List.flatten (List.map f l)
+
+let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
+
+let list_share_tails l1 l2 =
+  let rec shr_rev acc = function
+    | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
+    | (l1,l2) -> (List.rev l1, List.rev l2, acc)
+  in 
+  shr_rev [] (List.rev l1, List.rev l2)
+
+let list_join_map f l = List.flatten (List.map f l)
+
+let rec list_fold_map f e = function 
+  |  []  -> (e,[])
+  |  h::t -> 
+       let e',h' = f e h in
+       let e'',t' = list_fold_map f e' t in
+	 e'',h'::t'
+
+(* (* tail-recursive version of the above function *)
+let list_fold_map f e l = 
+  let g (e,b') h = 
+    let (e',h') = f e h in
+      (e',h'::b') 
+  in
+  let (e',lrev) = List.fold_left g (e,[]) l in
+    (e',List.rev lrev)
+*)
+
+let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
+
+(* Arrays *)
+
+let array_exists f v = 
+  let rec exrec = function
+    | -1 -> false
+    | n -> (f v.(n)) || (exrec (n-1))
+  in 
+  exrec ((Array.length v)-1) 
+
+let array_for_all f v = 
+  let rec allrec = function
+    | -1 -> true
+    | n -> (f v.(n)) && (allrec (n-1))
+  in 
+  allrec ((Array.length v)-1) 
+
+let array_for_all2 f v1 v2 =
+  let rec allrec = function
+    | -1 -> true
+    | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
+  in 
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && allrec (pred lv1) 
+
+let array_for_all3 f v1 v2 v3 =
+  let rec allrec = function
+    | -1 -> true
+    | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
+  in 
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) 
+
+let array_for_all4 f v1 v2 v3 v4 =
+  let rec allrec = function
+    | -1 -> true
+    | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
+  in 
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 &&
+  lv1 = Array.length v3 &&
+  lv1 = Array.length v4 &&
+    allrec (pred lv1) 
+
+let array_hd v = 
+  match Array.length v with
+    | 0 -> failwith "array_hd"
+    | _ -> v.(0)
+
+let array_tl v = 
+  match Array.length v with
+    | 0 -> failwith "array_tl"
+    | n -> Array.sub v 1 (pred n)
+
+let array_last v =
+  match Array.length v with
+    | 0 -> failwith "array_last"
+    | n -> v.(pred n)
+
+let array_cons e v = Array.append [|e|] v
+
+let array_fold_right_i f v a =
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f k v.(k) a) k in
+  fold a (Array.length v)
+
+let array_fold_left_i f v a =
+  let n = Array.length a in
+  let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in
+  fold 0 v
+
+let array_fold_right2 f v1 v2 a =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f v1.(k) v2.(k) a) k in
+  if Array.length v2 <> lv1 then invalid_arg "array_fold_right2";
+  fold a lv1
+
+let array_fold_left2 f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n = 
+    if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
+  fold a 0
+
+let array_fold_left2_i f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n = 
+    if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
+  fold a 0
+
+let array_fold_left_from n f a v = 
+  let rec fold a n =
+    if n >= Array.length v then a else fold (f a v.(n)) (succ n)
+  in 
+  fold a n
+
+let array_fold_right_from n f v a = 
+  let rec fold n =
+    if n >= Array.length v then a else f v.(n) (fold (succ n))
+  in 
+  fold n
+
+let array_app_tl v l = 
+  if Array.length v = 0 then invalid_arg "array_app_tl";
+  array_fold_right_from 1 (fun e l -> e::l) v l
+
+let array_list_of_tl v =
+  if Array.length v = 0 then invalid_arg "array_list_of_tl";
+  array_fold_right_from 1 (fun e l -> e::l) v []
+
+let array_map_to_list f v =
+  List.map f (Array.to_list v)
+
+let array_chop n v =
+  let vlen = Array.length v in
+  if n > vlen then failwith "array_chop";
+  (Array.sub v 0 n, Array.sub v n (vlen-n))
+
+exception Local of int
+
+(* If none of the elements is changed by f we return ar itself.
+   The for loop looks for the first such an element.
+   If found it is temporarily stored in a ref and the new array is produced, 
+   but f is not re-applied to elements that are already checked *)
+let array_smartmap f ar = 
+  let ar_size = Array.length ar in
+  let aux = ref None in
+  try
+    for i = 0 to ar_size-1 do
+      let a = ar.(i) in
+      let a' = f a in
+	if a != a' then (* pointer (in)equality *) begin
+	  aux := Some a';
+	  raise (Local i)
+	end
+    done;
+    ar
+  with
+      Local i -> 
+	let copy j = 
+	  if j<i then ar.(j) 
+	  else if j=i then 
+	    match !aux with Some a' -> a' | None -> failwith "Error"
+	  else f (ar.(j))
+	in
+	  Array.init ar_size copy
+
+let array_map2 f v1 v2 =
+  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
+  if Array.length v1 == 0 then 
+    [| |] 
+  else begin
+    let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
+    for i = 1 to pred (Array.length v1) do
+      res.(i) <- f v1.(i) v2.(i)
+    done;
+    res
+  end
+
+let array_map2_i f v1 v2 =
+  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
+  if Array.length v1 == 0 then 
+    [| |] 
+  else begin
+    let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
+    for i = 1 to pred (Array.length v1) do
+      res.(i) <- f i v1.(i) v2.(i)
+    done;
+    res
+  end
+
+let array_map3 f v1 v2 v3 =
+  if Array.length v1 <> Array.length v2 ||
+     Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
+  if Array.length v1 == 0 then 
+    [| |] 
+  else begin
+    let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
+    for i = 1 to pred (Array.length v1) do
+      res.(i) <- f v1.(i) v2.(i) v3.(i)
+    done;
+    res
+  end
+
+let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *)
+  let l = Array.length a in (* (even if so), then we rewrite it *)
+  if l = 0 then [||] else begin
+    let r = Array.create l (f a.(0)) in
+    for i = 1 to l - 1 do
+      r.(i) <- f a.(i)
+    done;
+    r
+  end
+
+let array_map_left_pair f a g b =
+  let l = Array.length a in
+  if l = 0 then [||],[||] else begin
+    let r = Array.create l (f a.(0)) in
+    let s = Array.create l (g b.(0)) in
+    for i = 1 to l - 1 do
+      r.(i) <- f a.(i);
+      s.(i) <- g b.(i)
+    done;
+    r, s
+  end
+
+(* Matrices *)
+
+let matrix_transpose mat =
+  List.fold_right (List.map2 (fun p c -> p::c)) mat
+    (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat))
+
+(* Functions *)
+
+let identity x = x
+
+let compose f g x = f (g x)
+
+let iterate f = 
+  let rec iterate_f n x =
+    if n <= 0 then x else iterate_f (pred n) (f x)
+  in 
+  iterate_f
+
+let repeat n f x =
+  for i = 1 to n do f x done
+
+let iterate_for a b f x =
+  let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
+  iterate a x
+ 
+(* Misc *)
+
+type ('a,'b) union = Inl of 'a | Inr of 'b
+
+module Intset = Set.Make(struct type t = int let compare = compare end)
+
+module Intmap = Map.Make(struct type t = int let compare = compare end)
+
+let intmap_in_dom x m =
+  try let _ = Intmap.find x m in true with Not_found -> false
+
+let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
+
+let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
+
+let interval n m = 
+  let rec interval_n (l,m) =
+    if n > m then l else interval_n (m::l,pred m)
+  in 
+  interval_n ([],m)
+
+let in_some x = Some x
+
+let out_some = function
+  | Some x -> x
+  | None -> failwith "out_some"
+
+let option_app f = function
+  | None -> None
+  | Some x -> Some (f x)
+
+let option_cons a l = match a with
+  | Some x -> x::l
+  | None -> l
+
+let option_fold_left2 f e a b = match (a,b) with
+  | Some x, Some y -> f e x y
+  | _ -> e
+
+let option_fold_right f a e = match a with
+  | Some x -> f x e
+  | _ -> e
+
+let option_compare f a b = match (a,b) with
+  | None, None -> true
+  | Some a', Some b' -> f a' b'
+  | _ -> failwith "option_compare"
+
+let option_iter f = function
+  | None -> ()
+  | Some x -> f x
+
+let option_smartmap f a = match a with
+  | None -> a
+  | Some x -> let x' = f x in if x'==x then a else Some x'
+
+let map_succeed f = 
+  let rec map_f = function 
+    | [] -> []
+    |  h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
+  in 
+  map_f 
+
+(* Pretty-printing *)
+  
+let pr_spc = spc
+let pr_fnl = fnl
+let pr_int = int
+let pr_str = str
+let pr_coma () = str "," ++ spc ()
+let pr_semicolon () = str ";" ++ spc ()
+let pr_bar () = str "|" ++ spc ()
+
+let pr_ord n =
+  let suff = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
+  int n ++ str suff
+
+let rec prlist elem l = match l with 
+  | []   -> mt ()
+  | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
+
+let rec prlist_with_sep sep elem l = match l with
+  | []   -> mt ()
+  | [h]  -> elem h
+  | h::t ->
+      let e = elem h and s = sep() and r = prlist_with_sep sep elem t in
+      e ++ s ++ r
+
+let pr_vertical_list pr = function
+  | [] -> str "none" ++ fnl ()
+  | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
+      
+let prvecti elem v =
+  let n = Array.length v in
+  let rec pr i =
+    if i = 0 then 
+      elem 0 v.(0)
+    else
+      let r = pr (i-1) and e = elem i v.(i) in r ++ e
+  in
+  if n = 0 then mt () else pr (n - 1)
+
+let prvect_with_sep sep elem v =
+  let rec pr n =
+    if n = 0 then 
+      elem v.(0)
+    else 
+      let r = pr (n-1) and s = sep() and e = elem v.(n) in 
+      r ++ s ++ e
+      in
+  let n = Array.length v in
+  if n = 0 then mt () else pr (n - 1)
+
+(*s Size of ocaml values. *)
+
+module Size = struct
+  
+  open Obj
+
+  (*s Pointers already visited are stored in a hash-table, where
+      comparisons are done using physical equality. *)
+
+  module H = Hashtbl.Make(
+    struct 
+      type t = Obj.t 
+      let equal = (==) 
+      let hash o = Hashtbl.hash (magic o : int)
+    end)
+	       
+  let node_table = (H.create 257 : unit H.t)
+		     
+  let in_table o = try H.find node_table o; true with Not_found -> false
+      
+  let add_in_table o = H.add node_table o ()
+			 
+  let reset_table () = H.clear node_table
+			 
+  (*s Objects are traversed recursively, as soon as their tags are less than
+      [no_scan_tag]. [count] records the numbers of words already visited. *)
+
+  let size_of_double = size (repr 1.0)
+			 
+  let count = ref 0
+		
+  let rec traverse t =
+    if not (in_table t) then begin
+      add_in_table t;
+      if is_block t then begin
+	let n = size t in
+	let tag = tag t in
+	if tag < no_scan_tag then begin
+	  count := !count + 1 + n;
+	  for i = 0 to n - 1 do
+      	    let f = field t i in 
+	    if is_block f then traverse f
+	  done
+	end else if tag = string_tag then
+	  count := !count + 1 + n 
+	else if tag = double_tag then
+	  count := !count + size_of_double
+	else if tag = double_array_tag then
+	  count := !count + 1 + size_of_double * n 
+	else
+	  incr count
+      end
+    end
+      
+  (*s Sizes of objects in words and in bytes. The size in bytes is computed
+      system-independently according to [Sys.word_size]. *)
+
+  let size_w o =
+    reset_table ();
+    count := 0;
+    traverse (repr o);
+    !count
+
+  let size_b o = (size_w o) * (Sys.word_size / 8)
+
+  let size_kb o = (size_w o) / (8192 / Sys.word_size)
+
+end
+
+let size_w = Size.size_w
+let size_b = Size.size_b
+let size_kb = Size.size_kb
+
+(*s Total size of the allocated ocaml heap. *)
+
+let heap_size () =
+  let stat = Gc.stat ()
+  and control = Gc.get () in
+  let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
+  (max_words_total * Sys.word_size / 8)
+
+let heap_size_kb () = (heap_size () + 1023) / 1024
+
+(*s interruption *)
+
+let interrupt = ref false
+let check_for_interrupt () = 
+  if !interrupt then begin interrupt := false; raise Sys.Break end
+
diff --git a/lib/util.mli b/lib/util.mli
new file mode 100644
index 00000000..19f05ea4
--- /dev/null
+++ b/lib/util.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: util.mli,v 1.84.2.2 2004/07/16 20:43:46 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+(*i*)
+
+(* This module contains numerous utility functions on strings, lists,
+   arrays, etc. *)
+
+(*s Errors. [Anomaly] is used for system errors and [UserError] for the
+   user's ones. *)
+
+exception Anomaly of string * std_ppcmds
+val anomaly : string -> 'a
+val anomalylabstrm : string -> std_ppcmds -> 'a
+
+exception UserError of string * std_ppcmds
+val error : string -> 'a
+val errorlabstrm : string -> std_ppcmds -> 'a
+
+(* [todo] is for running of an incomplete code its implementation is
+   "do nothing" (or print a message), but this function should not be
+   used in a released code *)
+
+val todo : string -> unit
+
+type loc = Compat.loc
+
+type 'a located = loc * 'a
+
+val unloc : loc -> int * int
+val make_loc : int * int -> loc
+val dummy_loc : loc
+val anomaly_loc : loc * string * std_ppcmds -> 'a
+val user_err_loc : loc * string * std_ppcmds -> 'a
+val invalid_arg_loc : loc * string -> 'a
+val join_loc : loc -> loc -> loc
+
+(* Like [Exc_located], but specifies the outermost file read, the
+   input buffer associated to the location of the error (or the module name
+   if boolean is true), and the error itself. *)
+
+exception Error_in_file of string * (bool * string * loc) * exn
+
+(*s Projections from triplets *)
+
+val pi1 : 'a * 'b * 'c -> 'a
+val pi2 : 'a * 'b * 'c -> 'b
+val pi3 : 'a * 'b * 'c -> 'c
+
+(*s Chars. *)
+
+val is_letter : char -> bool
+val is_digit : char -> bool
+val is_ident_tail : char -> bool
+
+(*s Strings. *)
+
+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 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
+val list_intersect : 'a list -> 'a list -> 'a list
+val list_union : 'a list -> 'a list -> 'a list
+val list_unionq : 'a list -> 'a list -> 'a list
+val list_subtract : 'a list -> 'a list -> 'a list
+val list_subtractq : 'a list -> 'a list -> 'a list
+val list_chop : int -> 'a list -> 'a list * 'a list
+(* [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
+val list_tabulate : (int -> 'a) -> int -> 'a list
+val list_assign : 'a list -> int -> 'a -> 'a list
+val list_distinct : 'a list -> bool
+val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
+
+(* [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
+   [ f ai == ai], then [list_smartmap f l==l] *)
+val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
+val list_map_left : ('a -> 'b) -> 'a list -> 'b list
+val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+val list_map2_i : 
+  (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+val list_map3 :
+  ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+val list_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_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
+val list_try_find : ('a -> 'b) -> 'a list -> 'b
+val list_uniquize : 'a list -> 'a list
+val list_subset : 'a list -> 'a list -> bool
+val list_splitby : ('a -> bool) -> 'a list -> 'a list * 'a list
+val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+val list_firstn : int -> 'a list -> 'a list
+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
+(* [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 *)
+val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+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_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+
+(*s Arrays. *)
+
+val array_exists : ('a -> bool) -> 'a array -> bool
+val array_for_all : ('a -> bool) -> 'a array -> bool
+val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+val array_for_all3 : ('a -> 'b -> 'c -> bool) ->
+  'a array -> 'b array -> 'c array -> bool
+val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+  'a array -> 'b array -> 'c array -> 'd array -> bool
+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_fold_right_i : 
+  (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+val array_fold_right2 :
+  ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+val array_fold_left2 : 
+  ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+val array_fold_left2_i : 
+  (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
+val array_app_tl : 'a array -> 'a list -> 'a list
+val array_list_of_tl : 'a array -> 'a list
+val array_map_to_list : ('a -> 'b) -> 'a array -> 'b list
+val array_chop : int -> 'a array -> 'a array * 'a array
+val array_smartmap : ('a -> 'a) -> 'a array -> 'a array
+val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+val array_map3 : 
+  ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+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
+
+(*s Matrices *)
+
+val matrix_transpose : 'a list list -> 'a list list
+
+(*s Functions. *)
+
+val identity : 'a -> 'a
+val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+val iterate : ('a -> 'a) -> int -> 'a -> 'a
+val repeat : int -> ('a -> unit) -> 'a -> unit
+val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
+
+(*s Misc. *)
+
+type ('a,'b) union = Inl of 'a | Inr of 'b
+
+module Intset : Set.S with type elt = int
+
+module Intmap : Map.S with type key = int
+
+val intmap_in_dom : int -> 'a Intmap.t -> bool
+val intmap_to_list : 'a Intmap.t -> (int * 'a) list
+val intmap_inv : 'a Intmap.t -> 'a -> int list
+
+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_cons : 'a option -> 'a list -> 'a list
+val option_fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
+val option_fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option ->
+  'c option -> 'a
+val option_iter : ('a -> unit) -> 'a option -> unit
+val option_compare : ('a -> 'b -> bool) -> 'a option -> 'b option -> bool 
+val option_smartmap : ('a -> 'a) -> 'a option -> 'a option
+
+(* In [map_succeed f l] an element [a] is removed if [f a] raises *)
+(* [Failure _] otherwise behaves as [List.map f l] *)
+
+val map_succeed : ('a -> 'b) -> 'a list -> 'b list
+
+(*s Pretty-printing. *)
+
+val pr_spc : unit -> std_ppcmds
+val pr_fnl : unit -> std_ppcmds
+val pr_int : int -> std_ppcmds
+val pr_str : string -> std_ppcmds
+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 prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+val prlist_with_sep :
+   (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds
+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
+
+(*s Size of an ocaml value (in words, bytes and kilobytes). *)
+
+val size_w : 'a -> int
+val size_b : 'a -> int
+val size_kb : 'a -> int
+
+(*s Total size of the allocated ocaml heap. *)
+
+val heap_size : unit -> int
+val heap_size_kb : unit -> int
+
+(*s Coq interruption: set the following boolean reference to interrupt Coq
+    (it eventually raises [Break], simulating a Ctrl-C) *)
+
+val interrupt : bool ref
+val check_for_interrupt : unit -> unit
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
new file mode 100644
index 00000000..a030284c
--- /dev/null
+++ b/library/decl_kinds.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: decl_kinds.ml,v 1.6.2.1 2004/07/16 19:30:33 herbelin Exp $ *)
+
+(* Informal mathematical status of declarations *)
+
+type locality_flag = (*bool (* local = true; global = false *)*)
+  | Local
+  | Global
+
+(* Kinds used at parsing time *)
+
+type theorem_kind =
+  | Theorem
+  | Lemma
+  | Fact
+  | Remark
+
+type definition_object_kind =
+  | Definition
+  | Coercion
+  | SubClass
+  | CanonicalStructure
+
+type strength = locality_flag (* For compatibility *)
+
+type type_as_formula_kind = Definitional | Logical | Conjectural
+
+(* [assumption_kind] 
+
+                |  Local      | Global
+   ------------------------------------
+   Definitional |  Variable   | Parameter
+   Logical      |  Hypothesis | Axiom
+
+*)
+type assumption_kind = locality_flag * type_as_formula_kind
+
+type definition_kind = locality_flag * definition_object_kind
+
+(* Kinds used in proofs *)
+
+type global_goal_kind =
+  | DefinitionBody
+  | Proof of theorem_kind
+
+type goal_kind =
+  | IsGlobal of global_goal_kind
+  | IsLocal
+
+(* 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
+
+(* Utils *)
+
+let theorem_kind_of_goal_kind = function
+  | DefinitionBody -> IsDefinition
+  | Proof s -> IsProof s
+
diff --git a/library/declare.ml b/library/declare.ml
new file mode 100644
index 00000000..8b9dfeda
--- /dev/null
+++ b/library/declare.ml
@@ -0,0 +1,402 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: declare.ml,v 1.128.2.1 2004/07/16 19:30:34 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Sign
+open Declarations
+open Entries
+open Inductive
+open Indtypes
+open Reduction
+open Type_errors
+open Typeops
+open Libobject
+open Lib
+open Impargs
+open Nametab
+open Safe_typing
+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] *)
+
+open Nametab
+
+let strength_min (stre1,stre2) =
+  if stre1 = Local or stre2 = Local then Local else Global
+
+let string_of_strength = function
+  | Local -> "(local)"
+  | 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 if_xml f x = if !Options.xml_export then f x else ()
+
+let set_xml_declare_variable f = xml_declare_variable := if_xml f
+let set_xml_declare_constant f = xml_declare_constant := if_xml f
+let set_xml_declare_inductive f = xml_declare_inductive := if_xml f
+
+(* Section variables. *)
+
+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 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
+
+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))) =
+  (* Constr raisonne sur les noms courts *)
+  if Idmap.mem id !vartab then
+    errorlabstrm "cache_variable" (pr_id id ++ str " already exists");
+  let vd = match d with (* Fails if not well-typed *)
+    | SectionLocalAssum ty ->
+        let cst = Global.push_named_assum (id,ty) in
+        let (_,bd,ty) = Global.lookup_named id in
+        CheckedSectionLocalAssum (ty,cst)
+    | SectionLocalDef (c,t,opaq) -> 
+        let cst = Global.push_named_def (id,c,t) in
+        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);
+  vartab := Idmap.add id (p,vd,mk) !vartab
+
+let (in_variable, out_variable) =
+  declare_object { (default_object "VARIABLE") with
+    cache_function = cache_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
+  !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
+
+let csttab = ref (Spmap.empty : global_kind Spmap.t)
+
+let _ = Summary.declare_summary "CONSTANT"
+	  { Summary.freeze_function = (fun () -> !csttab);
+	    Summary.unfreeze_function = (fun ft -> csttab := ft);
+	    Summary.init_function = (fun () -> csttab := Spmap.empty);
+	    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)
+
+(* Opening means making the name without its module qualification available *)
+let open_constant i ((sp,kn),_) =
+  Nametab.push (Nametab.Exactly i) sp (ConstRef kn)
+
+(* 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 export_constant cst = Some (dummy_constant cst)
+
+let classify_constant (_,cst) = Substitute (dummy_constant cst)
+
+let (in_constant, out_constant) =
+  declare_object { (default_object "CONSTANT") with
+    cache_function = cache_constant;
+    load_function = load_constant;
+    open_function = open_constant;
+    classify_function = classify_constant;
+    subst_function = ident_subst_function;
+    export_function = export_constant } 
+
+let hcons_constant_declaration = function
+  | DefinitionEntry ce ->
+      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 }
+  | cd -> cd
+
+let declare_constant_common id discharged_hyps (cd,kind) =
+  let (sp,kn as oname) = add_leaf id (in_constant (cd,kind)) in
+  declare_constant_implicits kn;
+  Symbols.declare_ref_arguments_scope (ConstRef kn);
+  Dischargedhypsmap.set_discharged_hyps sp discharged_hyps;
+  oname
+
+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 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 inductive_names sp kn mie =
+  let (dp,_) = repr_path sp in
+  let names, _ = 
+    List.fold_left
+      (fun (names, n) ind ->
+	 let ind_p = (kn,n) in
+	 let names, _ =
+	   List.fold_left
+	     (fun (names, p) l ->
+		let sp = 
+		  Libnames.make_path dp l
+		in
+		  ((sp, ConstructRef (ind_p,p)) :: names, p+1))
+	     (names, 1) ind.mind_entry_consnames in
+	 let sp = Libnames.make_path dp ind.mind_entry_typename
+	 in
+	   ((sp, IndRef ind_p) :: names, n+1))
+      ([], 0) mie.mind_entry_inds
+  in names
+
+
+let check_exists_inductive (sp,_) =
+  (if Idmap.mem (basename sp) !vartab then
+    errorlabstrm "cache_inductive" 
+      (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")
+
+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 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 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 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;
+  mind_entry_lc = []
+}
+
+(* Hack to reduce the size of .vo: we keep only what load/open needs *)
+let dummy_inductive_entry m = {
+  mind_entry_finite = true;
+  mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds }
+
+let export_inductive x = Some (dummy_inductive_entry x)
+
+let (in_inductive, out_inductive) =
+  declare_object {(default_object "INDUCTIVE") with 
+    cache_function = cache_inductive;
+    load_function = load_inductive;
+    open_function = open_inductive;
+    classify_function = (fun (_,a) -> Substitute (dummy_inductive_entry a));
+    subst_function = ident_subst_function;
+    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 [] ;
+  !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 = 
+  try let _ = Spmap.find sp !csttab in true with Not_found -> false
+
+let constant_strength sp = Global
+let constant_kind sp = Spmap.find sp !csttab
+
+let get_variable id = 
+  let (p,x,_) = Idmap.find id !vartab in
+  match x with
+    | 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 =
+  let (p,_,_) = Idmap.find id !vartab in Libnames.make_path p id
+
+let variable_opacity id =
+  let (_,x,_) = Idmap.find id !vartab in
+  match x with
+    | CheckedSectionLocalDef (c,ty,cst,opaq) -> opaq
+    | CheckedSectionLocalAssum (ty,cst) -> false (* any.. *)
+
+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
+
+(* Global references. *)
+
+let first f v =
+  let n = Array.length v in
+  let rec look_for i =
+    if i = n then raise Not_found;
+    try f i v.(i) with Not_found -> look_for (succ i)
+  in
+  look_for 0
+
+let mind_oper_of_id sp id mib =
+  first
+    (fun tyi mip ->
+       if id = mip.mind_typename then 
+	 IndRef (sp,tyi)
+       else
+	 first 
+	   (fun cj cid -> 
+	      if id = cid then 
+		ConstructRef ((sp,tyi),succ cj) 
+	      else raise Not_found) 
+	   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 ->
+      try
+        let (p,_,_) = Idmap.find id !vartab in
+        if dir=p then id::sec_ids else sec_ids
+      with Not_found -> sec_ids)
+    (Environ.named_context (Global.env()))
+    ~init:[]
+
+let is_section_variable = function
+  | VarRef _ -> true
+  | _ -> false
+
+let strength_of_global = function
+  | VarRef _ -> Local
+  | IndRef _ | ConstructRef _ | ConstRef _ -> Global
diff --git a/library/declare.mli b/library/declare.mli
new file mode 100644
index 00000000..968be059
--- /dev/null
+++ b/library/declare.mli
@@ -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: declare.mli,v 1.74.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Libnames
+open Term
+open Sign
+open Declarations
+open Entries
+open Indtypes
+open Safe_typing
+open Nametab
+open Decl_kinds
+(*i*)
+
+(* This module provides the official functions to declare new variables, 
+   parameters, constants and inductive types. Using the following functions
+   will add the entries in the global environment (module [Global]), will
+   register the declarations in the library (module [Lib]) --- so that the
+   reset works properly --- and will fill some global tables such as 
+   [Nametab] and [Impargs]. *)
+
+open Nametab
+
+(* Declaration of local constructions (Variable/Hypothesis/Local) *)
+
+type section_variable_entry =
+  | SectionLocalDef of constr * types option * bool (* opacity *)
+  | SectionLocalAssum of types
+
+type variable_declaration = dir_path * section_variable_entry * local_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
+
+(* [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_internal_constant :
+  identifier -> constant_declaration -> object_name
+
+val redeclare_constant :
+ identifier -> Dischargedhypsmap.discharged_hyps -> 
+      Cooking.recipe * global_kind -> unit
+
+(* [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
+
+(*s Corresponding test and access functions. *)
+
+val is_constant : section_path -> bool
+val constant_strength : section_path -> strength
+val constant_kind : section_path -> global_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 find_section_variable : variable -> section_path
+val last_section_hyps : dir_path -> identifier list
+val clear_proofs : named_context -> named_context
+
+(*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_inductive : (bool * object_name -> unit) -> unit
diff --git a/library/declaremods.ml b/library/declaremods.ml
new file mode 100644
index 00000000..b968a432
--- /dev/null
+++ b/library/declaremods.ml
@@ -0,0 +1,820 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: declaremods.ml,v 1.18.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Declarations
+open Entries
+open Libnames
+open Libobject
+open Lib
+open Nametab
+
+(* modules and components *)
+
+
+(* This type is a functional closure of substitutive lib_objects.
+
+   The first part is a partial substitution (which will be later
+   applied to lib_objects when completed).
+
+   The second one is a list of bound identifiers which is nonempty
+   only if the objects are owned by a fuctor
+
+   The third one is the "self" ident of the signature (or structure),
+   which should be substituted in lib_objects with the real name of
+   the module.
+
+   The fourth one is the segment itself which can contain references
+   to identifiers in the domain of the substitution or in other two
+   parts. These references are invalid in the current scope and
+   therefore must be substitued with valid names before use.
+
+*)
+type substitutive_objects = 
+    substitution * mod_bound_id list * mod_self_id * lib_objects
+
+
+(* For each module, we store the following things:
+
+   In modtab_substobjs: substitutive_objects 
+     when we will do Module M:=N, the objects of N will be reloaded 
+     with M after substitution
+
+   In modtab_objects: "substituted objects" @ "keep objects"
+
+   substituted objects - 
+     roughly the objects above after the substitution - we need to 
+     keep them to call open_object when the module is opened (imported)
+ 
+   keep objects -
+     The list of non-substitutive objects - as above, for each of 
+     them we will call open_object when the module is opened 
+     
+   (Some) Invariants:
+   * If the module is a functor, the two latter lists are empty.
+
+   * Module objects in substitutive_objects part have empty substituted 
+     objects.
+
+   * Modules which where created with Module M:=mexpr or with 
+     Module M:SIG. ... End M. have the keep list empty.
+*)
+let modtab_substobjs = 
+  ref (MPmap.empty : substitutive_objects MPmap.t)
+let modtab_objects = 
+  ref (MPmap.empty : (object_prefix * lib_objects) MPmap.t)
+
+
+(* currently started interactive module (if any) - its arguments (if it
+   is a functor) and declared output type *)
+let openmod_info = 
+  ref (([],None,None) : mod_bound_id list * module_type_entry option 
+                                          * module_type_body option) 
+
+let _ = Summary.declare_summary "MODULE-INFO"
+	  { Summary.freeze_function = (fun () -> 
+					 !modtab_substobjs,
+					 !modtab_objects,
+					 !openmod_info);
+	    Summary.unfreeze_function = (fun (sobjs,objs,info) -> 
+					   modtab_substobjs := sobjs;
+					   modtab_objects := objs;
+					   openmod_info := info);
+	    Summary.init_function = (fun () -> 
+				       modtab_substobjs := MPmap.empty;
+				       modtab_objects := MPmap.empty;
+				       openmod_info := ([],None,None));
+	    Summary.survive_module = false;
+	    Summary.survive_section = false }
+
+(* auxiliary functions to transform section_path and kernel_name given
+   by Lib into module_path and dir_path needed for modules *)
+
+let mp_of_kn kn = 
+  let mp,sec,l = repr_kn kn in 
+    if sec=empty_dirpath then 
+      MPdot (mp,l) 
+    else
+      anomaly ("Non-empty section in module name!" ^ string_of_kn kn)
+
+let dir_of_sp sp = 
+  let dir,id = repr_path sp in
+    extend_dirpath dir id
+
+let msid_of_mp = function
+    MPself msid -> msid
+  | _ -> anomaly "'Self' module path expected!"
+
+let msid_of_prefix (_,(mp,sec)) = 
+  if sec=empty_dirpath then 
+    msid_of_mp mp
+  else
+    anomaly ("Non-empty section in module name!" ^ 
+	     string_of_mp mp ^ "." ^ string_of_dirpath sec)
+
+
+(* This function checks if the type calculated for the module [mp] is
+   a subtype of [sub_mtb]. Uses only the global environment. *)
+let check_subtypes mp sub_mtb =
+  let env = Global.env () in
+  let mtb = (Environ.lookup_module mp env).mod_type in
+  let _ = Environ.add_constraints 
+	    (Subtyping.check_subtypes env mtb sub_mtb) 
+  in
+    ()  (* The constraints are checked and forgot immediately! *) 
+
+
+(* This function registers the visibility of the module and iterates
+   through its components. It is called by plenty module functions *)
+
+let do_module exists what iter_objects i dir mp substobjs objects =
+  let prefix = (dir,(mp,empty_dirpath)) in
+  let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
+  let vis = 
+    if exists then 
+      if 
+	try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo 
+	with Not_found -> false 
+      then
+	Nametab.Exactly i
+      else
+	errorlabstrm (what^"_module") 
+	  (pr_dirpath dir ++ str " should already exist!") 
+    else
+      if Nametab.exists_dir dir then
+	errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists")
+      else
+	Nametab.Until i
+  in
+    Nametab.push_dir vis dir dirinfo;
+    modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
+    match objects with
+	Some seg -> 
+	  modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects;
+	  iter_objects (i+1) prefix seg	  
+      | None ->  ()
+
+    
+let conv_names_do_module exists what iter_objects i 
+      (sp,kn) substobjs substituted =
+  let dir,mp = dir_of_sp sp, mp_of_kn kn in
+  do_module exists what iter_objects i dir mp substobjs substituted
+
+(* Interactive modules and module types cannot be recached! cache_mod*
+   functions can be called only once (and "end_mod*" set the flag to
+   false then)
+*)
+
+let cache_module ((sp,kn as oname),(entry,substobjs,substituted)) =
+  let _ = match entry with
+    | None ->
+	anomaly "You must not recache interactive modules!"
+    | Some (me,sub_mte_o) ->
+	let sub_mtb_o = match sub_mte_o with 
+	    None -> None
+	  | Some mte -> Some (Mod_typing.translate_modtype (Global.env()) mte)
+	in
+
+	let mp = Global.add_module (basename sp) me in
+	if mp <> mp_of_kn kn then
+	  anomaly "Kernel and Library names do not match";
+	  
+	match sub_mtb_o with
+	    None -> ()
+	  | Some sub_mtb -> check_subtypes mp sub_mtb
+
+  in
+  conv_names_do_module false "cache" load_objects 1 oname substobjs substituted
+
+
+(* TODO: This check is not essential *)
+let check_empty s = function
+     | None -> ()
+     | Some _ -> 
+	 anomaly ("We should never have full info in " ^ s^"!")
+
+
+(* When this function is called the module itself is already in the
+   environment. This function loads its objects only *)
+
+let load_module i (oname,(entry,substobjs,substituted)) =
+  (* TODO: This check is not essential *)
+  check_empty "load_module" entry;
+  conv_names_do_module false "load" load_objects i oname substobjs substituted
+
+
+let open_module i (oname,(entry,substobjs,substituted)) =
+  (* TODO: This check is not essential *)
+  check_empty "open_module" entry;
+  conv_names_do_module true "open" open_objects i oname substobjs substituted
+
+
+let subst_substobjs dir mp (subst,mbids,msid,objs) =
+  match mbids with
+    | [] -> 
+	let prefix = dir,(mp,empty_dirpath) in
+	  Some (subst_objects prefix (add_msid msid mp subst) objs)
+    | _ -> None
+
+
+let subst_module ((sp,kn),subst,(entry,substobjs,_)) =
+  check_empty "subst_module" entry;
+  let dir,mp = dir_of_sp sp, mp_of_kn kn in
+  let (sub,mbids,msid,objs) = substobjs in
+  let subst' = join sub subst in
+  (* substitutive_objects get the new substitution *)
+  let substobjs = (subst',mbids,msid,objs) in
+  (* if we are not a functor - calculate substitued.
+     We add "msid |-> mp" to the substitution *)
+  let substituted = subst_substobjs dir mp substobjs
+  in
+    (None,substobjs,substituted)
+
+
+let classify_module (_,(_,substobjs,_)) =
+  Substitute (None,substobjs,None)
+
+let (in_module,out_module) =
+  declare_object {(default_object "MODULE") with
+    cache_function = cache_module;
+    load_function = load_module;
+    open_function = open_module;
+    subst_function = subst_module;
+    classify_function = classify_module;
+    export_function = (fun _ -> anomaly "No modules in sections!") }
+
+
+let cache_keep _ = anomaly "This module should not be cached!"
+
+let load_keep i ((sp,kn),seg) = 
+  let mp = mp_of_kn kn in
+  let prefix = dir_of_sp sp, (mp,empty_dirpath) in
+    begin 
+      try
+	let prefix',objects = MPmap.find mp !modtab_objects in
+	  if prefix' <> prefix then 
+	    anomaly "Two different modules with the same path!";
+	  modtab_objects := MPmap.add mp (prefix,objects@seg) !modtab_objects;
+      with
+	  Not_found -> anomaly "Keep objects before substitutive"
+    end;
+    load_objects i prefix seg
+
+let open_keep i ((sp,kn),seg) = 
+  let dirpath,mp = dir_of_sp sp, mp_of_kn kn in
+    open_objects i (dirpath,(mp,empty_dirpath)) seg
+
+let (in_modkeep,out_modkeep) = 
+  declare_object {(default_object "MODULE KEEP OBJECTS") with
+    cache_function = cache_keep;
+    load_function = load_keep;
+    open_function = open_keep;
+    export_function = (fun _ -> anomaly "No modules in sections!") }
+
+(* we remember objects for a module type. In case of a declaration:
+   Module M:SIG:=...
+   The module M gets its objects from SIG
+*)
+let modtypetab =
+  ref (KNmap.empty : substitutive_objects KNmap.t)
+
+(* currently started interactive module type. We remember its arguments
+   if it is a functor type *)
+let openmodtype_info =
+  ref ([] : mod_bound_id list)
+
+let _ = Summary.declare_summary "MODTYPE-INFO"
+	  { Summary.freeze_function = (fun () ->
+					 !modtypetab,!openmodtype_info);
+	    Summary.unfreeze_function = (fun ft ->
+					   modtypetab := fst ft;
+					   openmodtype_info := snd ft);
+	    Summary.init_function = (fun () ->
+				       modtypetab := KNmap.empty;
+				       openmodtype_info := []);
+	    Summary.survive_module = false;
+	    Summary.survive_section = true }
+
+
+
+
+let cache_modtype ((sp,kn),(entry,modtypeobjs)) =
+  let _ = 
+    match entry with
+      | None ->
+	  anomaly "You must not recache interactive module types!"
+      | Some mte ->
+	  let kn' = Global.add_modtype (basename sp) mte in
+	  if kn' <> kn then
+	    anomaly "Kernel and Library names do not match"
+  in
+
+  if Nametab.exists_modtype sp then
+    errorlabstrm "cache_modtype"
+      (pr_sp sp ++ str " already exists") ;
+
+  Nametab.push_modtype (Nametab.Until 1) sp kn;
+
+  modtypetab := KNmap.add kn modtypeobjs !modtypetab
+
+
+let load_modtype i ((sp,kn),(entry,modtypeobjs)) =
+  check_empty "load_modtype" entry;
+
+  if Nametab.exists_modtype sp then
+    errorlabstrm "cache_modtype"
+      (pr_sp sp ++ str " already exists") ;
+
+  Nametab.push_modtype (Nametab.Until i) sp kn;
+    
+  modtypetab := KNmap.add kn modtypeobjs !modtypetab
+
+
+let open_modtype i ((sp,kn),(entry,_)) =
+  check_empty "open_modtype" entry;
+
+  if 
+    try Nametab.locate_modtype (qualid_of_sp sp) <> kn 
+    with Not_found -> true
+  then
+    errorlabstrm ("open_modtype") 
+      (pr_sp sp ++ str " should already exist!");
+
+  Nametab.push_modtype (Nametab.Exactly i) sp kn
+
+
+let subst_modtype (_,subst,(entry,(subs,mbids,msid,objs))) =
+  check_empty "subst_modtype" entry;
+  (entry,(join subs subst,mbids,msid,objs))
+
+
+let classify_modtype (_,(_,substobjs)) =
+  Substitute (None,substobjs)
+
+
+let (in_modtype,out_modtype) =
+    declare_object {(default_object "MODULE TYPE") with
+      cache_function = cache_modtype;
+      open_function = open_modtype;
+      load_function = load_modtype;
+      subst_function = subst_modtype;
+      classify_function = classify_modtype;
+      export_function = in_some }
+
+
+
+let replace_module_object id (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' ->
+	  if object_tag obj = "MODULE" then
+	    (id, in_module (None,modobjs,None))::tail
+	  else error "MODULE expected!"
+      | lobj::tail -> lobj::replace_id tail
+    in
+      (subst, mbids, msid, replace_id lib_stack)
+
+let abstract_substobjs mbids1 (subst, mbids2, msid, lib_stack) =
+  (subst, mbids1@mbids2, msid, lib_stack)
+
+
+let rec get_modtype_substobjs = function
+    MTEident ln -> KNmap.find ln !modtypetab
+  | MTEfunsig (mbid,_,mte) ->
+      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)) -> 
+      let substobjs = get_modtype_substobjs mty in
+      let modobjs = MPmap.find mp !modtab_substobjs in
+	replace_module_object id substobjs modobjs
+  | MTEsig (msid,_) -> 
+      todo "Anonymous module types"; (empty_subst, [], msid, [])
+
+(* push names of bound modules (and their components) to Nametab *)
+(* add objects associated to them *)
+let process_module_bindings argids args =
+  let process_arg id (mbid,mty) =
+    let dir = make_dirpath [id] in
+    let mp = MPbound mbid in
+    let substobjs = get_modtype_substobjs mty in
+    let substituted = subst_substobjs dir mp substobjs in
+      do_module false "start" load_objects 1 dir mp substobjs substituted
+  in
+    List.iter2 process_arg argids args
+
+
+let replace_module mtb id mb = todo "replace module after with"; mtb 
+
+let rec get_some_body mty env = match mty with
+    MTEident kn -> Environ.lookup_modtype kn env 
+  | MTEfunsig _ 
+  | MTEsig _ -> anomaly "anonymous module types not supported"
+  | MTEwith (mty,With_Definition _) -> get_some_body mty env 
+  | MTEwith (mty,With_Module (id,mp)) -> 
+      replace_module (get_some_body mty env) id (Environ.lookup_module mp env)
+
+
+let intern_args interp_modtype (env,oldargs) (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 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 =
+  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 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
+	  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
+  Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
+  Lib.add_frozen_state ()
+
+
+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
+    
+  begin match sub_o with
+      None -> ()
+    | Some sub_mtb -> check_subtypes mp sub_mtb
+  end;
+    
+  let substitute, keep, special = Lib.classify_segment lib_stack in
+
+  let dir = fst oldprefix in
+  let msid = msid_of_prefix oldprefix in
+
+  let substobjs = try
+    match res_o with
+      | None -> 
+	  empty_subst, mbids, msid, substitute
+      | Some (MTEident ln) ->
+	  abstract_substobjs mbids (KNmap.find ln (!modtypetab))
+      | Some (MTEsig (msid,_)) ->
+	  todo "Anonymous signatures not supported";
+	  empty_subst, mbids, msid, []
+      | Some (MTEwith _ as mty) ->
+	  abstract_substobjs mbids (get_modtype_substobjs mty)
+      | Some (MTEfunsig _) -> 
+	  anomaly "Funsig cannot be here..."
+    with
+	Not_found -> anomaly "Module objects not found..."
+  in
+
+  (* must be called after get_modtype_substobjs, because of possible
+     dependencies on functor arguments *)
+  Summary.module_unfreeze_summaries fs;
+
+  let substituted = subst_substobjs dir mp substobjs in
+  let node = in_module (None,substobjs,substituted) in
+  let objects = 
+    if keep = [] || mbids <> [] then 
+      special@[node]   (* no keep objects or we are defining a functor *)
+    else
+      special@[node;in_modkeep keep]   (* otherwise *)
+  in
+  let newoname = Lib.add_leaves id objects in
+
+    if (fst newoname) <> (fst oldoname) then
+      anomaly "Names generated on start_ and end_module do not match";
+    if mp_of_kn (snd newoname) <> mp then 
+      anomaly "Kernel and Library names do not match";
+
+    Lib.add_frozen_state () (* to prevent recaching *)
+
+
+
+let module_objects mp = 
+  let prefix,objects = MPmap.find mp !modtab_objects in
+    segment_of_objects prefix objects
+
+
+
+(************************************************************************)
+(* libraries *)
+
+type library_name = dir_path
+
+(* The first two will form substitutive_objects, the last one is keep *)
+type library_objects = 
+    mod_self_id * lib_objects * lib_objects
+
+
+(* The library_cache here is needed to avoid recalculations of
+   substituted modules object during "reloading" of libraries *)
+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);
+      (* if it's in the environment, the cached objects should be correct *)
+      Hashtbl.find library_cache dir
+    with
+	Not_found ->
+	  if mp <> Global.import cenv digest then
+	    anomaly "Unexpected disk module name";
+	  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 modobjs = substobjs, objects in
+	    Hashtbl.add library_cache dir modobjs;
+	    modobjs
+  in
+    do_module false "register_library" load_objects 1 dir mp substobjs objects
+
+
+let start_library dir = 
+  let mp = Global.start_library dir in
+  openmod_info:=[],None,None;
+  Lib.start_compilation dir mp;
+  Lib.add_frozen_state ()
+
+
+let end_library dir = 
+  let prefix, lib_stack = Lib.end_compilation dir in
+  let cenv = Global.export dir in
+  let msid = msid_of_prefix prefix in
+  let substitute, keep, _ = Lib.classify_segment lib_stack in
+    cenv,(msid,substitute,keep)
+
+
+(* implementation of Export M and Import M *)
+
+
+let really_import_module mp = 
+  let prefix,objects = MPmap.find mp !modtab_objects in
+    open_objects 1 prefix objects
+
+
+let cache_import (_,(_,mp)) = 
+(* for non-substitutive exports: 
+  let mp = Nametab.locate_module (qualid_of_dirpath dir) in  *)
+  really_import_module mp
+
+let classify_import (_,(export,_ as obj)) = 
+  if export then Substitute obj else Dispose
+
+let subst_import (_,subst,(export,mp as obj)) =
+  let mp' = subst_mp subst mp in
+    if mp'==mp then obj else
+      (export,mp')
+
+let (in_import,out_import) = 
+  declare_object {(default_object "IMPORT MODULE") with
+    cache_function = cache_import;
+    open_function = (fun i o -> if i=1 then cache_import o);
+    subst_function = subst_import;
+    classify_function = classify_import }
+
+
+let import_module export mp = 
+  Lib.add_anonymous_leaf (in_import (export,mp))
+
+(************************************************************************)
+(* module types *)
+
+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 mbids = List.map fst arg_entries in
+  openmodtype_info := mbids;
+  let prefix = Lib.start_modtype id mp fs in
+  Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix);
+  Lib.add_frozen_state ()
+
+
+let end_modtype id =
+
+  let oldoname,prefix,fs,lib_stack = Lib.end_modtype id in
+  let ln = Global.end_modtype id in
+  let substitute, _, special = Lib.classify_segment lib_stack in
+
+  let msid = msid_of_prefix prefix in
+  let mbids = !openmodtype_info in
+
+  Summary.module_unfreeze_summaries fs;
+
+  let modtypeobjs = empty_subst, mbids, msid, substitute in
+
+  let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs)]) in
+  if fst oname <> fst oldoname then
+    anomaly
+      "Section paths generated on start_ and end_modtype do not match";
+  if snd oname <> ln then
+    anomaly
+      "Kernel and Library names do not match";
+
+  Lib.add_frozen_state ()(* to prevent recaching *)
+
+
+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 entry = 
+    List.fold_right 
+      (fun (arg_id,arg_t) mte -> MTEfunsig(arg_id,arg_t,mte))
+      arg_entries
+      base_mty
+  in
+  let substobjs = get_modtype_substobjs entry in
+  Summary.unfreeze_summaries fs;
+    
+  ignore (add_leaf id (in_modtype (Some entry, substobjs)))
+			       
+
+
+let rec get_module_substobjs = function
+  | MEident mp -> MPmap.find mp !modtab_substobjs 
+  | MEfunctor (mbid,mty,mexpr) ->
+      let (subst, mbids, msid, objs) = 
+	get_module_substobjs 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
+	(match mbids with
+	   | mbid::mbids ->
+	       (add_mbid mbid mp subst, mbids, msid, objs)
+	   | [] -> match mexpr with
+	       | MEident _ | MEstruct _ -> error "Application of a non-functor"
+	       | _ -> error "Application of a functor with too few arguments")
+  | MEapply (_,mexpr) ->
+      Modops.error_application_to_not_path mexpr
+
+
+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 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)), 
+	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))
+  in
+  let mexpr_entry_o = match mexpr_o with
+      None -> None
+    | Some mexpr -> 
+	Some (List.fold_right 
+		(fun (mbid,mte) me -> MEfunctor(mbid,mte,me))
+		arg_entries
+		(interp_modexpr env mexpr))
+  in
+  let entry = 
+    {mod_entry_type = mty_entry_o;	    
+     mod_entry_expr = mexpr_entry_o }
+  in
+  let substobjs =
+    match entry with
+      | {mod_entry_type = Some mte} -> get_modtype_substobjs mte
+      | {mod_entry_expr = Some mexpr} -> get_module_substobjs mexpr
+      | _ -> anomaly "declare_module: No type, no body ..."
+  in
+    Summary.unfreeze_summaries fs;
+
+    let dir,mp = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in
+    let substituted = subst_substobjs dir mp substobjs in
+
+      ignore (add_leaf
+		id
+		(in_module (Some (entry, mty_sub_o), substobjs, substituted)))
+
+
+(*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 _ = 
+    MPmap.iter 
+      (fun _ (prefix,objects) -> 
+	 let apply_obj (id,obj) = f (make_oname prefix id) obj in
+	   List.iter apply_obj objects)
+      !modtab_objects
+  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 "[]"
+    | l -> str ("[." ^ string_of_int (List.length l) ^ ".]")
+  in
+  let pr_modinfo mp (prefix,objects) s =
+    s ++ str (string_of_mp mp) ++ (spc ())
+    ++ (pr_seg (segment_of_objects prefix objects))
+  in
+  let modules = MPmap.fold pr_modinfo !modtab_objects (mt ()) in
+    hov 0 modules
+
+
diff --git a/library/declaremods.mli b/library/declaremods.mli
new file mode 100644
index 00000000..f229da1e
--- /dev/null
+++ b/library/declaremods.mli
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: declaremods.mli,v 1.8.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Entries
+open Environ
+open Libnames
+open Libobject
+open Lib
+   (*i*)
+
+(*s This modules provides official functions to declare modules and
+  module types *)
+
+
+(*s Modules *)
+
+(* [declare_module interp_modtype interp_modexpr id fargs typ expr]
+   declares module [id], with type constructed by [interp_modtype]
+   from functor arguments [fargs] and [typ] and with module body
+   constructed by [interp_modtype] from functor arguments [fargs] and
+   by [interp_modexpr] from [expr]. At least one of [typ], [expr] must
+   be non-empty.
+   
+   The [bool] in [typ] tells if the module must be abstracted [true]
+   with respect to the module type or merely matched without any
+   restriction [false].
+*)
+
+val declare_module : 
+  (env -> 'modtype -> module_type_entry) -> (env -> 'modexpr -> module_expr) ->
+  identifier -> 
+  (identifier located list * 'modtype) list -> ('modtype * bool) option -> 
+  'modexpr option -> unit
+ 
+val start_module : (env -> 'modtype -> module_type_entry) -> 
+  identifier -> 
+  (identifier located list * 'modtype) list -> ('modtype * bool) option -> 
+  unit
+
+val end_module : identifier -> unit
+
+
+
+(*s Module types *)
+
+val declare_modtype : (env -> 'modtype -> module_type_entry) -> 
+  identifier -> (identifier located list * 'modtype) list -> 'modtype -> unit
+
+val start_modtype : (env -> 'modtype -> module_type_entry) -> 
+  identifier -> (identifier located list * 'modtype) list -> unit
+
+val end_modtype : identifier -> unit
+
+
+(*s Objects of a module. They come in two lists: the substitutive ones
+  and the other *)
+
+val module_objects : module_path -> library_segment
+
+
+(*s Libraries i.e. modules on disk *)
+
+type library_name = dir_path
+
+type library_objects
+
+val register_library : 
+  library_name -> 
+    Safe_typing.compiled_library -> library_objects -> Digest.t -> unit
+
+val start_library : library_name -> unit
+
+val end_library :
+  library_name -> Safe_typing.compiled_library * library_objects
+
+
+(* [really_import_module mp] opens the module [mp] (in a Caml sense).
+   It modifies Nametab and performs the "open_object" function for
+   every object of the module. *)
+
+val really_import_module : module_path -> unit
+
+(* [import_module export mp] is a synchronous version of
+   [really_import_module]. If [export] is [true], the module is also
+   opened every time the module containing it is. *)
+
+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. *)
+
+val fold_all_segments : bool -> ('a -> object_name -> obj -> 'a) -> 'a -> 'a
+val iter_all_segments : bool -> (object_name -> obj -> unit) -> unit
+
+
+val debug_print_modtab : unit -> Pp.std_ppcmds
+
+(*val debug_print_modtypetab : unit -> Pp.std_ppcmds*)
+
+(* For translator *)
+val process_module_bindings : module_ident list ->
+  (mod_bound_id * module_type_entry) list -> unit
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
new file mode 100644
index 00000000..59a01d81
--- /dev/null
+++ b/library/dischargedhypsmap.ml
@@ -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        *)
+(************************************************************************)
+
+(* $Id: dischargedhypsmap.ml,v 1.3.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+
+open Util
+open Libnames
+open Names
+open Term
+open Reduction
+open Declarations
+open Environ
+open Inductive
+open Libobject
+open Lib
+open Nametab
+
+type discharged_hyps = section_path list
+
+let discharged_hyps_map = ref Spmap.empty
+
+let cache_discharged_hyps_map (_,(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
+  with Not_found ->
+   anomaly ("No discharged hypothesis for object " ^ string_of_path sp)
+
+(*s Registration as global tables and rollback. *)
+
+let init () =
+  discharged_hyps_map := Spmap.empty
+
+let freeze () = !discharged_hyps_map
+
+let unfreeze dhm = discharged_hyps_map := dhm
+
+let _ = 
+  Summary.declare_summary "discharged_hypothesis"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = true }
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
new file mode 100644
index 00000000..8851e5a3
--- /dev/null
+++ b/library/dischargedhypsmap.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: dischargedhypsmap.mli,v 1.2.8.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Libnames
+open Term
+open Environ
+open Nametab
+(*i*)
+
+type discharged_hyps = section_path list
+
+(*s Discharged hypothesis. Here we store the discharged hypothesis of each *)
+(*  constant or inductive type declaration.                                *)
+
+val set_discharged_hyps : section_path -> discharged_hyps -> unit
+val get_discharged_hyps : section_path -> discharged_hyps
diff --git a/library/doc.tex b/library/doc.tex
new file mode 100644
index 00000000..33af5933
--- /dev/null
+++ b/library/doc.tex
@@ -0,0 +1,16 @@
+
+\newpage
+\section*{The Coq library}
+
+\ocwsection \label{library}
+This chapter describes the \Coq\ library, which is made of two parts:
+\begin{itemize}
+  \item a general mechanism to keep a trace of all operations and of
+    the state of the system, with backtrack capabilities;
+  \item a global environment for the CCI, with functions to export and 
+    import compiled modules.
+\end{itemize}
+The modules of the library are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=library.dep.ps}\end{center}
diff --git a/library/global.ml b/library/global.ml
new file mode 100644
index 00000000..bfa9335c
--- /dev/null
+++ b/library/global.ml
@@ -0,0 +1,145 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: global.ml,v 1.43.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Safe_typing
+open Summary
+
+(* We introduce here the global environment of the system, and we declare it
+   as a synchronized table. *)
+
+let global_env = ref empty_environment
+
+let safe_env () = !global_env
+
+let env () = env_of_safe_env !global_env
+
+let _ = 
+  declare_summary "Global environment"
+    { freeze_function = (fun () -> !global_env);
+      unfreeze_function = (fun fr -> global_env := fr);
+      init_function = (fun () -> global_env := empty_environment);
+      survive_module = true;
+      survive_section = false }
+
+(* Then we export the functions of [Typing] on that environment. *)
+
+let universes () = universes (env())
+let named_context () = named_context (env())
+
+let push_named_assum a =
+  let (cst,env) = push_named_assum a !global_env in
+  global_env := env;
+  cst
+let push_named_def d =
+  let (cst,env) = push_named_def d !global_env in
+  global_env := env;
+  cst
+
+(*let add_thing add kn thing =
+  let _,dir,l = repr_kn kn in
+  let kn',newenv = add dir l thing !global_env in
+    if kn = kn' then
+      global_env := newenv
+    else
+      anomaly "Kernel names do not match."
+*)
+
+let add_thing add dir id thing = 
+  let kn, newenv = add dir (label_of_id id) thing !global_env in
+    global_env := newenv;
+    kn
+
+let add_constant = add_thing add_constant 
+let add_mind = add_thing add_mind
+let add_modtype = add_thing (fun _ -> add_modtype) ()
+let add_module = add_thing (fun _ -> add_module) ()
+
+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 l = label_of_id id in
+  let mp,newenv = start_module l params mtyo !global_env in
+    global_env := newenv;
+    mp
+  
+let end_module id =
+  let l = label_of_id id in
+  let mp,newenv = end_module l !global_env in
+    global_env := newenv;
+    mp
+
+
+let start_modtype id params = 
+  let l = label_of_id id in
+  let mp,newenv = start_modtype l params !global_env in
+    global_env := newenv;
+    mp
+
+let end_modtype id =
+  let l = label_of_id id in
+  let kn,newenv = end_modtype l !global_env in
+    global_env := newenv;
+    kn
+
+
+
+
+let lookup_named id = lookup_named id (env())
+let lookup_constant kn = lookup_constant kn (env())
+let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind
+let lookup_mind kn = lookup_mind kn (env())
+
+let lookup_module mp = lookup_module mp (env())
+let lookup_modtype kn = lookup_modtype kn (env())
+
+
+
+
+let start_library dir = 
+  let mp,newenv = start_library dir !global_env in
+    global_env := newenv; 
+    mp
+
+let export s = snd (export !global_env s)
+
+let import cenv digest = 
+  let mp,newenv = import cenv digest !global_env in 
+    global_env := newenv; 
+    mp
+
+
+
+(*s Function to get an environment from the constants part of the global
+    environment and a given context. *)
+
+let env_of_context hyps = 
+  reset_with_named_context hyps (env())
+
+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
+
+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
new file mode 100644
index 00000000..1da5965c
--- /dev/null
+++ b/library/global.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: global.mli,v 1.40.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Univ
+open Term
+open Declarations
+open Entries
+open Indtypes
+open Safe_typing
+   (*i*)
+
+(* This module defines the global environment of Coq.  The functions
+   below are exactly the same as the ones in [Safe_typing], operating on
+   that global environment. [add_*] functions perform name verification,
+   i.e. check that the name given as argument match those provided by
+   [Safe_typing]. *)
+
+
+
+val safe_env : unit -> safe_environment
+val env : unit -> Environ.env
+
+val universes : unit -> universes
+val named_context : unit -> Sign.named_context
+
+(*s Extending env with variables and local definitions *)
+val push_named_assum : (identifier * types) -> Univ.constraints
+val push_named_def   : (identifier * constr * types option) -> Univ.constraints
+
+(*s Adding constants, inductives, modules and module types.  All these
+  functions verify that given names match those generated by kernel *)
+
+val add_constant : 
+  dir_path -> identifier -> global_declaration -> kernel_name
+val add_mind        : 
+  dir_path -> identifier -> mutual_inductive_entry -> kernel_name
+
+val add_module      : identifier -> module_entry -> module_path
+val add_modtype     : identifier -> module_type_entry -> kernel_name
+
+val add_constraints : constraints -> unit
+
+val set_engagement : Environ.engagement -> unit
+
+(*s Interactive modules and module types *)
+(* Both [start_*] functions take the [dir_path] argument to create a 
+   [mod_self_id]. This should be the name of the compilation 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_modtype :
+  identifier -> (mod_bound_id * module_type_entry) list
+    -> module_path
+
+val end_modtype :
+  identifier -> kernel_name
+
+
+(* Queries *)
+val lookup_named     : variable -> named_declaration
+val lookup_constant  : constant -> constant_body
+val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body
+val lookup_mind      : mutual_inductive -> mutual_inductive_body
+val lookup_module    : module_path -> module_body
+val lookup_modtype   : kernel_name -> module_type_body
+
+(* Compiled modules *)
+val start_library : dir_path -> module_path
+val export : dir_path -> compiled_library
+val import : compiled_library -> Digest.t -> module_path
+
+(*s Function to get an environment from the constants part of the global
+ * environment and a given context. *)
+  
+val type_of_global : Libnames.global_reference -> types
+val env_of_context : Sign.named_context -> Environ.env
+
diff --git a/library/goptions.ml b/library/goptions.ml
new file mode 100644
index 00000000..bcb4fb79
--- /dev/null
+++ b/library/goptions.ml
@@ -0,0 +1,359 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: goptions.ml,v 1.22.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+
+(* This module manages customization parameters at the vernacular level     *)
+
+open Pp
+open Util
+open Libobject
+open Names
+open Libnames
+open Term
+open Nametab
+
+(****************************************************************************)
+(* 0- Common things                                                         *)
+
+type option_name =
+  | PrimaryTable of string
+  | SecondaryTable of string * string
+
+let nickname = function
+  | PrimaryTable s         -> s
+  | SecondaryTable (s1,s2) -> s1^" "^s2
+
+let error_undeclared_key key =
+  error ((nickname key)^": no table or option of this type")
+
+type value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
+  | IdentValue  of global_reference
+
+(****************************************************************************)
+(* 1- Tables                                                                *)
+
+class type ['a] table_of_A =
+object
+  method add : 'a -> unit
+  method remove : 'a -> unit
+  method mem : 'a -> unit
+  method print : unit
+end
+
+module MakeTable =
+  functor
+   (A : sig
+	  type t
+	  type key
+	  val table : (string * key table_of_A) list ref
+	  val encode : key -> t
+	  val subst : substitution -> t -> t
+          val printer : t -> std_ppcmds
+          val key : option_name
+          val title : string
+          val member_message : t -> bool -> std_ppcmds
+          val synchronous : bool
+        end) ->
+  struct
+    type option_mark =
+      | GOadd
+      | GOrmv
+
+    let nick = nickname A.key
+
+    let _ =
+      if List.mem_assoc nick !A.table then
+	error "Sorry, this table name is already used"
+
+    module MyType = struct type t = A.t let compare = Pervasives.compare end
+    module MySet = Set.Make(MyType)
+
+    let t = ref (MySet.empty : MySet.t)
+
+    let _ = 
+      if A.synchronous then
+	let freeze () = !t in
+	let unfreeze c = t := c in
+	let init () = t := MySet.empty in
+	Summary.declare_summary nick
+          { Summary.freeze_function = freeze;
+            Summary.unfreeze_function = unfreeze;
+            Summary.init_function = init;
+	    Summary.survive_module = false;
+	    Summary.survive_section = true }
+
+    let (add_option,remove_option) =
+      if A.synchronous then
+        let cache_options (_,(f,p)) = match f with
+          | GOadd -> t := MySet.add p !t
+          | GOrmv -> t := MySet.remove p !t in
+        let load_options i o = if i=1 then cache_options o in
+	let subst_options (_,subst,(f,p as obj)) = 
+	  let p' = A.subst subst p in
+	    if p' == p then obj else
+	      (f,p')
+	in
+	let export_options fp = Some fp in
+        let (inGo,outGo) =
+          Libobject.declare_object {(Libobject.default_object nick) with
+                Libobject.load_function = load_options;
+		Libobject.open_function = load_options;
+		Libobject.cache_function = cache_options;
+		Libobject.subst_function = subst_options;
+		Libobject.classify_function = (fun (_,x) -> Substitute x);
+		Libobject.export_function = export_options} 
+	in
+        ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))),
+         (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c))))
+      else
+        ((fun c -> t := MySet.add c !t),
+         (fun c -> t := MySet.remove c !t))
+
+    let print_table table_name printer table =
+      msg (str table_name ++ 
+	   (hov 0 
+	      (if MySet.is_empty table then str "None" ++ fnl ()
+               else MySet.fold
+		 (fun a b -> printer a ++ spc () ++ b)
+		 table (mt ()) ++ fnl ())))
+
+    class table_of_A () =
+    object
+      method add x = add_option (A.encode x)
+      method remove x = remove_option (A.encode x)
+      method mem x = 
+	let y = A.encode x in
+        let answer = MySet.mem y !t in
+        msg (A.member_message y answer ++ fnl ())
+      method print = print_table A.title A.printer !t 
+    end
+
+    let _ = A.table := (nick,new table_of_A ())::!A.table
+    let active c = MySet.mem c !t
+    let elements () = MySet.elements !t
+  end
+
+let string_table = ref []
+
+let get_string_table k = List.assoc (nickname k) !string_table
+
+module type StringConvertArg =
+sig
+  val key : option_name
+  val title : string
+  val member_message : string -> bool -> std_ppcmds
+  val synchronous : bool
+end
+
+module StringConvert = functor (A : StringConvertArg) ->
+struct
+  type t = string
+  type key = string
+  let table = string_table
+  let encode x = x
+  let subst _ x = x
+  let printer = str
+  let key = A.key
+  let title = A.title
+  let member_message = A.member_message
+  let synchronous = A.synchronous
+end
+
+module MakeStringTable =
+  functor (A : StringConvertArg) -> MakeTable (StringConvert(A))
+
+let ref_table = ref []
+
+let get_ref_table k = List.assoc (nickname k) !ref_table
+
+module type RefConvertArg =
+sig
+  type t
+  val encode : reference -> t
+  val subst : substitution -> t -> t
+  val printer : t -> std_ppcmds
+  val key : option_name
+  val title : string
+  val member_message : t -> bool -> std_ppcmds
+  val synchronous : bool
+end
+
+module RefConvert = functor (A : RefConvertArg) -> 
+struct
+  type t = A.t
+  type key = reference
+  let table = ref_table
+  let encode = A.encode
+  let subst = A.subst
+  let printer = A.printer
+  let key = A.key
+  let title = A.title
+  let member_message = A.member_message
+  let synchronous = A.synchronous
+end
+
+module MakeRefTable =
+  functor (A : RefConvertArg) -> MakeTable (RefConvert(A))
+
+(****************************************************************************)
+(* 2- Options                                                               *)
+
+type 'a option_sig = {
+  optsync  : bool;
+  optname  : string;
+  optkey   : option_name;
+  optread  : unit -> 'a;
+  optwrite : 'a -> unit }
+
+type option_type = bool * (unit -> value) -> (value -> unit) 
+
+module Key = struct type t = option_name let compare = Pervasives.compare end
+module OptionMap = Map.Make(Key)
+
+let value_tab = ref OptionMap.empty
+
+(* This raises Not_found if option of key [key] is unknown *)
+
+let get_option key = OptionMap.find key !value_tab
+
+let check_key key = try 
+  let _ = get_option key in
+  error "Sorry, this option name is already used"
+with Not_found ->
+  if List.mem_assoc (nickname key) !string_table
+    or List.mem_assoc (nickname key) !ref_table
+  then error "Sorry, this option name is already used"
+
+open Summary
+open Libobject
+open Lib
+
+let declare_option cast uncast 
+  { optsync=sync; optname=name; optkey=key; optread=read; optwrite=write } =
+  check_key key;
+  let default = read() in
+  let write = if sync then 
+    let (decl_obj,_) = 
+      declare_object {(default_object (nickname key)) with
+		       cache_function = (fun (_,v) -> write v);
+		       classify_function = (fun _ -> Dispose)}
+    in 
+    let _ = declare_summary (nickname key) 
+	      {freeze_function = read;
+	       unfreeze_function = write;
+	       init_function = (fun () -> write default);
+	       survive_module = false;
+	       survive_section = true}
+    in 
+    fun v -> add_anonymous_leaf (decl_obj v)
+  else write
+  in 
+  let cread () = cast (read ()) in
+  let cwrite v = write (uncast v) in 
+  value_tab := OptionMap.add key (name,(sync,cread,cwrite)) !value_tab; 
+  write
+
+type 'a write_function = 'a -> unit
+
+let declare_int_option =
+  declare_option 
+    (fun v -> IntValue v)
+    (function IntValue v -> v | _ -> anomaly "async_option")
+let declare_bool_option =
+  declare_option
+    (fun v -> BoolValue v)
+    (function BoolValue v -> v | _ -> anomaly "async_option")
+let declare_string_option =
+  declare_option
+    (fun v -> StringValue v)
+    (function StringValue v -> v | _ -> anomaly "async_option")
+
+(* 3- User accessible commands *)
+
+(* Setting values of options *)
+
+let set_option_value check_and_cast key v =
+  let (name,(_,read,write)) =
+    try get_option key
+    with Not_found -> error ("There is no option "^(nickname key)^".")
+  in
+  write (check_and_cast v (read ()))
+
+let bad_type_error () = error "Bad type of value for this option"
+
+let set_int_option_value = set_option_value
+  (fun v -> function 
+     | (IntValue _) -> IntValue v
+     | _ -> bad_type_error ())
+let set_bool_option_value = set_option_value
+  (fun v -> function 
+     | (BoolValue _) -> BoolValue v
+     | _ -> bad_type_error ())
+let set_string_option_value = set_option_value
+ (fun v -> function 
+    | (StringValue _) -> StringValue v
+    | _ -> bad_type_error ())
+
+(* Printing options/tables *)
+
+let msg_option_value (name,v) =
+  match v with
+    | BoolValue true  -> str "true"
+    | BoolValue false -> str "false"
+    | IntValue (Some n) -> int n
+    | IntValue None   -> str "undefined"
+    | StringValue s   -> str s
+    | IdentValue r    -> pr_global_env Idset.empty r
+
+let print_option_value key =
+  let (name,(_,read,_)) = get_option key in
+  let s = read () in 
+  match s with
+    | BoolValue b -> 
+	msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ 
+	     fnl ())
+    | _ ->
+	msg (str ("Current value of "^name^" is ") ++
+	     msg_option_value (name,s) ++ fnl ())
+
+
+let print_tables () =
+  msg
+    (str "Synchronous options:" ++ fnl () ++
+     OptionMap.fold 
+       (fun key (name,(sync,read,write)) p -> 
+	  if sync then 
+	    p ++ str ("  "^(nickname key)^": ") ++
+	    msg_option_value (name,read()) ++ fnl ()
+	  else 
+	    p)
+       !value_tab (mt ()) ++
+     str "Asynchronous options:" ++ fnl () ++
+     OptionMap.fold 
+       (fun key (name,(sync,read,write)) p -> 
+	  if sync then 
+	    p
+	  else 
+	    p ++ str ("  "^(nickname key)^": ") ++
+            msg_option_value (name,read()) ++ fnl ())
+       !value_tab (mt ()) ++
+     str "Tables:" ++ fnl () ++
+     List.fold_right
+       (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
+       !string_table (mt ()) ++
+     List.fold_right
+       (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
+       !ref_table (mt ()) ++
+     fnl ()
+    )
+
+
diff --git a/library/goptions.mli b/library/goptions.mli
new file mode 100644
index 00000000..bbf5357a
--- /dev/null
+++ b/library/goptions.mli
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: goptions.mli,v 1.10.6.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(* This module manages customization parameters at the vernacular level     *)
+
+(* Two kinds of things are managed : tables and options value
+   - Tables are created by applying the [MakeTable] functor.
+   - Variables storing options value are created by applying one of the
+   [declare_int_option], [declare_bool_option], ... functions.
+
+   Each table/option is uniquely identified by a key of type [option_name].
+   There are two kinds of table/option idenfiers: the primary ones
+   (supposed to be more global) and the secondary ones
+
+   The declaration of a table, say of name [SecondaryTable("Toto","Titi")] 
+   automatically makes available the following vernacular commands:
+
+      Add Toto Titi foo.
+      Remove Toto Titi foo.
+      Print Toto Titi.
+      Test Toto Titi.
+
+   The declaration of a non boolean option value, say of name
+   [SecondaryTable("Tata","Tutu")], automatically makes available the
+   following vernacular commands:
+
+       Set Tata Tutu val.
+       Print Table Tata Tutu.
+
+   If it is the declaration of a boolean value, the following
+   vernacular commands are made available:
+
+       Set Tata Tutu.
+       Unset Tata Tutu.
+       Print Table Tata Tutu. (* synonym: Test Table Tata Tutu. *)
+
+   For a primary table, say of name [PrimaryTable("Bidule")], the
+   vernacular commands look like
+
+      Add Bidule foo.
+      Print Table Bidule foo.
+      Set Bidule foo.
+      ...
+
+   The created table/option may be declared synchronous or not
+   (synchronous = consistent with the resetting commands)                   *)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Term
+open Nametab
+(*i*)
+
+(*s Things common to tables and options. *)
+
+(* The type of primary or secondary table/option keys *)
+type option_name =
+  | PrimaryTable of string
+  | SecondaryTable of string * string
+
+val error_undeclared_key : option_name -> 'a
+
+(*s Tables. *)
+
+(* The functor [MakeStringTable] declares a table containing objects
+   of type [string]; the function [member_message] say what to print
+   when invoking the "Test Toto Titi foo." command; at the end [title]
+   is the table name printed when invoking the "Print Toto Titi."
+   command; [active] is roughly the internal version of the vernacular
+   "Test ...": it tells if a given object is in the table; [elements]
+   returns the list of elements of the table *)
+
+module MakeStringTable :
+  functor
+    (A : sig
+       val key : option_name
+       val title : string
+       val member_message : string -> bool -> std_ppcmds
+       val synchronous : bool
+     end) ->
+sig
+  val active : string -> bool
+  val elements : unit -> string list
+end
+
+(* The functor [MakeRefTable] declares a new table of objects of type
+   [A.t] practically denoted by [reference]; the encoding function
+   [encode : reference -> A.t] is typically a globalization function,
+   possibly with some restriction checks; the function
+   [member_message] say what to print when invoking the "Test Toto
+   Titi foo." command; at the end [title] is the table name printed
+   when invoking the "Print Toto Titi." command; [active] is roughly
+   the internal version of the vernacular "Test ...": it tells if a
+   given object is in the table.  *)
+
+module MakeRefTable :
+  functor
+    (A : sig
+           type t
+           val encode : reference -> t
+	   val subst : substitution -> t -> t
+           val printer : t -> std_ppcmds
+           val key : option_name
+           val title : string
+           val member_message : t -> bool -> std_ppcmds
+           val synchronous : bool
+         end) ->
+    sig
+      val active : A.t -> bool
+      val elements : unit -> A.t list
+    end
+
+
+(*s Options. *)
+
+(* These types and function are for declaring a new option of name [key]
+   and access functions [read] and [write]; the parameter [name] is the option name 
+   used when printing the option value (command "Print Toto Titi." *)
+
+type 'a option_sig = {
+  optsync    : bool; 
+  optname    : string;
+  optkey     : option_name;
+  optread    : unit -> 'a;
+  optwrite   : 'a -> unit
+}
+
+(* When an option is declared synchronous ([optsync] is [true]), the output is 
+   a synchronous write function. Otherwise it is [optwrite] *)
+
+type 'a write_function = 'a -> unit
+
+val declare_int_option   : int option option_sig -> int option write_function
+val declare_bool_option  : bool option_sig   -> bool write_function
+val declare_string_option: string option_sig -> string write_function
+
+
+(*s Special functions supposed to be used only in vernacentries.ml *)
+
+val get_string_table :
+  option_name ->
+    < add : string -> unit;
+      remove : string -> unit;
+      mem : string -> unit;
+      print : unit >
+
+val get_ref_table :
+  option_name ->
+    < add : reference -> unit;
+      remove : reference -> unit;
+      mem : reference -> unit;
+      print : unit >
+
+val set_int_option_value    : option_name -> int option -> unit
+val set_bool_option_value   : option_name -> bool   -> unit
+val set_string_option_value : option_name -> string -> unit
+
+val print_option_value : option_name -> unit
+
+val print_tables : unit -> unit
+
diff --git a/library/impargs.ml b/library/impargs.ml
new file mode 100644
index 00000000..8a9429a4
--- /dev/null
+++ b/library/impargs.ml
@@ -0,0 +1,551 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: impargs.ml,v 1.59.2.1 2004/07/16 19:30:35 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Term
+open Reduction
+open Declarations
+open Environ
+open Inductive
+open Libobject
+open Lib
+open Nametab
+open Pp
+open Termops
+open Topconstr
+
+(*s Flags governing the computation of implicit arguments *)
+
+(* les implicites sont stricts par défaut en v8 *)
+let implicit_args = ref false
+let strict_implicit_args = ref (not !Options.v7)
+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
+
+let make_strict_implicit_args flag =
+  strict_implicit_args := flag;
+  if not !Options.v7_only then strict_implicit_args_out := flag
+
+let make_contextual_implicit_args flag =
+  contextual_implicit_args := flag;
+  if not !Options.v7_only then contextual_implicit_args_out := 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)
+
+let with_implicits ((a,b,c),(d,e,g)) 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
+
+(*s Computation of implicit arguments *)
+
+(* We remember various information about why an argument is (automatically)
+   inferable as implicit
+
+- [DepRigid] means that the implicit argument can be found by
+  unification along a rigid path (we do not print the arguments of
+  this kind if there is enough arguments to infer them)
+
+- [DepFlex] means that the implicit argument can be found by unification
+  along a collapsable path only (e.g. as x in (P x) where P is another
+  argument) (we do (defensively) print the arguments of this kind)
+
+- [DepFlexAndRigid] means that the least argument from which the
+  implicit argument can be inferred is following a collapsable path
+  but there is a greater argument from where the implicit argument is
+  inferable following a rigid path (useful to know how to print a
+  partial application)
+
+  We also consider arguments inferable from the conclusion but it is
+  operational only if [conclusion_matters] is true.
+*)
+
+type argument_position =
+  | Conclusion
+  | Hyp of int
+
+type implicit_explanation =
+  | DepRigid of argument_position
+  | DepFlex of argument_position
+  | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position
+  | Manual
+
+let argument_less = function
+  | Hyp n, Hyp n' -> n<n'
+  | Hyp _, Conclusion -> true
+  | Conclusion, _ -> false
+
+let update pos rig (na,st) =
+  let e =
+  if rig then
+    match st with
+      | None -> DepRigid pos
+      | Some (DepRigid n as x) ->
+          if argument_less (pos,n) then DepRigid pos else x
+      | 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) ->
+          if argument_less (pos,fpos) or pos=fpos then DepRigid pos
+          else DepFlexAndRigid (fpos,pos)
+      | Some Manual -> assert false
+  else
+    match st with
+      | None -> DepFlex pos
+      | Some (DepRigid rpos as x) ->
+          if argument_less (pos,rpos) then DepFlexAndRigid (pos,rpos) else x
+      | Some (DepFlexAndRigid (fpos,rpos) as x) ->
+          if argument_less (pos,fpos) then DepFlexAndRigid (pos,rpos) else x
+      | Some (DepFlex fpos as x) ->
+          if argument_less (pos,fpos) then DepFlex pos else x
+      | Some Manual -> assert false
+  in na, Some e
+
+(* modified is_rigid_reference with a truncated env *)
+let is_flexible_reference env bound depth f =
+  match kind_of_term f with
+    | Rel n when n >= bound+depth -> (* inductive type *) false
+    | Rel n when n >= depth -> (* previous argument *) true
+    | Rel n -> (* since local definitions have been expanded *) false
+    | Const kn ->
+        let cb = Environ.lookup_constant kn env in
+        cb.const_body <> None & not cb.const_opaque
+    | Var id ->
+        let (_,value,_) = Environ.lookup_named id env in value <> None
+    | Ind _ | Construct _ -> false
+    |  _ -> true
+
+let push_lift d (e,n) = (push_rel d e,n+1)
+
+(* Precondition: rels in env are for inductive types only *)
+let add_free_rels_until strict bound env m pos acc =
+  let rec frec rig (env,depth as ed) c =
+    match kind_of_term (whd_betadeltaiota env c) with
+    | Rel n when (n < bound+depth) & (n >= depth) ->
+        acc.(bound+depth-n-1) <- update pos rig (acc.(bound+depth-n-1))
+    | App (f,_) when rig & is_flexible_reference env bound depth f ->
+	if strict then () else
+          iter_constr_with_full_binders push_lift (frec false) ed c
+    | Case _ when rig ->
+	if strict then () else
+          iter_constr_with_full_binders push_lift (frec false) ed c
+    | _ ->
+        iter_constr_with_full_binders push_lift (frec rig) ed c
+  in 
+  frec true (env,1) m; 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
+    match kind_of_term t with
+      | Prod (na,a,b) ->
+	  let na',avoid' = Termops.concrete_name false avoid names na b in
+	  add_free_rels_until strict n env a (Hyp (n+1))
+            (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b)
+      | _ -> 
+	  let names = List.rev names in
+	  let v = Array.map (fun na -> na,None) (Array.of_list names) in
+	  if contextual then add_free_rels_until strict n env t Conclusion v
+	  else v
+  in 
+  match kind_of_term (whd_betadeltaiota env t) with 
+    | Prod (na,a,b) ->
+	let na',avoid = Termops.concrete_name false [] [] na b in
+	let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in
+	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 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
+
+type implicit_status =
+    (* None = Not implicit *)
+    (identifier * implicit_explanation) option
+
+type implicits_list = implicit_status list
+
+let is_status_implicit = function
+  | None -> false
+  | _ -> true
+
+let name_of_implicit = function
+  | None -> anomaly "Not an implicit argument"
+  | Some (id,_) -> id
+
+(* [in_ctx] means we now the expected type, [n] is the index of the argument *)
+let is_inferable_implicit in_ctx n = function
+  | None -> false
+  | Some (_,DepRigid (Hyp p)) -> n >= p
+  | Some (_,DepFlex (Hyp p)) -> false
+  | Some (_,DepFlexAndRigid (_,Hyp q)) -> n >= q
+  | Some (_,DepRigid Conclusion) -> in_ctx
+  | Some (_,DepFlex Conclusion) -> false
+  | Some (_,DepFlexAndRigid (_,Conclusion)) -> false
+  | Some (_,Manual) -> true
+
+let positions_of_implicits =
+  let rec aux n = function
+      [] -> []
+    | Some _ :: l -> n :: aux (n+1) l
+    | None :: l -> aux (n+1) l
+  in aux 1
+
+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 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
+
+(*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 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))
+        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)
+  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 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 env = Global.env () in
+  let (_,_,ty) = lookup_named id env in
+  auto_implicits env ty
+
+let var_implicits id = 
+  try Idmap.find id !var_table with Not_found -> No_impl,No_impl
+
+(* 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
+
+let cache_implicits (_,l) = List.iter cache_implicits_decl l
+
+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 subst_implicits (_,subst,l) =
+  list_smartmap (subst_implicits_decl subst) l
+
+let (in_implicits, _) =
+  declare_object {(default_object "IMPLICITS") with 
+    cache_function = cache_implicits;
+    load_function = (fun _ -> cache_implicits);
+    subst_function = subst_implicits;
+    classify_function = (fun (_,x) -> Substitute x);
+    export_function = (fun x -> Some x) }
+
+(* Implicits of a global reference. *)
+
+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_var_implicits id =
+  if !implicit_args or !implicit_args_out then
+    declare_implicits_gen (VarRef id)
+
+let declare_constant_implicits kn =
+  if !implicit_args or !implicit_args_out then
+    declare_implicits_gen (ConstRef kn)
+
+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
+
+(* 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
+
+(*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 _ = 
+  Summary.declare_summary "implicits"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      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
new file mode 100644
index 00000000..8db04ee7
--- /dev/null
+++ b/library/impargs.mli
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: impargs.mli,v 1.26.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Libnames
+open Term
+open Environ
+open Nametab
+(*i*)
+
+(*s Implicit arguments. Here we store the implicit arguments. Notice that we 
+    are outside the kernel, which knows nothing about implicit arguments. *)
+
+val make_implicit_args : bool -> unit
+val make_strict_implicit_args : bool -> unit
+val make_contextual_implicit_args : bool -> unit
+
+val is_implicit_args : unit -> bool
+val is_strict_implicit_args : unit -> bool
+val is_contextual_implicit_args : unit -> bool
+
+type implicits_flags
+val with_implicits : implicits_flags -> ('a -> 'b) -> 'a -> 'b
+
+(*s An [implicits_list] is a list of positions telling which arguments
+    of a reference can be automatically infered *)
+type implicit_status
+type implicits_list = implicit_status list
+
+val is_status_implicit : implicit_status -> bool
+val is_inferable_implicit : bool -> int -> implicit_status -> bool
+val name_of_implicit : implicit_status -> identifier
+
+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
+
+(*s Computation of implicits (done using the global environment). *)
+
+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
+
+(* Manual declaration of which arguments are expected implicit *)
+val declare_manual_implicits : 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
new file mode 100644
index 00000000..b9da6dea
--- /dev/null
+++ b/library/lib.ml
@@ -0,0 +1,566 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: lib.ml,v 1.63.2.2 2004/07/16 19:30:35 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Libobject
+open Summary
+
+
+
+type node = 
+  | Leaf of obj
+  | CompilingLibrary of object_prefix
+  | OpenedModule of 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
+  | FrozenState of Summary.frozen
+
+and library_entry = object_name * node
+
+and library_segment = library_entry list
+
+type lib_objects =  (identifier * obj) list
+
+let iter_objects f i prefix =
+  List.iter (fun (id,obj) -> f i (make_oname prefix id, obj))
+
+let load_objects = iter_objects load_object
+let open_objects = iter_objects open_object
+
+let subst_objects prefix subst seg = 
+  let subst_one = fun (id,obj as node) ->
+    let obj' = subst_object (make_oname prefix id, subst, obj) in
+      if obj' == obj then node else
+	(id, obj')
+  in
+    list_smartmap subst_one 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 -> 
+	let id = id_of_label (label kn) in
+	  (match classify_object (oname,o) with 
+	     | Dispose -> clean acc stk
+	     | Keep o' -> 
+		 clean (substl, (id,o')::keepl, anticipl) stk
+	     | Substitute o' -> 
+		 clean ((id,o')::substl, keepl, anticipl) stk
+	     | Anticipate o' ->
+		 clean (substl, keepl, o'::anticipl) stk)
+    | (oname,ClosedSection _ as item) :: 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"
+    | (_,FrozenState _) :: stk -> clean acc stk
+  in
+    clean ([],[],[]) (List.rev seg)
+
+
+let segment_of_objects prefix =
+  List.map (fun (id,obj) -> (make_oname prefix id, Leaf obj))
+
+(* We keep trace of operations in the stack [lib_stk]. 
+   [path_prefix] is the current path of sections, where sections are stored in 
+   ``correct'' order, the oldest coming first in the list. It may seems 
+   costly, but in practice there is not so many openings and closings of
+   sections, but on the contrary there are many constructions of section
+   paths based on the library path. *) 
+
+let initial_prefix = default_library,(initial_path,empty_dirpath)
+
+let lib_stk = ref ([] : library_segment)
+
+let comp_name = ref None
+
+let library_dp () =
+  match !comp_name with Some m -> m | None -> default_library
+
+(* [path_prefix] is a pair of absolute dirpath and a pair of current
+   module path and relative section path *)
+let path_prefix = ref initial_prefix
+
+
+let cwd () = fst !path_prefix
+
+let make_path id = Libnames.make_path (cwd ()) id
+
+
+let current_prefix () = snd !path_prefix
+
+let make_kn id = 
+  let mp,dir = current_prefix () in
+    Names.make_kn mp dir (label_of_id id)
+
+
+let make_oname id = make_path id, make_kn id
+
+
+let sections_depth () =
+  List.length (repr_dirpath (snd (snd !path_prefix)))
+
+let sections_are_opened () =
+  match repr_dirpath (snd (snd !path_prefix)) with
+      [] -> false
+    | _ -> true
+
+
+let recalc_path_prefix () =
+  let rec recalc = function
+    | (sp, OpenedSection (dir,_)) :: _ -> dir
+    | (sp, OpenedModule (dir,_)) :: _ -> dir
+    | (sp, OpenedModtype (dir,_)) :: _ -> dir
+    | (sp, CompilingLibrary dir) :: _ -> dir
+    | _::l -> recalc l
+    | [] -> initial_prefix
+  in
+  path_prefix := recalc !lib_stk
+
+let pop_path_prefix () = 
+  let dir,(mp,sec) = !path_prefix in
+    path_prefix := fst (split_dirpath dir), (mp, fst (split_dirpath sec))
+
+let find_entry_p p = 
+  let rec find = function
+    | [] -> raise Not_found
+    | ent::l -> if p ent then ent else find l
+  in
+  find !lib_stk
+
+let find_split_p p = 
+  let rec find = function
+    | [] -> raise Not_found
+    | ent::l -> if p ent then ent,l else find l
+  in
+  find !lib_stk
+
+let split_lib sp = 
+  let rec collect after equal = function
+    | ((sp',_) as hd)::before ->
+      	if sp = sp' then collect after (hd::equal) before else after,equal,hd::before
+    | [] -> after,equal,[]
+  in
+  let rec findeq after = function
+    | ((sp',_) as hd)::before ->
+      	if sp = sp' then collect after [hd] before else findeq (hd::after) before
+    | [] -> error "no such entry"
+  in 
+  findeq [] !lib_stk
+
+(* Adding operations. *)
+
+let add_entry sp node =
+  lib_stk := (sp,node) :: !lib_stk
+
+let anonymous_id = 
+  let n = ref 0 in
+  fun () -> incr n; id_of_string ("_" ^ (string_of_int !n))
+
+let add_anonymous_entry node =
+  let id = anonymous_id () in
+  let name = make_oname id in
+  add_entry name node;
+  name
+
+let add_absolutely_named_leaf sp obj =
+  cache_object (sp,obj);
+  add_entry sp (Leaf obj)
+
+let add_leaf id obj =
+  let oname = make_oname id in
+  cache_object (oname,obj);
+  add_entry oname (Leaf obj);
+  oname
+
+let add_leaves id objs =
+  let oname = make_oname id in
+  let add_obj obj = 
+    add_entry oname (Leaf obj);
+    load_object 1 (oname,obj) 
+  in
+  List.iter add_obj objs;
+  oname
+
+let add_anonymous_leaf obj =
+  let id = anonymous_id () in
+  let oname = make_oname id in
+  cache_object (oname,obj);
+  add_entry oname (Leaf obj)
+
+let add_frozen_state () =
+  let _ = add_anonymous_entry (FrozenState (freeze_summaries())) in ()
+
+(* Modules. *)
+
+let is_something_opened = function 
+    (_,OpenedSection _) -> true 
+  | (_,OpenedModule _) -> true
+  | (_,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 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));
+  path_prefix := prefix;
+  prefix
+(*  add_frozen_state () must be called in declaremods *)
+ 
+let end_module id = 
+  let oname,nametab = 
+    try match find_entry_p is_something_opened with
+      | 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"; 
+	  oname,nametab
+      | _,OpenedModtype _ ->
+	  error "there are some open module types"
+      | _,OpenedSection _ ->
+	  error "there are some open sections"
+      | _ -> assert false
+    with Not_found ->
+      error "no opened modules"
+  in
+  let (after,_,before) = split_lib oname in
+  lib_stk := before;
+  let prefix = !path_prefix in
+  recalc_path_prefix ();
+  (* add_frozen_state must be called after processing the module, 
+     because we cannot recache interactive modules  *) 
+  (oname, prefix, nametab,after)
+
+let start_modtype id mp nametab = 
+  let dir = extend_dirpath (fst !path_prefix) id in
+  let prefix = dir,(mp,empty_dirpath) in
+  let sp = make_path id in
+  let name = sp, make_kn id in
+  if Nametab.exists_cci sp then
+    errorlabstrm "open_modtype" (pr_id id ++ str " already exists") ;
+  add_entry name (OpenedModtype (prefix,nametab));
+  path_prefix := prefix;
+  prefix
+
+let end_modtype id = 
+  let sp,nametab = 
+    try match find_entry_p is_something_opened with
+      | sp,OpenedModtype (_,nametab) -> 
+	  let id' = basename (fst sp) in
+	  if id<>id' then error "this is not the last opened module"; 
+	  sp,nametab
+      | _,OpenedModule _ ->
+	  error "there are some open modules"
+      | _,OpenedSection _ ->
+	  error "there are some open sections"
+      | _ -> assert false
+    with Not_found ->
+      error "no opened module types"
+  in
+  let (after,_,before) = split_lib sp in
+  lib_stk := before;
+  let dir = !path_prefix in
+  recalc_path_prefix ();
+  (* add_frozen_state must be called after processing the module type.
+     This is because we cannot recache interactive module types *) 
+  (sp,dir,nametab,after)
+
+
+
+let contents_after = function
+  | None -> !lib_stk
+  | Some sp -> let (after,_,_) = split_lib sp in after
+
+(* Modules. *)
+
+let check_for_comp_unit () =
+  let is_decl = function (_,FrozenState _) -> false | _ -> true in
+  try
+    let _ = find_entry_p is_decl in
+    error "a module cannot be started after some declarations"
+  with Not_found -> ()
+
+(* TODO: use check_for_module ? *)
+let start_compilation s mp =
+  if !comp_name <> None then
+    error "compilation unit is already started";
+  if snd (snd (!path_prefix)) <> empty_dirpath then
+    error "some sections are already opened";
+  let prefix = s, (mp, empty_dirpath) in
+  let _ = add_anonymous_entry (CompilingLibrary prefix) in
+  comp_name := Some s;
+  path_prefix := prefix
+
+let end_compilation dir =
+  let _ =
+    try match find_entry_p is_something_opened with
+      | _, OpenedSection _ -> error "There are some open sections"
+      | _, OpenedModule _ -> error "There are some open modules"
+      | _, OpenedModtype _ -> error "There are some open module types"
+      | _ -> assert false
+    with
+	Not_found -> ()
+  in
+  let module_p =
+    function (_,CompilingLibrary _) -> true | x -> is_something_opened x
+  in
+  let oname = 
+    try match find_entry_p module_p with
+	(oname, CompilingLibrary prefix) -> oname
+      | _ -> assert false
+    with
+	Not_found -> anomaly "No module declared"
+  in
+  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));
+  in
+  let (after,_,before) = split_lib oname in
+  comp_name := None;
+  !path_prefix,after
+
+(* Returns true if we are inside an opened module type *)
+let is_modtype () = 
+  let opened_p = function
+    | _, OpenedModtype _ -> true 
+    | _ -> false
+  in
+    try 
+      let _ = find_entry_p opened_p in true
+    with
+	Not_found -> false
+
+(* Returns true if we are inside an opened module *)
+let is_module () = 
+  let opened_p = function
+    | _, OpenedModule _ -> true 
+    | _ -> false
+  in
+    try 
+      let _ = find_entry_p opened_p in true
+    with
+	Not_found -> false
+
+
+(* Returns the most recent OpenedThing node *)
+let what_is_opened () = find_entry_p is_something_opened
+
+(* XML output hooks *)
+let xml_open_section = ref (fun id -> ())
+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
+
+
+(* Restore lib_stk and summaries as before the section opening, and
+   add a ClosedSection object. *)
+let close_section ~export id =
+  let oname,fs = 
+    try match find_entry_p is_something_opened with
+      | oname,OpenedSection (_,fs) -> 
+	  if id <> basename (fst oname) then
+	    error "this is not the last opened section";
+	  (oname,fs)
+      | _ -> assert false 
+    with Not_found ->
+      error "no opened section"
+  in
+  let (after,_,before) = split_lib oname in
+  lib_stk := before;
+  let prefix = !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;
+  if !Options.xml_export then !xml_close_section id;
+  (prefix, after, fs)
+
+(* Backtracking. *)
+
+let recache_decl = function
+  | (sp, Leaf o) -> cache_object (sp,o)
+  | _ -> ()
+
+
+let recache_context ctx =
+  List.iter recache_decl ctx
+
+let is_frozen_state = function (_,FrozenState _) -> true | _ -> false
+
+let reset_to sp =
+  let (_,_,before) = split_lib sp in
+  lib_stk := before;
+  recalc_path_prefix ();
+  let spf = match find_entry_p is_frozen_state with
+    | (sp, FrozenState f) -> unfreeze_summaries f; sp
+    | _ -> assert false
+  in
+  let (after,_,_) = split_lib spf in
+  recache_context after
+
+let reset_name (loc,id) =
+  let (sp,_) = 
+    try
+      find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
+    with Not_found ->
+      user_err_loc (loc,"reset_name",pr_id id ++ str ": no such entry")
+  in
+  reset_to sp
+
+let is_mod_node = function 
+  | OpenedModule _ | OpenedModtype _ | OpenedSection _ 
+  | ClosedSection _ -> true 
+  | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE"
+  | _ -> false
+
+(* Reset on a module or section name in order to bypass constants with 
+   the same name *) 
+
+let reset_mod (loc,id) =
+  let (ent,before) = 
+    try
+      find_split_p (fun (sp,node) -> 
+                    let (_,spi) = repr_path (fst sp) in id = spi 
+                    && is_mod_node node)
+    with Not_found ->
+      user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry")
+  in
+  lib_stk := before;
+  recalc_path_prefix ();
+  let spf = match find_entry_p is_frozen_state with
+    | (sp, FrozenState f) -> unfreeze_summaries f; sp
+    | _ -> assert false
+  in
+  let (after,_,_) = split_lib spf in
+  recache_context after
+
+
+let point_obj =
+  let (f,_) = declare_object {(default_object "DOT") with
+				classify_function = (fun _ -> Dispose)} in
+    f()
+
+let mark_end_of_command () =
+  match !lib_stk with
+      (_,Leaf o)::_ when object_tag o = "DOT" -> ()
+    | _ -> add_anonymous_leaf point_obj
+
+let rec back_stk n stk =
+  match stk with
+      (sp,Leaf o)::tail when object_tag o = "DOT" ->
+        if n=0 then sp else back_stk (n-1) tail
+    | _::tail -> back_stk n tail
+    | [] -> error "Reached begin of command history"
+
+let back n = reset_to (back_stk n !lib_stk)
+
+(* State and initialization. *)
+
+type frozen = dir_path option * library_segment
+
+let freeze () = (!comp_name, !lib_stk)
+
+let unfreeze (mn,stk) =
+  comp_name := mn;
+  lib_stk := stk;
+  recalc_path_prefix ()
+
+let init () =
+  lib_stk := [];
+  add_frozen_state ();
+  comp_name := None;
+  path_prefix := initial_prefix;
+  init_summaries()
+
+(* Initial state. *)
+
+let initial_state = ref None
+
+let declare_initial_state () = 
+  let name = add_anonymous_entry (FrozenState (freeze_summaries())) in
+  initial_state := Some name
+
+let reset_initial () =
+  match !initial_state with
+    | None -> 
+        error "Resetting to the initial state is possible only interactively"
+    | Some sp -> 
+  	begin match split_lib sp with
+	  | (_,[_,FrozenState fs as hd],before) ->
+	      lib_stk := hd::before;
+	      recalc_path_prefix ();
+	      unfreeze_summaries fs
+	  | _ -> assert false
+	end
+
+
+(* Misc *)
+
+let library_part ref =
+  let sp = Nametab.sp_of_global ref in
+  let dir,_ = repr_path sp in
+  match ref with
+  | VarRef id -> 
+      anomaly "TODO";
+      extract_dirpath_prefix (sections_depth ()) (cwd ())
+  | _ ->
+      if is_dirpath_prefix_of dir (cwd ()) then
+        (* Not yet (fully) discharged *)
+        extract_dirpath_prefix (sections_depth ()) (cwd ())
+      else
+	(* Theorem/Lemma outside its outer section of definition *)
+	dir
diff --git a/library/lib.mli b/library/lib.mli
new file mode 100644
index 00000000..8981754e
--- /dev/null
+++ b/library/lib.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: lib.mli,v 1.41.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Libnames
+open Libobject
+open Summary
+(*i*)
+
+(*s This module provides a general mechanism to keep a trace of all operations
+   and to backtrack (undo) those operations. It provides also the section
+   mechanism (at a low level; discharge is not known at this step). *)
+
+type node = 
+  | Leaf of obj
+  | CompilingLibrary of object_prefix
+  | OpenedModule of object_prefix * Summary.frozen
+  | OpenedModtype of object_prefix * Summary.frozen
+  | OpenedSection of object_prefix * Summary.frozen
+  | ClosedSection of bool * dir_path * library_segment
+  | FrozenState of Summary.frozen
+
+and library_segment = (object_name * node) list
+
+type lib_objects = (identifier * obj) list
+
+(*s Object iteratation functions. *)
+
+val open_objects : int -> object_prefix -> lib_objects -> unit
+val load_objects : int -> object_prefix -> lib_objects -> unit
+val subst_objects : object_prefix -> substitution -> lib_objects -> lib_objects
+
+(* [classify_segment seg] verifies that there are no OpenedThings,
+   clears ClosedSections and FrozenStates and divides Leafs according
+   to their answers to the [classify_object] function in three groups:
+   [Substitute], [Keep], [Anticipate] respectively.  The order of each
+   returned list is the same as in the input list. *)
+val classify_segment : 
+  library_segment -> lib_objects * lib_objects * obj list
+
+(* [segment_of_objects prefix objs] forms a list of Leafs *)
+val segment_of_objects :
+  object_prefix -> lib_objects -> library_segment
+
+
+(*s Adding operations (which call the [cache] method, and getting the
+  current list of operations (most recent ones coming first). *)
+
+val add_leaf : identifier -> obj -> object_name
+val add_absolutely_named_leaf : object_name -> obj -> unit
+val add_anonymous_leaf : obj -> unit
+
+(* this operation adds all objects with the same name and calls load_object 
+   for each of them *)
+val add_leaves : identifier -> obj list -> object_name
+
+val add_frozen_state : unit -> unit
+val mark_end_of_command : unit -> unit
+
+
+(*s The function [contents_after] returns the current library segment, 
+  starting from a given section path. If not given, the entire segment
+  is returned. *)
+
+val contents_after : object_name option -> library_segment
+
+(*s Functions relative to current path *)
+
+(* User-side names *)
+val cwd : unit -> dir_path
+val make_path : identifier -> section_path
+
+(* Kernel-side names *)
+val current_prefix : unit -> module_path * dir_path
+val make_kn : identifier -> kernel_name
+
+(* Are we inside an opened section *)
+val sections_are_opened : unit -> bool
+val sections_depth : unit -> int
+
+(* Are we inside an opened module type *)
+val is_modtype : unit -> bool
+val is_module : unit -> bool
+
+
+(* Returns the most recent OpenedThing node *)
+val what_is_opened : unit -> object_name * node
+
+
+(*s Modules and module types *)
+
+val start_module : 
+  module_ident -> module_path -> Summary.frozen -> object_prefix
+val end_module : module_ident 
+  -> object_name * object_prefix * Summary.frozen * library_segment
+
+val start_modtype : 
+  module_ident -> module_path -> Summary.frozen -> object_prefix
+val end_modtype : module_ident 
+  -> object_name * object_prefix * Summary.frozen * library_segment
+(* Lib.add_frozen_state must be called after each of the above functions *)
+
+(*s Compilation units *)
+
+val start_compilation : dir_path -> module_path -> unit
+val end_compilation : dir_path -> object_prefix * library_segment
+
+(* The function [library_dp] returns the [dir_path] of the current
+   compiling library (or [default_library]) *)
+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
+
+(*s Sections *)
+
+val open_section : identifier -> object_prefix
+
+val close_section : export:bool -> identifier -> 
+  object_prefix * library_segment * Summary.frozen
+
+(*s Backtracking (undo). *)
+
+val reset_to : object_name -> unit
+val reset_name : identifier located -> unit
+val reset_mod : identifier located -> unit
+
+(* [back n] resets to the place corresponding to the $n$-th call of 
+   [mark_end_of_command] (counting backwards) *)
+val back : int -> unit
+
+(*s We can get and set the state of the operations (used in [States]). *)
+
+type frozen
+
+val freeze : unit -> frozen
+val unfreeze : frozen -> unit
+
+val init : unit -> unit
+
+val declare_initial_state : unit -> unit
+val reset_initial : unit -> unit
+
+
+(* XML output hooks *)
+val set_xml_open_section : (identifier -> unit) -> unit
+val set_xml_close_section : (identifier -> unit) -> unit
diff --git a/library/libnames.ml b/library/libnames.ml
new file mode 100644
index 00000000..16f5a917
--- /dev/null
+++ b/library/libnames.ml
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: libnames.ml,v 1.11.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+
+type global_reference =
+  | VarRef of variable
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+let subst_global subst ref = match ref with
+  | VarRef _ -> ref
+  | ConstRef kn ->
+      let kn' = subst_kn subst kn in if kn==kn' then ref else
+          ConstRef kn'
+  | IndRef (kn,i) ->
+      let kn' = subst_kn subst kn in if kn==kn' then ref else
+          IndRef(kn',i)
+  | ConstructRef ((kn,i),j) ->
+      let kn' = subst_kn subst kn in if kn==kn' then ref else
+          ConstructRef ((kn',i),j)
+
+let reference_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
+  | VarRef id -> mkVar id
+  | ConstRef sp -> mkConst sp
+  | ConstructRef sp -> mkConstruct sp
+  | IndRef sp -> mkInd sp
+
+module RefOrdered =
+  struct
+    type t = global_reference
+    let compare = Pervasives.compare
+  end
+
+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))
+
+(*s Operations on dirpaths *)
+
+(* Pop the last n module idents *)
+let extract_dirpath_prefix n dir =
+  make_dirpath (list_skipn n (repr_dirpath dir))
+
+let dirpath_prefix p = match repr_dirpath p with
+  | [] -> anomaly "dirpath_prefix: empty dirpath"
+  | _::l -> make_dirpath l
+
+let is_dirpath_prefix_of d1 d2 =
+  list_prefix_of (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
+
+(* 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])
+
+let split_dirpath d =
+  let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l)
+
+let extend_dirpath p id = make_dirpath (id :: repr_dirpath p)
+
+
+(*
+let path_of_constructor env ((sp,tyi),ind) =
+   let mib = Environ.lookup_mind sp env in
+   let mip = mib.mind_packets.(tyi) in 
+   let (pa,_) = repr_path sp in 
+   Names.make_path pa (mip.mind_consnames.(ind-1))
+
+let path_of_inductive env (sp,tyi) =
+  if tyi = 0 then sp
+  else
+    let mib = Environ.lookup_mind sp env in
+    let mip = mib.mind_packets.(tyi) in 
+    let (pa,_) = repr_path sp in 
+    Names.make_path pa (mip.mind_typename) 
+*)
+(* parsing *)
+let parse_dir s =
+  let len = String.length s in
+  let rec decoupe_dirs dirs n =
+    if n>=len then dirs else
+    let pos =
+      try
+	String.index_from s n '.' 
+      with Not_found -> len
+    in
+    let dir = String.sub s n (pos-n) in
+      decoupe_dirs ((id_of_string dir)::dirs) (pos+1)	  
+  in
+    decoupe_dirs [] 0
+
+let dirpath_of_string s = 
+  match parse_dir s with
+      [] -> invalid_arg "dirpath_of_string"
+    | dir -> make_dirpath dir
+
+module Dirset = Set.Make(struct type t = dir_path let compare = compare end)
+module Dirmap = Map.Make(struct type t = dir_path let compare = compare end)
+
+(*s Section paths are absolute names *)
+
+type section_path = {
+  dirpath : dir_path ;
+  basename : identifier }
+
+let make_path pa id = { dirpath = pa; basename = id }
+let repr_path { dirpath = pa; basename = id } = (pa,id)
+
+(* parsing and printing of section paths *)
+let string_of_path sp =
+  let (sl,id) = repr_path sp in
+  if repr_dirpath sl = [] then string_of_id id
+  else (string_of_dirpath sl) ^ "." ^ (string_of_id id)
+
+let sp_ord sp1 sp2 =
+  let (p1,id1) = repr_path sp1
+  and (p2,id2) = repr_path sp2 in
+  let p_bit = compare p1 p2 in
+  if p_bit = 0 then id_ord id1 id2 else p_bit
+
+module SpOrdered =
+  struct
+    type t = section_path
+    let compare = sp_ord
+  end
+
+module Spset = Set.Make(SpOrdered)
+module Sppred = Predicate.Make(SpOrdered)
+module Spmap = Map.Make(SpOrdered)
+
+let dirpath sp = let (p,_) = repr_path sp in p
+let basename sp = let (_,id) = repr_path sp in id
+
+let path_of_string s =
+  try
+    let dir, id = split_dirpath (dirpath_of_string s) in
+    make_path dir id
+  with
+    | Invalid_argument _ -> invalid_arg "path_of_string"
+
+let pr_sp sp = str (string_of_path sp) 
+
+let restrict_path n sp =
+  let dir, s = repr_path sp in
+  let dir' = list_firstn n (repr_dirpath dir) in
+  make_path (make_dirpath dir') s
+
+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 decode_kn kn = 
+  let mp,sec_dir,l = repr_kn 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
+
+let make_qualid = make_path
+let repr_qualid = repr_path
+
+let string_of_qualid = string_of_path
+let pr_qualid = pr_sp
+
+let qualid_of_string = path_of_string
+
+let qualid_of_sp sp = sp
+let make_short_qualid id = make_qualid empty_dirpath id
+let qualid_of_dirpath dir = 
+  let (l,a) = split_dirpath dir in
+  make_qualid l a
+
+type object_name = section_path * kernel_name
+
+type object_prefix = dir_path * (module_path * dir_path)
+
+let make_oname (dirpath,(mp,dir)) id = 
+  make_path dirpath id, make_kn mp dir (label_of_id id)
+
+(* to this type are mapped dir_path's in the nametab *)
+type global_dir_reference = 
+  | DirOpenModule of object_prefix
+  | DirOpenModtype of object_prefix
+  | DirOpenSection of object_prefix
+  | DirModule of object_prefix
+  | DirClosedSection of dir_path
+      (* this won't last long I hope! *)
+
+(*  | ModRef mp ->
+      let mp' = subst_modpath subst mp in if mp==mp' then ref else
+          ModRef mp'
+  | ModTypeRef kn ->
+      let kn' = subst_kernel_name subst kn in if kn==kn' then ref else
+          ModTypeRef kn'
+*)
+
+type reference = 
+  | Qualid of qualid located
+  | Ident of identifier located
+
+let qualid_of_reference = function
+  | Qualid (loc,qid) -> loc, qid
+  | Ident (loc,id) -> loc, make_short_qualid id
+
+let string_of_reference = function
+  | Qualid (loc,qid) -> string_of_qualid qid
+  | Ident (loc,id) -> string_of_id id
+
+let pr_reference = function 
+  | Qualid (_,qid) -> pr_qualid qid
+  | Ident (_,id) -> pr_id id
+
+let loc_of_reference = function
+  | Qualid (loc,qid) -> loc
+  | Ident (loc,id) -> loc
diff --git a/library/libnames.mli b/library/libnames.mli
new file mode 100644
index 00000000..6f05333c
--- /dev/null
+++ b/library/libnames.mli
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: libnames.mli,v 1.8.2.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Term
+(*i*)
+
+(*s Global reference is a kernel side type for all references together *)
+type global_reference =
+  | VarRef of variable
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+val subst_global : substitution -> global_reference -> global_reference
+
+(* Turn a global reference into a construction *)
+val constr_of_reference : global_reference -> constr
+
+(* Turn a construction denoting a global into a reference;
+   raise [Not_found] if not a global *)
+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
+
+val dirpath_of_string : string -> dir_path
+
+(* Give the immediate prefix of a [dir_path] *)
+val dirpath_prefix : dir_path -> dir_path 
+
+(* Give the immediate prefix and basename of a [dir_path] *)
+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 extract_dirpath_prefix : int -> dir_path -> dir_path
+val is_dirpath_prefix_of : dir_path -> dir_path -> bool
+
+module Dirset : Set.S with type elt = dir_path
+module Dirmap : Map.S with type key = dir_path
+
+(*s Section paths are {\em absolute} names *)
+type section_path
+
+(* Constructors of [section_path] *)
+val make_path : dir_path -> identifier -> section_path
+
+(* Destructors of [section_path] *)
+val repr_path : section_path -> dir_path * identifier
+val dirpath : section_path -> dir_path
+val basename : section_path -> identifier
+
+(* Parsing and printing of section path as ["coq_root.module.id"] *)
+val path_of_string : string -> section_path
+val string_of_path : section_path -> string
+val pr_sp : section_path -> std_ppcmds
+
+module Sppred : Predicate.S with type elt = section_path
+module Spmap  : Map.S with type key = section_path
+
+val restrict_path : int -> section_path -> section_path
+
+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
+
+
+(*s A [qualid] is a partially qualified ident; it includes fully
+    qualified names (= absolute names) and all intermediate partial
+    qualifications of absolute names, including single identifiers *)
+type qualid
+
+val make_qualid : dir_path -> identifier -> qualid
+val repr_qualid : qualid -> dir_path * identifier
+
+val string_of_qualid : qualid -> string
+val pr_qualid : qualid -> std_ppcmds
+
+val qualid_of_string : string -> qualid
+
+(* Turns an absolute name into a qualified name denoting the same name *)
+val qualid_of_sp : section_path -> qualid
+
+val qualid_of_dirpath : dir_path -> qualid
+
+val make_short_qualid : identifier -> qualid
+
+(* Both names are passed to objects: a "semantic" kernel_name, which
+   can be substituted and a "syntactic" section_path which can be printed
+*)
+
+type object_name = section_path * kernel_name
+
+type object_prefix = dir_path * (module_path * dir_path)
+
+val make_oname : object_prefix -> identifier -> object_name
+
+(* to this type are mapped dir_path's in the nametab *)
+type global_dir_reference = 
+  | DirOpenModule of object_prefix
+  | DirOpenModtype of object_prefix
+  | DirOpenSection of object_prefix
+  | DirModule of object_prefix
+  | DirClosedSection of dir_path
+      (* this won't last long I hope! *)
+
+type reference = 
+  | Qualid of qualid located
+  | Ident of identifier located
+
+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
diff --git a/library/libobject.ml b/library/libobject.ml
new file mode 100644
index 00000000..2e531e05
--- /dev/null
+++ b/library/libobject.ml
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: libobject.ml,v 1.8.8.1 2004/07/16 19:30:35 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+
+(* 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
+   wants to work with restricted Coq programs that have only parts of
+   the full capabilities, but may still be able to work correctly for
+   limited purposes.  One example is for the graphical interface, that uses
+   such a limite coq process to do only parsing.  It loads .vo files, but
+   is only interested in loading the grammar rule definitions. *)
+
+let relax_flag = ref false;;
+
+let relax b = relax_flag := b;;
+
+type 'a substitutivity = 
+    Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
+
+
+type 'a object_declaration = {
+  object_name : string;
+  cache_function : object_name * 'a -> unit;
+  load_function : int -> object_name * 'a -> unit;
+  open_function : int -> object_name * 'a -> unit;
+  classify_function : object_name * 'a -> 'a substitutivity;
+  subst_function : object_name * substitution * 'a -> 'a;
+  export_function : 'a -> 'a option }
+
+let yell s = anomaly s
+
+let default_object s = {
+  object_name = s;
+  cache_function = (fun _ -> ());
+  load_function = (fun _ _ -> ());
+  open_function = (fun _ _ -> ());
+  subst_function = (fun _ -> 
+    yell ("The object "^s^" does not know how to substitute!"));
+  classify_function = (fun (_,obj) -> Keep obj);
+  export_function = (fun _ -> None)} 
+
+
+(* The suggested object declaration is the following:
+
+   declare_object { (default_object "MY OBJECT") with
+       cache_function = fun (sp,a) -> Mytbl.add sp a}
+
+   and the listed functions are only those which definitions accually 
+   differ from the default.
+
+   This helps introducing new functions in objects.
+*)
+
+let ident_subst_function (_,_,a) = a
+
+type obj = Dyn.t (* persistent dynamic objects *)
+
+type dynamic_object_declaration = {
+  dyn_cache_function : object_name * obj -> unit;
+  dyn_load_function : int -> object_name * obj -> unit;
+  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_export_function : obj -> obj option }
+
+let object_tag lobj = Dyn.tag lobj
+
+let cache_tab = 
+  (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
+
+let declare_object odecl =
+  let na = odecl.object_name in
+  let (infun,outfun) = Dyn.create na in
+  let cacher (oname,lobj) =
+    if Dyn.tag lobj = na then odecl.cache_function (oname,outfun lobj)
+    else anomaly "somehow we got the wrong dynamic object in the cachefun"
+  and loader i (oname,lobj) =
+    if Dyn.tag lobj = na then odecl.load_function i (oname,outfun lobj)
+    else anomaly "somehow we got the wrong dynamic object in the loadfun"
+  and opener i (oname,lobj) =
+    if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj)
+    else anomaly "somehow we got the wrong dynamic object in the openfun"
+  and substituter (oname,sub,lobj) = 
+    if Dyn.tag lobj = na then 
+      infun (odecl.subst_function (oname,sub,outfun lobj))
+    else anomaly "somehow we got the wrong dynamic object in the substfun"
+  and classifier (spopt,lobj) = 
+    if Dyn.tag lobj = na then 
+      match odecl.classify_function (spopt,outfun lobj) with
+	| Dispose -> Dispose
+	| Substitute obj -> Substitute (infun obj)
+	| Keep obj -> Keep (infun obj)
+	| Anticipate (obj) -> Anticipate (infun obj)
+    else 
+      anomaly "somehow we got the wrong dynamic object in the classifyfun"
+  and exporter lobj = 
+    if Dyn.tag lobj = na then 
+      option_app infun (odecl.export_function (outfun lobj))
+    else 
+      anomaly "somehow we got the wrong dynamic object in the exportfun"
+
+  in 
+  Hashtbl.add cache_tab na { dyn_cache_function = cacher;
+			     dyn_load_function = loader;
+                             dyn_open_function = opener;
+			     dyn_subst_function = substituter;
+			     dyn_classify_function = classifier;
+                             dyn_export_function = exporter };
+  (infun,outfun)
+
+(* this function describes how the cache, load, open, and export functions
+   are triggered.  In relaxed mode, this function just return a meaningless
+   value instead of raising an exception when they fail. *)
+
+let apply_dyn_fun deflt f lobj =
+  let tag = object_tag lobj in
+    try
+      let dodecl =
+    	try
+	  Hashtbl.find cache_tab tag
+    	with Not_found -> 
+	  if !relax_flag then
+	    failwith "local to_apply_dyn_fun"
+	  else
+	    anomaly
+	      ("Cannot find library functions for an object with tag "^tag) in 
+  	f dodecl
+    with
+	Failure "local to_apply_dyn_fun" -> deflt;;
+
+let cache_object ((_,lobj) as node) =
+  apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj
+
+let load_object i ((_,lobj) as node) = 
+  apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj
+
+let open_object i ((_,lobj) as node) = 
+  apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj
+
+let subst_object ((_,_,lobj) as node) = 
+  apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj
+
+let classify_object ((_,lobj) as node) = 
+  apply_dyn_fun Dispose (fun d -> d.dyn_classify_function node) 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
new file mode 100644
index 00000000..8a3811e1
--- /dev/null
+++ b/library/libobject.mli
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: libobject.mli,v 1.9.8.1 2004/07/16 19:30:35 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Libnames
+(*i*)
+
+(* [Libobject] declares persistent objects, given with methods:
+
+   * a caching function specifying how to add the object in the current
+     scope;
+     If the object wishes to register its visibility in the Nametab, 
+     it should do so for all possible sufixes.
+
+   * a loading function, specifying what to do when the module 
+     containing the object is loaded; 
+     If the object wishes to register its visibility in the Nametab, 
+     it should do so for all sufixes no shorter then the "int" argument
+
+   * an opening function, specifying what to do when the module 
+     containing the object is opened (imported);
+     If the object wishes to register its visibility in the Nametab, 
+     it should do so for the sufix of the length the "int" argument
+
+   * a classification function, specyfying what to do with the object,
+     when the current module (containing the object) is ended;
+     The possibilities are:
+     Dispose   - the object dies at the end of the module
+     Substitue - meaning the object is substitutive and 
+                 the module name must be updated
+     Keep      - the object is not substitutive, but survives module 
+                 closing
+     Anticipate - this is for objects which have to be explicitely 
+                 managed by the end_module function (like Require 
+                 and Read markers)
+
+     The classification function is also an occasion for a cleanup
+     (if this function returns Keep or Substitute of some object, the 
+     cache method is never called for it)
+
+   * a substitution function, performing the substitution; 
+     this function should be declared for substitutive objects 
+     only (see obove)
+
+   * an export function, to enable optional writing of its contents 
+     to disk (.vo). This function is also the oportunity to remove 
+     redundant information in order to keep .vo size small 
+
+     The export function is a little obsolete and will be removed 
+     in the near future... 
+
+*)
+
+type 'a substitutivity = 
+    Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a
+
+type 'a object_declaration = {
+  object_name : string;
+  cache_function : object_name * 'a -> unit;
+  load_function : int -> object_name * 'a -> unit;
+  open_function : int -> object_name * 'a -> unit;
+  classify_function : object_name * 'a -> 'a substitutivity;
+  subst_function : object_name * substitution * 'a -> 'a;
+  export_function : 'a -> 'a option }
+
+(* The default object is a "Keep" object with empty methods. 
+   Object creators are advised to use the construction
+   [{(default_object "MY_OBJECT") with
+      cache_function = ...
+   }]
+   and specify only these functions which are not empty/meaningless
+
+*)
+
+val default_object : string -> 'a object_declaration
+
+(* the identity substitution function *)
+val ident_subst_function : object_name * substitution * 'a -> 'a
+
+(*s Given an object declaration, the function [declare_object]
+   will hand back two functions, the "injection" and "projection"
+   functions for dynamically typed library-objects. *)
+
+type obj
+
+val declare_object : 
+  'a object_declaration -> ('a -> obj) * (obj -> 'a)
+
+val object_tag : obj -> string
+
+val cache_object : object_name * obj -> unit
+val load_object : int -> object_name * obj -> unit
+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 relax : bool -> unit
diff --git a/library/library.ml b/library/library.ml
new file mode 100644
index 00000000..0477a8f3
--- /dev/null
+++ b/library/library.ml
@@ -0,0 +1,704 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: library.ml,v 1.79.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open Pp
+open Util
+
+open Names
+open Libnames
+open Nameops
+open Safe_typing
+open Libobject
+open Lib
+open Nametab
+open Declaremods
+
+(*************************************************************************)
+(*s Load path. Mapping from physical to logical paths etc.*)
+
+type logical_path = dir_path
+
+let load_path = ref ([],[] : System.physical_path list * logical_path list)
+
+let get_load_path () = fst !load_path
+
+(* 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 = canonical_path_name phys_dir in
+  match list_filter2 (fun p d -> p = phys_dir) !load_path with
+  | _,[dir] -> dir
+  | _,[] -> Nameops.default_root_prefix
+  | _,l -> anomaly ("Two logical paths are associated to "^phys_dir)
+
+let remove_path dir =
+  load_path := list_filter2 (fun p d -> p <> dir) !load_path
+
+let add_load_path_entry (phys_path,coq_path) =
+  let phys_path = 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 = 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 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)
+
+(************************************************************************)
+(*s Modules on disk contain the following informations (after the magic 
+    number, and before the digest). *)
+
+type compilation_unit_name = dir_path
+
+type library_disk = { 
+  md_name : compilation_unit_name;
+  md_compiled : compiled_library;
+  md_objects : library_objects;
+  md_deps : (compilation_unit_name * Digest.t) list;
+  md_imports : compilation_unit_name list }
+
+(*s Modules loaded in memory contain the following informations. They are
+    kept in the global table [libraries_table]. *)
+
+type library_t = {
+  library_name : compilation_unit_name;
+  library_filename : System.physical_path;
+  library_compiled : compiled_library;
+  library_objects : library_objects;
+  library_deps : (compilation_unit_name * Digest.t) list;
+  library_imports : compilation_unit_name list;
+  library_digest : Digest.t }
+
+module CompilingLibraryOrdered = 
+  struct
+    type t = dir_path
+    let compare d1 d2 =
+      Pervasives.compare
+        (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
+  end
+
+module CompilingLibraryMap = Map.Make(CompilingLibraryOrdered)
+
+(* This is a map from names to libraries *)
+let libraries_table = ref CompilingLibraryMap.empty
+
+(* These are the _ordered_ lists of loaded, imported and exported libraries *)
+let libraries_loaded_list = ref []
+let libraries_imports_list = ref []
+let libraries_exports_list = ref []
+
+let freeze () =
+  !libraries_table,
+  !libraries_loaded_list,
+  !libraries_imports_list,
+  !libraries_exports_list
+
+let unfreeze (mt,mo,mi,me) = 
+  libraries_table := mt;
+  libraries_loaded_list := mo;
+  libraries_imports_list := mi;
+  libraries_exports_list := me
+
+let init () =
+  libraries_table := CompilingLibraryMap.empty;
+  libraries_loaded_list := [];
+  libraries_imports_list := [];
+  libraries_exports_list := []
+
+let _ = 
+  Summary.declare_summary "MODULES"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let find_library s =
+  try
+    CompilingLibraryMap.find s !libraries_table
+  with Not_found ->
+    error ("Unknown library " ^ (string_of_dirpath s))
+
+let library_full_filename m = (find_library m).library_filename
+
+let library_is_loaded dir =
+  try let _ = CompilingLibraryMap.find dir !libraries_table in true
+  with Not_found -> false
+
+let library_is_opened dir = 
+  List.exists (fun m -> m.library_name = dir) !libraries_imports_list
+
+let library_is_exported dir =
+  List.exists (fun m -> m.library_name = dir) !libraries_exports_list
+
+let loaded_libraries () = 
+  List.map (fun m -> m.library_name) !libraries_loaded_list
+
+let opened_libraries () =
+  List.map (fun m -> m.library_name) !libraries_imports_list
+
+  (* If a library is loaded several time, then the first occurrence must
+     be performed first, thus the libraries_loaded_list ... *)
+
+let register_loaded_library m =
+  let rec aux = function
+    | [] -> [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
+
+  (* ... while if a library is imported/exported several time, then
+     only the last occurrence is really needed - though the imported
+     list may differ from the exported list (consider the sequence
+     Export A; Export B; Import A which results in A;B for exports but
+     in B;A for imports) *)
+
+let rec remember_last_of_each l m =
+  match l with
+  | [] -> [m]
+  | m'::l' when m'.library_name = m.library_name -> remember_last_of_each l' m
+  | m'::l' -> m' :: remember_last_of_each l' m
+
+let register_open_library export m =
+  libraries_imports_list := remember_last_of_each !libraries_imports_list m;
+  if export then 
+    libraries_exports_list := remember_last_of_each !libraries_exports_list 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]. *)
+
+let eq_lib_name m1 m2 = m1.library_name = m2.library_name
+
+let open_library export explicit_libs m =
+  if
+    (* Only libraries indirectly to open are not reopen *)
+    (* Libraries explicitly mentionned by the user are always reopen *)
+    List.exists (eq_lib_name m) explicit_libs
+    or not (library_is_opened m.library_name)
+  then begin
+    register_open_library export m;
+    Declaremods.really_import_module (MPfile m.library_name)
+  end
+  else
+    if export then 
+      libraries_exports_list := remember_last_of_each !libraries_exports_list m
+
+let open_libraries export modl = 
+  let to_open_list = 
+    List.fold_left
+      (fun l m ->
+         let subimport =
+           List.fold_left
+             (fun l m -> remember_last_of_each l (find_library m))
+             l m.library_imports
+         in remember_last_of_each subimport m)
+      [] modl in
+  List.iter (open_library export modl) to_open_list
+
+
+(**********************************************************************)
+(* import and export  -  synchronous operations*)
+
+let cache_import (_,(dir,export)) = 
+  open_libraries export [find_library dir]
+
+let open_import i (_,(dir,_) as obj) =
+  if i=1 then
+    (* even if the library is already imported, we re-import it *)
+    (* if not (library_is_opened dir) then *)
+      cache_import obj
+
+let subst_import (_,_,o) = o
+
+let export_import o = Some o
+
+let classify_import (_,(_,export as obj)) = 
+  if export then Substitute obj else Dispose
+
+
+let (in_import, out_import) =
+  declare_object {(default_object "IMPORT LIBRARY") with 
+       cache_function = cache_import;
+       open_function = open_import;
+       subst_function = subst_import;
+       classify_function = classify_import }
+
+
+(************************************************************************)
+(*s Loading from disk to cache (preparation phase) *)
+
+let vo_magic_number7 = 07992 (* V8.0 final old syntax *)
+let vo_magic_number8 = 08002 (* V8.0 final new syntax *)
+
+let (raw_extern_library7, raw_intern_library7) =
+  System.raw_extern_intern vo_magic_number7 ".vo"
+
+let (raw_extern_library8, raw_intern_library8) =
+  System.raw_extern_intern vo_magic_number8 ".vo"
+
+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 raw_extern_library =
+  if !Options.v7 then raw_extern_library7 else raw_extern_library8
+
+(* cache for loaded libraries *)
+let compunit_cache = ref CompilingLibraryMap.empty
+
+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). *)
+
+exception LibUnmappedDir
+exception LibNotFound
+type library_location = LibLoaded | LibInPath
+
+let locate_absolute_library dir =
+  (* Look if loaded in current environment *)
+  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
+
+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 lighten_library m = 
+  if !Options.dont_load_proofs then lighten_library m else m
+
+let mk_library md f digest = {
+  library_name = md.md_name;
+  library_filename = f;
+  library_compiled = lighten_library md.md_compiled;
+  library_objects = md.md_objects;
+  library_deps = md.md_deps;
+  library_imports = md.md_imports;
+  library_digest = digest }
+
+let intern_from_file f =
+  let ch = with_magic_number_check raw_intern_library f in
+  let md = System.marshal_in ch in
+  let digest = System.marshal_in ch in
+  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
+  with Not_found ->
+  try
+    (* Look if already loaded in cache and consequently its dependencies *)
+    CompilingLibraryMap.find dir !compunit_cache
+  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
+
+and intern_mandatory_library caller (dir,d) =
+  let m = intern_absolute_library_from 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
+
+let rec_intern_library mref = let _ = intern_library mref in ()
+
+let check_library_short_name f dir = function
+  | Some id when id <> snd (split_dirpath dir) ->
+      errorlabstrm "check_library_short_name"
+      (str ("The file " ^ f ^ " contains library") ++ spc () ++
+      pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++
+      pr_id id)
+  | _ -> ()
+
+let rec_intern_by_filename_only id f =
+  let m = intern_from_file f in
+  (* Only the base name is expected to match *)
+  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
+    Options.if_verbose warning 
+      ((string_of_dirpath m.library_name)^" is already loaded from file "^
+       m'.library_filename);
+    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 =
+  (* Look if loaded in current environment *)
+  try 
+    let dir = Nametab.full_name_module qid in
+    (LibLoaded, dir, library_full_filename dir)
+  with Not_found ->
+  (* Look if in loadpath *)
+  try
+    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
+    (LibInPath, extend_dirpath (find_logical_path path) base, 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 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
+  rec_intern_by_filename_only idopt f
+
+(**********************************************************************)
+(*s [require_library] loads and opens a library. This is a synchronized
+    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_* )
+
+  execution phase: (through add_leaf and cache_require)
+    the library is loaded in the environment and Nametab, the objects are 
+    registered etc, using functions from Declaremods (via load_library, 
+    which recursively loads its dependencies)
+
+
+  The [read_library] operation is very similar, but does not "open"
+    the library
+*)
+
+type library_reference = dir_path list * bool option
+
+let string_of_library (_,dir,_) = string_of_id (List.hd (repr_dirpath dir))
+
+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)
+
+  (* 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 (in_require, out_require) =
+  declare_object {(default_object "REQUIRE") with
+       cache_function = cache_require;
+       load_function = load_require;
+       export_function = export_require;
+       classify_function = (fun (_,o) -> Anticipate o) }
+
+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
+    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
+    end
+    else
+      add_anonymous_leaf (in_require (modrefl,Some 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));
+  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) =
+  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))
+      | mp ->
+	  import_module export mp
+  with
+      Not_found ->
+	user_err_loc
+        (loc,"import_library",
+	 str ((string_of_qualid qid)^" is not a module"))
+  
+(************************************************************************)
+(*s [save_library s] saves the library [m] to the disk. *)
+
+let start_library f = 
+  let _,longf = 
+    System.find_file_in_path (get_load_path ()) (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
+
+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 md = { 
+    md_name = s;
+    md_compiled = cenv;
+    md_objects = seg;
+    md_deps = current_deps ();
+    md_imports = current_reexports () } in
+  let (f',ch) = raw_extern_library f in
+  try
+    System.marshal_out ch md;
+    flush ch;
+    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")
+
+
+(*s Display the memory use of a library. *)
+
+open Printf
+
+let mem s =
+  let m = find_library s in
+  h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)"
+		 (size_kb m) (size_kb m.library_compiled) 
+		 (size_kb m.library_objects)))
diff --git a/library/library.mli b/library/library.mli
new file mode 100644
index 00000000..18be1671
--- /dev/null
+++ b/library/library.mli
@@ -0,0 +1,94 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: library.mli,v 1.23.2.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+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]. *)
+
+val read_library : qualid located -> unit
+
+val read_library_from_file : System.physical_path -> unit
+
+(* [import_library true qid] = [export qid] *)
+ 
+val import_library : bool -> qualid located -> unit
+
+val library_is_loaded : dir_path -> bool
+val library_is_opened : dir_path -> bool
+
+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. *)
+
+val library_full_filename : dir_path -> string
+
+
+(*s Global load path *)
+type logical_path = dir_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
+
+exception LibUnmappedDir
+exception LibNotFound
+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. *)
+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
new file mode 100644
index 00000000..ea40aae5
--- /dev/null
+++ b/library/nameops.ml
@@ -0,0 +1,173 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: nameops.ml,v 1.21.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+
+(* Identifiers *)
+
+let pr_id id = str (string_of_id id)
+
+let wildcard = id_of_string "_"
+
+(* Utilities *)
+
+let code_of_0 = Char.code '0'
+let code_of_9 = Char.code '9'
+
+let cut_ident skip_quote s =
+  let s = string_of_id s in
+  let slen = String.length s in
+  (* [n'] is the position of the first non nullary digit *)
+  let rec numpart n n' =
+    if n = 0 then 
+      error
+	("The string " ^ s ^ " is not an identifier: it contains only digits or _")
+    else 
+      let c = Char.code (String.get s (n-1)) in
+      if c = code_of_0 && n <> slen then 
+	numpart (n-1) n' 
+      else if code_of_0 <= c && c <= code_of_9 then 
+	numpart (n-1) (n-1)
+      else if skip_quote & (c = Char.code '\'' || c = Char.code '_') then
+	numpart (n-1) (n-1)
+      else
+	n'
+  in
+  numpart slen slen
+
+let repr_ident s =
+  let numstart = cut_ident false s in
+  let s = string_of_id s in
+  let slen = String.length s in
+  if numstart = slen then 
+    (s, None)
+  else
+    (String.sub s 0 numstart,
+     Some (int_of_string (String.sub s numstart (slen - numstart))))
+
+let make_ident sa = function
+  | Some n -> 
+      let c = Char.code (String.get sa (String.length sa -1)) in
+      let s =
+        if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n)
+        else sa ^ "_" ^ (string_of_int n) in
+      id_of_string s
+  | None -> id_of_string (String.copy sa)
+
+let root_of_id id =
+  let suffixstart = cut_ident true id in
+  id_of_string (String.sub (string_of_id id) 0 suffixstart)
+
+(* Rem: semantics is a bit different, if an ident starts with toto00 then
+  after successive renamings it comes to toto09, then it goes on with toto10 *)
+let lift_subscript id =
+  let id = string_of_id id in
+  let len = String.length id in
+  let rec add carrypos =
+    let c = id.[carrypos] in
+    if is_digit c then
+      if c = '9' then begin
+	assert (carrypos>0);
+	add (carrypos-1)
+      end
+      else begin
+	let newid = String.copy id in
+	String.fill newid (carrypos+1) (len-1-carrypos) '0';
+	newid.[carrypos] <- Char.chr (Char.code c + 1);
+	newid
+      end
+    else begin
+      let newid = id^"0" in
+      if carrypos < len-1 then begin
+	String.fill newid (carrypos+1) (len-1-carrypos) '0';
+	newid.[carrypos+1] <- '1'
+      end;
+      newid
+    end
+  in id_of_string (add (len-1))
+
+let has_subscript id =
+  let id = string_of_id id in
+  is_digit (id.[String.length id - 1])
+
+let forget_subscript id =
+  let numstart = cut_ident false id in
+  let newid = String.make (numstart+1) '0' in
+  String.blit (string_of_id id) 0 newid 0 numstart;
+  (id_of_string newid)
+
+let add_suffix id s = id_of_string (string_of_id id ^ s)
+let add_prefix s id = id_of_string (s ^ string_of_id id)
+
+let atompart_of_id id = fst (repr_ident id)
+
+(* Fresh names *)
+
+let lift_ident = lift_subscript
+
+let next_ident_away id avoid = 
+  if List.mem id avoid then
+    let id0 = if not (has_subscript id) then id else 
+    (* Ce serait sans doute mieux avec quelque chose inspiré de 
+       *** make_ident id (Some 0) *** mais ça brise la compatibilité... *)
+    forget_subscript id in
+    let rec name_rec id =
+      if List.mem id avoid then name_rec (lift_ident id) else id in 
+    name_rec id0
+  else id
+
+let next_ident_away_from id avoid = 
+  let rec name_rec id =
+    if List.mem id avoid then name_rec (lift_ident id) else id in 
+  name_rec id 
+
+(* Names *)
+
+let out_name = function
+  | Name id -> id
+  | Anonymous -> anomaly "out_name: expects a defined name"
+
+let name_fold f na a =
+  match na with
+  | Name id -> f id a
+  | Anonymous -> a
+
+let name_cons na l =
+  match na with
+  | Anonymous -> l 
+  | Name id -> id::l
+
+let name_app f = function
+  | Name id -> Name (f id)
+  | Anonymous -> 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 pr_lab l = str (string_of_label l)
+
+let default_library = Names.initial_dir (* = ["Top"] *)
+
+(*s Roots of the space of absolute names *)
+let coq_root = id_of_string "Coq"
+let default_root_prefix = make_dirpath []
+
+(* Metavariables *)
+let pr_meta = Pp.int
+let string_of_meta = string_of_int
diff --git a/library/nameops.mli b/library/nameops.mli
new file mode 100644
index 00000000..4b7cecda
--- /dev/null
+++ b/library/nameops.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: nameops.mli,v 1.12.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open Names
+
+(* Identifiers and names *)
+val pr_id : identifier -> Pp.std_ppcmds
+val wildcard : identifier
+
+val make_ident : string -> int option -> identifier
+val repr_ident : identifier -> string * int option
+
+val atompart_of_id : identifier -> string  (* remove trailing digits *)
+val root_of_id : identifier -> identifier (* remove trailing digits, ' and _ *)
+
+val add_suffix : identifier -> string -> identifier
+val add_prefix : string -> identifier -> identifier
+
+val lift_ident           : identifier -> identifier
+val next_ident_away      : identifier -> identifier list -> identifier
+val next_ident_away_from : identifier -> identifier list -> identifier
+
+val next_name_away : name -> identifier list -> identifier
+val next_name_away_with_default :
+  string -> name -> identifier list -> identifier
+
+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 pr_lab : label -> Pp.std_ppcmds
+
+(* some preset paths *)
+
+val default_library : dir_path
+
+(* This is the root of the standard library of Coq *)
+val coq_root : module_ident
+
+(* This is the default root prefix for developments which doesn't
+   mention a root *)
+val default_root_prefix : dir_path
+
+(* Metavariables *)
+val pr_meta : Term.metavariable -> Pp.std_ppcmds
+val string_of_meta : Term.metavariable -> string
diff --git a/library/nametab.ml b/library/nametab.ml
new file mode 100755
index 00000000..f009d867
--- /dev/null
+++ b/library/nametab.ml
@@ -0,0 +1,553 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: nametab.ml,v 1.48.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Libnames
+open Nameops
+open Declarations
+
+
+exception GlobalizationError of qualid
+exception GlobalizationConstantError of qualid
+
+let error_global_not_found_loc loc q =
+  Stdpp.raise_with_loc loc (GlobalizationError q)
+
+let error_global_constant_not_found_loc loc q =
+  Stdpp.raise_with_loc loc (GlobalizationConstantError q)
+
+let error_global_not_found q = raise (GlobalizationError q)
+
+
+
+(* The visibility can be registered either 
+   - for all suffixes not shorter then a given int - when the object
+     is loaded inside a module
+   or
+   - for a precise suffix, when the module containing (the module
+     containing ...) the object is open (imported) 
+*)
+type visibility = Until of int | Exactly of int
+
+
+(* Data structure for nametabs *******************************************)
+
+
+(* This module type will be instantiated by [section_path] of [dir_path] *)
+(* The [repr] function is assumed to return the reversed list of idents. *)
+module type UserName = sig 
+  type t
+  val to_string : t -> string
+  val repr : t -> identifier * module_ident list
+end
+
+
+(* A ['a t] is a map from [user_name] to ['a], with possible lookup by
+   partially qualified names of type [qualid]. The mapping of
+   partially qualified names to ['a] is determined by the [visibility]
+   parameter of [push].
+   
+   The [shortest_qualid] function given a user_name Coq.A.B.x, tries
+   to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes
+   the same object. 
+*)
+module type NAMETREE = sig
+  type 'a t
+  type user_name
+  
+  val empty : 'a t
+  val push : visibility -> user_name -> 'a -> 'a t -> 'a t
+  val locate : qualid -> 'a t -> 'a
+  val find : user_name -> 'a t -> 'a
+  val exists : user_name -> 'a t -> bool
+  val user_name : qualid -> 'a t -> user_name
+  val shortest_qualid : Idset.t -> user_name -> 'a t -> qualid
+  val find_prefixes : qualid -> 'a t -> 'a list
+end
+
+module Make(U:UserName) : NAMETREE with type user_name = U.t 
+				     = 
+struct
+
+  type user_name = U.t
+
+  type 'a path_status = 
+      Nothing 
+    | Relative of user_name * 'a 
+    | Absolute of user_name * 'a
+
+  (* Dictionaries of short names *)
+  type 'a nametree = ('a path_status * 'a nametree ModIdmap.t)
+
+  type 'a t = 'a nametree Idmap.t
+
+  let empty = Idmap.empty
+		
+  (* [push_until] is used to register [Until vis] visibility and 
+     [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 ->
+	let mc = 
+	  try ModIdmap.find modid dirmap
+	  with Not_found -> (Nothing, ModIdmap.empty)
+	in
+	let this =
+          if level <= 0 then
+	    match current with
+	      | Absolute (n,_) -> 
+		  (* This is an absolute name, we must keep it 
+		     otherwise it may become unaccessible forever *)
+		  warning ("Trying to mask the absolute name \"" 
+			   ^ U.to_string n ^ "\"!"); 
+		  current
+	      | Nothing
+	      | Relative _ -> Relative (uname,o)
+          else current 
+	in
+	let ptab' = push_until uname o (level-1) mc path in
+	  (this, ModIdmap.add modid ptab' dirmap)
+    | [] -> 
+	match current with
+	  | Absolute (uname',o') -> 
+	      if o'=o then begin
+		assert (uname=uname');
+		current, dirmap 
+		  (* we are putting the same thing for the second time :) *)
+	      end
+	      else
+		(* This is an absolute name, we must keep it otherwise it may
+		   become unaccessible forever *)
+		(* But ours is also absolute! This is an error! *)
+		error ("Cannot mask the absolute name \""
+  		       ^ U.to_string uname' ^ "\"!")
+	  | Nothing
+	  | Relative _ -> Absolute (uname,o), dirmap
+
+
+let rec push_exactly uname o level (current,dirmap) = function
+  | modid :: path as dir ->
+      let mc = 
+	try ModIdmap.find modid dirmap
+	with Not_found -> (Nothing, ModIdmap.empty)
+      in
+        if level = 0 then
+	  let this =
+	    match current with
+	      | Absolute (n,_) -> 
+		  (* This is an absolute name, we must keep it 
+		     otherwise it may become unaccessible forever *)
+		  warning ("Trying to mask the absolute name \""
+  			   ^ U.to_string n ^ "\"!");
+		  current
+	      | Nothing
+	      | Relative _ -> Relative (uname,o)
+	  in
+	    (this, dirmap)
+	else (* not right level *)
+	  let ptab' = push_exactly uname o (level-1) mc path in
+	    (current, ModIdmap.add modid ptab' dirmap)
+  | [] -> 
+      anomaly "Prefix longer than path! Impossible!"
+
+
+let push visibility uname o tab =
+  let id,dir = U.repr uname in
+  let ptab =
+    try Idmap.find id tab
+    with Not_found -> (Nothing, ModIdmap.empty) 
+  in
+  let ptab' = match visibility with
+    | Until i -> push_until uname o (i-1) ptab dir
+    | Exactly i -> push_exactly uname o (i-1) ptab dir
+  in
+    Idmap.add id ptab' tab
+
+
+let rec search (current,modidtab) = function
+  | modid :: path -> search (ModIdmap.find modid modidtab) path
+  | [] -> current
+      
+let find_node qid tab =
+  let (dir,id) = repr_qualid qid in
+    search (Idmap.find id tab) (repr_dirpath dir)
+
+let locate qid tab = 
+  let o = match find_node qid tab with
+    | Absolute (uname,o) | Relative (uname,o) -> o
+    | Nothing -> raise Not_found                                            
+  in
+    o
+
+let user_name qid tab =
+  let uname = match find_node qid tab with
+    | Absolute (uname,o) | Relative (uname,o) -> uname
+    | Nothing -> raise Not_found                                            
+  in
+    uname
+  
+let find uname tab = 
+  let id,l = U.repr uname in
+    match search (Idmap.find id tab) l with
+	Absolute (_,o) -> o
+      | _ -> raise Not_found
+
+let exists uname tab =
+  try 
+    let _ = find uname tab in
+      true
+  with
+      Not_found -> false
+
+let shortest_qualid ctx uname tab = 
+  let id,dir = U.repr uname in
+  let hidden = Idset.mem id ctx in
+  let rec find_uname pos dir (path,tab) = match path with
+    | Absolute (u,_) | Relative (u,_)
+          when u=uname && not(pos=[] && hidden) -> List.rev pos
+    | _ -> 
+	match dir with 
+	    [] -> raise Not_found
+	  | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tab)
+  in
+  let ptab = Idmap.find id tab in
+  let found_dir = find_uname [] dir ptab in
+    make_qualid (make_dirpath found_dir) id
+
+let push_node node l =
+  match node with
+  | Absolute (_,o) | Relative (_,o) when not (List.mem o l) -> o::l
+  | _ -> l
+
+let rec flatten_idmap tab l =
+  ModIdmap.fold (fun _ (current,idtab) l ->
+    flatten_idmap idtab (push_node current l)) tab l
+
+let rec search_prefixes (current,modidtab) = function
+  | modid :: path -> search_prefixes (ModIdmap.find modid modidtab) path
+  | [] -> List.rev (flatten_idmap  modidtab (push_node current []))
+      
+let find_prefixes qid tab =
+  try
+    let (dir,id) = repr_qualid qid in
+    search_prefixes (Idmap.find id tab) (repr_dirpath dir)
+  with Not_found -> []
+
+end
+
+
+
+(* Global name tables *************************************************)
+
+module SpTab = Make (struct 
+		       type t = section_path
+		       let to_string = string_of_path
+		       let repr sp = 
+			 let dir,id = repr_path sp in
+			   id, (repr_dirpath dir)
+		     end)
+
+
+type ccitab = extended_global_reference SpTab.t
+let the_ccitab = ref (SpTab.empty : ccitab)
+
+type kntab = kernel_name SpTab.t
+let the_modtypetab = ref (SpTab.empty : kntab)
+let the_tactictab = ref (SpTab.empty : kntab)
+
+type objtab = unit SpTab.t
+let the_objtab = ref (SpTab.empty : objtab)
+
+
+module DirTab = Make(struct 
+		       type t = dir_path
+		       let to_string = string_of_dirpath
+		       let repr dir = match repr_dirpath dir with
+			 | [] -> anomaly "Empty dirpath"
+			 | id::l -> (id,l)
+		     end)
+
+(* If we have a (closed) module M having a submodule N, than N does not
+   have the entry in [the_dirtab]. *)
+type dirtab = global_dir_reference DirTab.t
+let the_dirtab = ref (DirTab.empty : dirtab)
+
+
+(* Reversed name tables ***************************************************)
+
+(* This table translates extended_global_references back to section paths *)
+module Globrevtab = Map.Make(struct 
+			       type t=extended_global_reference 
+			       let compare = compare 
+			     end)
+
+type globrevtab = section_path Globrevtab.t
+let the_globrevtab = ref (Globrevtab.empty : globrevtab)
+
+
+type mprevtab = dir_path MPmap.t
+let the_modrevtab = ref (MPmap.empty : mprevtab)
+
+type knrevtab = section_path KNmap.t
+let the_modtyperevtab = ref (KNmap.empty : knrevtab)
+let the_tacticrevtab = ref (KNmap.empty : knrevtab)
+
+
+(* Push functions *********************************************************)
+
+(* This is for permanent constructions (never discharged -- but with
+   possibly limited visibility, i.e. Theorem, Lemma, Definition, Axiom,
+   Parameter but also Remark and Fact) *)
+
+let push_xref visibility sp xref =
+  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+  match visibility with
+    | Until _ -> 
+	the_globrevtab := Globrevtab.add xref sp !the_globrevtab
+    | _ -> ()
+
+let push_cci visibility sp ref =
+  push_xref visibility sp (TrueGlobal ref)
+
+(* This is for Syntactic Definitions *)
+let push_syntactic_definition visibility sp kn =
+  push_xref visibility sp (SyntacticDef kn)
+
+let push = push_cci
+
+let push_modtype vis sp kn = 
+  the_modtypetab := SpTab.push vis sp kn !the_modtypetab;
+  the_modtyperevtab := KNmap.add kn sp !the_modtyperevtab
+
+(* This is for tactic definition names *)
+
+let push_tactic vis sp kn = 
+  the_tactictab := SpTab.push vis sp kn !the_tactictab;
+  the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab
+
+
+(* This is for dischargeable non-cci objects (removed at the end of the
+   section -- i.e. Hints, Grammar ...) *) (* --> Unused *)
+
+let push_object visibility sp =
+  the_objtab := SpTab.push visibility sp () !the_objtab
+
+(* This is to remember absolute Section/Module names and to avoid redundancy *)
+let push_dir vis dir dir_ref = 
+  the_dirtab := DirTab.push vis dir dir_ref !the_dirtab;
+  match dir_ref with
+      DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab
+    | _ -> ()
+
+
+(* Locate functions *******************************************************)
+
+
+(* This should be used when syntactic definitions are allowed *)
+let extended_locate qid = SpTab.locate qid !the_ccitab
+
+(* This should be used when no syntactic definitions is expected *)
+let locate qid = match extended_locate qid with
+  | TrueGlobal ref -> ref
+  | SyntacticDef _ -> raise Not_found
+let full_name_cci qid = SpTab.user_name qid !the_ccitab
+
+let locate_syntactic_definition qid = match extended_locate qid with
+  | TrueGlobal _ -> raise Not_found
+  | SyntacticDef kn -> kn
+
+let locate_modtype qid = SpTab.locate qid !the_modtypetab
+let full_name_modtype qid = SpTab.user_name qid !the_modtypetab
+
+let locate_obj qid = SpTab.user_name qid !the_objtab
+
+type ltac_constant = kernel_name
+let locate_tactic qid = SpTab.locate qid !the_tactictab
+let full_name_tactic qid = SpTab.user_name qid !the_tactictab
+
+let locate_dir qid = DirTab.locate qid !the_dirtab
+
+let locate_module qid = 
+  match locate_dir qid with
+    | DirModule (_,(mp,_)) -> mp
+    | _ -> raise Not_found
+
+let full_name_module qid = 
+  match locate_dir qid with
+    | DirModule (dir,_) -> dir
+    | _ -> raise Not_found
+
+let locate_section qid =
+  match locate_dir qid with
+    | DirOpenSection (dir, _) 
+    | DirClosedSection dir -> dir
+    | _ -> raise Not_found
+
+let locate_all qid = 
+  List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l)
+    (SpTab.find_prefixes qid !the_ccitab) []
+
+let extended_locate_all qid = SpTab.find_prefixes qid !the_ccitab
+
+(* Derived functions *)
+
+let locate_constant qid =
+  match extended_locate qid with
+    | TrueGlobal (ConstRef kn) -> kn
+    | _ -> raise Not_found
+
+let locate_mind qid = 
+  match extended_locate qid with
+    | TrueGlobal (IndRef (kn,0)) -> kn
+    | _ -> raise Not_found
+
+
+let absolute_reference sp =
+  match SpTab.find sp !the_ccitab with
+    | TrueGlobal ref -> ref
+    | _ -> raise Not_found
+
+let locate_in_absolute_module dir id =
+  absolute_reference (make_path dir id)
+
+let global r =
+  let (loc,qid) = qualid_of_reference r in
+  try match extended_locate qid with
+    | TrueGlobal ref -> ref
+    | SyntacticDef _ -> 
+        user_err_loc (loc,"global",
+          str "Unexpected reference to a syntactic definition: " ++
+          pr_qualid qid)
+  with Not_found ->
+    error_global_not_found_loc loc qid
+
+(* Exists functions ********************************************************)
+
+let exists_cci sp = SpTab.exists sp !the_ccitab
+      
+let exists_dir dir = DirTab.exists dir !the_dirtab
+
+let exists_section = exists_dir
+
+let exists_module = exists_dir
+
+let exists_modtype sp = SpTab.exists sp !the_modtypetab
+
+let exists_tactic sp = SpTab.exists sp !the_tactictab
+
+(* Reverse locate functions ***********************************************)
+
+let sp_of_global ref = 
+  match ref with
+    | VarRef id -> make_path empty_dirpath id
+    | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab
+
+
+let id_of_global ref = 
+  let (_,id) = repr_path (sp_of_global ref) in 
+  id
+
+let sp_of_syntactic_definition kn = 
+  Globrevtab.find (SyntacticDef kn) !the_globrevtab
+
+let dir_of_mp mp =
+  MPmap.find mp !the_modrevtab
+
+
+(* Shortest qualid functions **********************************************)
+
+let shortest_qualid_of_global ctx ref = 
+  match ref with
+    | VarRef id -> make_qualid empty_dirpath id
+    | _ ->
+        let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in
+        SpTab.shortest_qualid ctx sp !the_ccitab
+
+let shortest_qualid_of_syndef kn = 
+  let sp = sp_of_syntactic_definition kn in
+    SpTab.shortest_qualid Idset.empty sp !the_ccitab
+
+let shortest_qualid_of_module mp = 
+  let dir = MPmap.find mp !the_modrevtab in
+    DirTab.shortest_qualid Idset.empty dir !the_dirtab
+
+let shortest_qualid_of_modtype kn =
+  let sp = KNmap.find kn !the_modtyperevtab in
+    SpTab.shortest_qualid Idset.empty sp !the_modtypetab
+
+let shortest_qualid_of_tactic kn =
+  let sp = KNmap.find kn !the_tacticrevtab in
+    SpTab.shortest_qualid Idset.empty sp !the_tactictab
+
+let pr_global_env env ref =
+  (* Il est important de laisser le let-in, car les streams s'évaluent
+  paresseusement : il faut forcer l'évaluation pour capturer
+  l'éventuelle levée d'une exception (le cas échoit dans le debugger) *)
+  let s = string_of_qualid (shortest_qualid_of_global env ref) in
+  (str s)
+
+let global_inductive r =
+  match global r with
+  | IndRef ind -> ind
+  | ref ->
+      user_err_loc (loc_of_reference r,"global_inductive",
+        pr_reference r ++ spc () ++ str "is not an inductive type")
+
+(********************************************************************)
+
+(********************************************************************)
+(* Registration of tables as a global table and rollback            *)
+
+type frozen = ccitab * dirtab * objtab * kntab * kntab
+    * globrevtab * mprevtab * knrevtab * knrevtab
+
+let init () = 
+  the_ccitab := SpTab.empty; 
+  the_dirtab := DirTab.empty;
+  the_objtab := SpTab.empty;
+  the_modtypetab := SpTab.empty;
+  the_tactictab := SpTab.empty;
+  the_globrevtab := Globrevtab.empty;
+  the_modrevtab := MPmap.empty;
+  the_modtyperevtab := KNmap.empty;
+  the_tacticrevtab := KNmap.empty
+
+
+let freeze () =
+  !the_ccitab, 
+  !the_dirtab,
+  !the_objtab,
+  !the_modtypetab,
+  !the_tactictab,
+  !the_globrevtab,
+  !the_modrevtab,
+  !the_modtyperevtab,
+  !the_tacticrevtab
+
+let unfreeze (ccit,dirt,objt,mtyt,tact,globr,modr,mtyr,tacr) =
+  the_ccitab := ccit;
+  the_dirtab := dirt;
+  the_objtab := objt;
+  the_modtypetab := mtyt;
+  the_tactictab := tact;
+  the_globrevtab := globr;
+  the_modrevtab := modr;
+  the_modtyperevtab := mtyr;
+  the_tacticrevtab := tacr
+
+let _ = 
+  Summary.declare_summary "names"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
diff --git a/library/nametab.mli b/library/nametab.mli
new file mode 100755
index 00000000..3a0bd670
--- /dev/null
+++ b/library/nametab.mli
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: nametab.mli,v 1.43.2.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Pp
+open Names
+open Libnames
+(*i*)
+
+(*s This module contains the tables for globalization, which
+  associates internal object references to qualified names (qualid). *)
+
+(* Most functions in this module fall into one of the following categories:
+   \begin{itemize}
+   \item [push : visibility -> full_user_name -> object_reference -> unit]
+   
+   Registers the [object_reference] to be referred to by the
+   [full_user_name] (and its suffixes according to [visibility]).
+   [full_user_name] can either be a [section_path] or a [dir_path].
+
+   \item [exists : full_user_name -> bool] 
+   
+   Is the [full_user_name] already atributed as an absolute user name
+   of some object? 
+
+   \item [locate : qualid -> object_reference]
+
+   Finds the object referred to by [qualid] or raises Not_found 
+   
+   \item [name_of] : object_reference -> user_name
+
+   The [user_name] can be for example the shortest non ambiguous [qualid] or 
+   the [full_user_name] or [identifier]. Such a function can also have a 
+   local context argument. 
+*)
+   
+  
+exception GlobalizationError of qualid
+exception GlobalizationConstantError of qualid
+
+(* Raises a globalization error *)
+val error_global_not_found_loc : loc -> qualid -> 'a
+val error_global_not_found     : qualid -> 'a
+val error_global_constant_not_found_loc : loc -> qualid -> 'a
+
+
+
+
+(*s Register visibility of things *)
+
+(* The visibility can be registered either
+   \begin{itemize}
+
+   \item for all suffixes not shorter then a given int -- when the
+   object is loaded inside a module -- or
+
+   \item for a precise suffix, when the module containing (the module
+   containing ...) the object is opened (imported) 
+   \end{itemize}
+*)
+
+type visibility = Until of int | Exactly of int
+
+val push : visibility -> section_path -> global_reference -> unit
+val push_syntactic_definition : 
+  visibility -> section_path -> kernel_name -> unit
+val push_modtype : visibility -> section_path -> kernel_name -> unit
+val push_dir : visibility -> dir_path -> global_dir_reference -> unit
+val push_object : visibility -> section_path -> unit
+val push_tactic : visibility -> section_path -> kernel_name -> unit
+
+
+(*s The following functions perform globalization of qualified names *)
+
+(* This returns the section path of a constant or fails with [Not_found] *)
+val locate : qualid -> global_reference
+
+(* This function is used to transform a qualified identifier into a
+   global reference, with a nice error message in case of failure *)
+val global : reference -> global_reference
+
+(* The same for inductive types *)
+val global_inductive : reference -> inductive
+
+(* This locates also syntactic definitions *)
+val extended_locate : qualid -> extended_global_reference
+
+(* This locates all names with a given suffix, if qualid is valid as
+   such, it comes first in the list *)
+val extended_locate_all : qualid -> extended_global_reference list
+
+(* This locates all global references with a given suffixe *)
+val locate_all : qualid -> global_reference list
+
+val locate_obj : qualid -> section_path
+
+val locate_constant : qualid -> constant
+val locate_mind : qualid -> mutual_inductive
+val locate_section : qualid -> dir_path
+val locate_modtype : qualid -> kernel_name
+val locate_syntactic_definition : qualid -> kernel_name
+
+type ltac_constant = kernel_name
+val locate_tactic : qualid -> ltac_constant
+val locate_dir : qualid -> global_dir_reference
+val locate_module : qualid -> module_path
+
+(* A variant looking up a [section_path] *)
+val absolute_reference : section_path -> global_reference
+
+
+(*s These function tell if the given absolute name is already taken *)
+
+val exists_cci : section_path -> bool
+val exists_modtype : section_path -> bool
+
+(* Those three functions are the same *)
+val exists_dir : dir_path -> bool
+val exists_section : dir_path -> bool (* deprecated *)
+val exists_module : dir_path -> bool (* deprecated *)
+
+
+(*s These functions turn qualids into full user names: [section_path]s
+  or [dir_path]s *)
+
+val full_name_modtype : qualid -> section_path
+val full_name_cci : qualid -> section_path
+
+(* As above but checks that the path found is indeed a module *)
+val full_name_module : qualid -> dir_path
+
+
+(*s Reverse lookup -- finding user names corresponding to the given
+  internal name *)
+
+val sp_of_syntactic_definition : kernel_name -> section_path
+val shortest_qualid_of_global : Idset.t -> global_reference -> qualid
+val shortest_qualid_of_syndef : kernel_name -> qualid
+val shortest_qualid_of_tactic : ltac_constant -> qualid
+
+val dir_of_mp : module_path -> dir_path
+
+val sp_of_global : global_reference -> section_path
+val id_of_global : global_reference -> identifier
+
+(* Printing of global references using names as short as possible *)
+val pr_global_env : Idset.t -> global_reference -> std_ppcmds
+
+
+(* The [shortest_qualid] functions given an object with user_name
+   Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and
+   Coq.A.B.x that denotes the same object. *)
+
+val shortest_qualid_of_module : module_path -> qualid
+val shortest_qualid_of_modtype : kernel_name -> qualid
+
+
+(*
+type frozen
+
+val freeze : unit -> frozen
+val unfreeze : frozen -> unit
+*)
diff --git a/library/states.ml b/library/states.ml
new file mode 100644
index 00000000..7a7f1e06
--- /dev/null
+++ b/library/states.ml
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: states.ml,v 1.8.14.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open System
+
+type state = Lib.frozen * Summary.frozen
+
+let get_state () =
+  (Lib.freeze(), Summary.freeze_summaries())
+
+let set_state (fl,fs) =
+  Lib.unfreeze fl;
+  Summary.unfreeze_summaries fs
+
+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))
+
+(* Rollback. *)
+
+let freeze = get_state
+let unfreeze = set_state
+
+let with_heavy_rollback f x =
+  let st = get_state () in
+  try 
+    f x
+  with reraise ->
+    (set_state st; raise reraise)
diff --git a/library/states.mli b/library/states.mli
new file mode 100644
index 00000000..70018180
--- /dev/null
+++ b/library/states.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: states.mli,v 1.6.16.1 2004/07/16 19:30:36 herbelin Exp $ 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
+  freezing the states of both [Lib] and [Summary]. We provide functions 
+  to write and restore state to and from a given file. *)
+
+val intern_state : string -> unit
+val extern_state : string -> unit
+
+type state
+val freeze : unit -> state
+val unfreeze : state -> unit
+
+(*s Rollback. [with_heavy_rollback f x] applies [f] to [x] and restores the
+  state of the whole system as it was before the evaluation if an exception 
+  is raised. *)
+
+val with_heavy_rollback : ('a -> 'b) -> 'a -> 'b
+
+
diff --git a/library/summary.ml b/library/summary.ml
new file mode 100644
index 00000000..fc88350a
--- /dev/null
+++ b/library/summary.ml
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: summary.ml,v 1.7.2.1 2004/07/16 19:30:36 herbelin Exp $ *)
+
+open Pp
+open Util
+
+type 'a summary_declaration = {
+  freeze_function : unit -> 'a;
+  unfreeze_function : 'a -> unit;
+  init_function : unit -> unit;
+  survive_module : bool ;
+  survive_section : bool }
+
+let summaries = 
+  (Hashtbl.create 17 : (string, Dyn.t summary_declaration) Hashtbl.t)
+
+let internal_declare_summary sumname sdecl =
+  let (infun,outfun) = Dyn.create sumname in
+  let dyn_freeze () = infun (sdecl.freeze_function())
+  and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum)
+  and dyn_init = sdecl.init_function in
+  let ddecl = {
+    freeze_function = dyn_freeze;
+    unfreeze_function = dyn_unfreeze;
+    init_function = dyn_init;
+    survive_module = sdecl.survive_module;
+    survive_section = sdecl.survive_section } 
+  in
+  if Hashtbl.mem summaries sumname then
+    anomalylabstrm "Summary.declare_summary"
+      (str "Cannot declare a summary twice: " ++ str sumname);
+  Hashtbl.add summaries sumname ddecl
+
+let declare_summary sumname decl = 
+  internal_declare_summary (sumname^"-SUMMARY") decl
+
+type frozen = Dyn.t Stringmap.t
+
+let freeze_summaries () =
+  let m = ref Stringmap.empty in
+  Hashtbl.iter 
+    (fun id decl -> m := Stringmap.add id (decl.freeze_function()) !m)
+    summaries;
+  !m
+
+
+let unfreeze_some_summaries p fs = 
+  Hashtbl.iter
+    (fun id decl -> 
+       try 
+	 if p decl then
+	   decl.unfreeze_function (Stringmap.find id fs)
+       with Not_found -> decl.init_function())
+    summaries
+
+let unfreeze_summaries = 
+  unfreeze_some_summaries (fun _ -> true)
+
+let section_unfreeze_summaries =
+  unfreeze_some_summaries (fun decl -> not decl.survive_section)
+
+let module_unfreeze_summaries =
+  unfreeze_some_summaries (fun decl -> not decl.survive_module)
+
+let init_summaries () =
+  Hashtbl.iter (fun _ decl -> decl.init_function()) summaries
diff --git a/library/summary.mli b/library/summary.mli
new file mode 100644
index 00000000..7e691f0b
--- /dev/null
+++ b/library/summary.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: summary.mli,v 1.8.2.1 2004/07/16 19:30:36 herbelin Exp $ i*)
+
+(* This module registers the declaration of global tables, which will be kept
+   in synchronization during the various backtracks of the system. *)
+
+type 'a summary_declaration = {
+  freeze_function : unit -> 'a;
+  unfreeze_function : 'a -> unit;
+  init_function : unit -> unit;
+  survive_module : bool;    (* should be false is most cases *)
+  survive_section : bool }
+
+val declare_summary : string -> 'a summary_declaration -> unit
+
+type frozen
+
+val freeze_summaries : unit -> frozen
+val unfreeze_summaries : frozen -> unit
+val section_unfreeze_summaries : frozen -> unit
+val module_unfreeze_summaries : frozen -> unit
+val init_summaries : unit -> unit
+
+
+
diff --git a/man/coq-interface.1 b/man/coq-interface.1
new file mode 100644
index 00000000..2ab2bf95
--- /dev/null
+++ b/man/coq-interface.1
@@ -0,0 +1,37 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coq-interface \-
+
+
+.SH SYNOPSIS
+.B coq-interface
+[
+.B options
+]
+
+.SH DESCRIPTION
+
+.B coq-interface
+is a Coq customized toplevel system for Coq containing some modules
+useful for the graphical interface. This program is not for the casual
+user.
+
+.SH OPTIONS
+
+.TP
+.B \-h
+Help. Will give you the complete list of options accepted by
+coq-interface (the same as coqtop).
+
+.SH SEE ALSO
+
+.BR coqc (1),
+.BR coqdep (1),
+.BR coqtop (1),
+.BR parser (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/man/coq-tex.1 b/man/coq-tex.1
new file mode 100644
index 00000000..737de70a
--- /dev/null
+++ b/man/coq-tex.1
@@ -0,0 +1,125 @@
+.TH COQ-TEX 1 "29 March 1995"
+
+.SH NAME
+coq-tex \- Process Coq phrases embedded in LaTeX files
+
+.SH SYNOPSIS
+.B coq-tex
+[
+.BI \-o \ output-file
+]
+[
+.BI \-n \ line-width
+]
+[
+.BI \-image \ coq-image
+]
+[
+.B -w
+]
+[
+.B -v
+]
+[
+.B -sl
+]
+[
+.B -hrule
+]
+[
+.B -small
+]
+.I input-file ...
+
+
+.SH DESCRIPTION
+
+The
+.B coq-tex
+filter extracts Coq phrases embedded in LaTeX files, evaluates
+them, and insert the outcome of the evaluation after each phrase.
+
+Three LaTeX environments are provided to include Coq code in
+the input files:
+.TP
+.B coq_example
+The phrases between \\begin{coq_example} and \\end{coq_example} are
+evaluated and copied into the output file. Each phrase is followed by
+the response of the toplevel loop.
+.TP
+.B coq_example*
+The phrases between \\begin{coq_example*} and \\end{coq_example*} are
+evaluated and copied into the output file. The responses of the
+toplevel loop are discarded.
+.TP
+.B coq_eval
+The phrases between \\begin{coq_eval} and \\end{coq_eval} are
+silently evaluated. They are not copied into the output file, and the
+responses of the toplevel loop are discarded.
+.PP
+The resulting LaTeX code is stored in the file
+.IR file \&.v.tex
+if the input file has a name of the form
+.IR file \&.tex,
+otherwise the name of the output file is the name of the input file
+with `.v.tex' appended.
+
+The files produced by
+.B coq-tex
+can be directly processed by LaTeX. 
+Both the Coq phrases and the toplevel output are typeset in
+typewriter font.
+
+.SH OPTIONS
+
+.TP
+.BI \-o \ output-file
+Specify the name of a file where the LaTeX output is to be stored. A
+dash `-' causes the LaTeX output to be printed on standard output.
+.TP
+.BI \-n \ line-width
+Set the line width. The default is 72 characters. The responses of the
+toplevel loop are folded if they are longer than the line width. No
+folding is performed on the Coq input text.
+.TP
+.BI \-image \ coq-image
+Cause the file
+.IR coq-image
+to be executed to evaluate the Coq phrases. By default,
+this is the command 
+.IR coqtop
+without specifying any path which is used to evaluate the Coq phrases.
+.TP
+.B -w
+Cause lines to be folded on a space character whenever possible,
+avoiding word cuts in the output. By default, folding occurs at
+the line width, regardless of word cuts.
+.TP
+.B -v
+Verbose mode. Prints the Coq answers on the standard output.
+Useful to detect errors in Coq phrases.
+.TP
+.B -sl
+Slanted mode. The Coq answers are written in a slanted font.
+.TP
+.B -hrule
+Horizontal lines mode. The Coq parts are written between two
+horizontal lines.
+.TP
+.B -small
+Small font mode. The Coq parts are written in a smaller font.
+
+
+.SH CAVEATS
+The \\begin... and \\end... phrases must sit on a line by themselves,
+with no characters before the backslash or after the closing brace.
+Each Coq phrase must be terminated by `.' at the end of a line.
+Blank space is accepted between `.' and the newline, but any other
+character will cause coq-tex to ignore the end of the phrase,
+resulting in an incorrect shuffling of the responses into the phrases.
+(The responses ``lag behind''.)
+
+.SH SEE ALSO
+
+.B coqtop
+(1).
diff --git a/man/coq_makefile.1 b/man/coq_makefile.1
new file mode 100644
index 00000000..b5de6d36
--- /dev/null
+++ b/man/coq_makefile.1
@@ -0,0 +1,33 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coq_makefile \- The Coq Proof Assistant makefile generator
+
+
+.SH SYNOPSIS
+.B coq_makefile
+[
+.B arguments
+]
+
+.SH DESCRIPTION
+
+.B coq_makefile
+is a makefile generator for Coq proof developments.
+
+.SH OPTIONS
+
+.TP
+.BI \-h
+Will give you a description of the whole list of options of coq_makefile.
+
+.SH SEE ALSO
+
+.BR coqtop (1),
+.BR coqtc (1),
+.BR coqdep (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/man/coqc.1 b/man/coqc.1
new file mode 100644
index 00000000..741b3dcb
--- /dev/null
+++ b/man/coqc.1
@@ -0,0 +1,49 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coqc \- The Coq Proof Assistant compiler
+
+
+.SH SYNOPSIS
+.B coqc
+[
+.B general \ Coq \ options
+]
+.I file
+
+
+.SH DESCRIPTION
+
+.B coqc
+is the batch compiler for the Coq Proof Assistant.
+The options are basically the same as coqtop(1).
+.IR file.v \&
+is the vernacular file to compile.
+.IR file \& 
+must be formed
+only with the characters `a` to  `Z`, `0`-`9` or `_` and must begin
+with a letter.
+The compiler produces an object file
+.IR file.vo \&.
+
+For interactive use of Coq, see 
+.BR coqtop(1).
+
+
+.SH OPTIONS
+
+.TP
+.BI \-h
+Will give you a description of the whole list of options of coqc and
+coqtop.
+
+.SH SEE ALSO
+
+.BR coqtop (1),
+.BR coq_makefile (1),
+.BR coqdep (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/man/coqdep.1 b/man/coqdep.1
new file mode 100644
index 00000000..01d080fc
--- /dev/null
+++ b/man/coqdep.1
@@ -0,0 +1,182 @@
+.TH COQ 1 "28 March 1995" "Coq tools"
+
+.SH NAME
+coqdep \- Compute inter-module dependencies for Coq and Caml programs
+
+.SH SYNOPSIS
+.B coqdep
+[
+.BI \-w
+]
+[
+.BI \-I \ directory
+]
+[
+.BI \-coqlib \ directory
+]
+[
+.BI \-c
+]
+[
+.BI \-i
+]
+[
+.BI \-D
+]
+.I filename ...
+.I directory ...
+
+.SH DESCRIPTION
+
+.B coqdep
+compute inter-module dependencies for Coq and Caml programs,
+and prints the dependencies on the standard output in a format
+readable by make.
+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. Dependencies relative to modules from the Coq library are not
+printed.
+
+Dependencies of Caml modules are computed by looking at
+.IR open \&
+directives and the dot notation
+.IR module.value \&.
+
+.SH OPTIONS
+
+.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).
+.TP
+.BI \-w
+Prints a warning if a Coq command
+.IR Declare \& 
+.IR ML \& 
+.IR Module \&
+is incorrect. (For instance, you wrote `Declare ML Module "A".',
+but the module A contains #open "B"). The correct command is printed
+(see option -D). The warning is printed on standard error.
+.TP
+.BI \-i
+Prints also the dependencies for .vi files (Coq specification modules).
+.TP
+.BI \-D
+This commands looks for every command
+.IR Declare \& 
+.IR ML \& 
+.IR Module \&
+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 \-I \ directory
+The files .v .ml .mli of the directory
+.IR directory \&
+are taken into account during the calculus of dependencies,
+but their own dependencies are not printed.
+.TP 
+.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.
+
+
+.SH SEE ALSO
+
+.BR ocamlc (1),
+.BR coqc (1),
+.BR make (1).
+.br
+
+.SH NOTES
+
+Lexers (for Coq and Caml) correctly handle nested comments
+and strings.
+
+The treatment of symbolic links is primitive.
+
+If two files have the same name, in two different directories,
+a warning is printed on standard error.
+
+There is no way to limit the scope of the recursive search for
+directories.
+
+.SH EXAMPLES
+
+.LP
+Consider the files (in the same directory):
+
+	A.ml B.ml C.ml D.ml X.v Y.v and Z.v
+
+where
+.TP
+.BI \+ 
+D.ml contains the commands `#open "A"', `#open "B"' and `type t = C__t' ;
+.TP
+.BI \+
+Y.v contains the command `Require X' ;
+.TP
+.BI \+
+Z.v contains the commands `Require X' and `Declare ML Module "D"'.
+.LP
+To get the dependencies of the Coq files:
+.IP
+.B
+example% coqdep -I . *.v
+.RS
+.sp .5
+.nf
+.B Z.vo: Z.v ./X.vo ./D.zo
+.B Y.vo: Y.v ./X.vo
+.B X.vo: X.v
+.fi
+.RE
+.br
+.ne 7
+.LP
+With a warning:
+.IP
+.B
+example% coqdep -w -I . *.v
+.RS
+.sp .5
+.nf
+.B Z.vo: Z.v ./X.vo ./D.zo
+.B Y.vo: Y.v ./X.vo
+.B X.vo: X.v
+### Warning : In file Z.v, the ML modules declaration should be
+### Declare ML Module "A" "B" "C" "D".
+.fi
+.RE
+.br
+.ne 7
+.LP
+To get only the Caml dependencies:
+.IP
+.B
+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
+.fi
+.RE
+.br
+.ne 7
+
+.SH BUGS
+
+Please report any bug to
+.B coq-bugs@pauillac.inria.fr
diff --git a/man/coqdoc.1 b/man/coqdoc.1
new file mode 100644
index 00000000..c325d221
--- /dev/null
+++ b/man/coqdoc.1
@@ -0,0 +1,33 @@
+.TH coqdoc 1 "February, 2002"
+
+.SH NAME
+coqdoc \- A documentation tool for the Coq proof assistant
+
+
+.SH SYNOPSIS
+.B coqdoc
+[
+.B options
+]
+.B files
+
+
+.SH DESCRIPTION
+
+.B coqdoc
+is a documentation tool for the Coq proof assistant.
+It creates LaTeX or HTML documents from a set of Coq files.
+See the Coq reference manual for documentation (url below).
+
+
+.SH OPTIONS
+
+.TP
+.B \-h
+Help. Will give you the complete list of options accepted by coqdoc.
+
+
+.SH SEE ALSO
+
+.I
+The Coq web site: http://coq.inria.fr/
diff --git a/man/coqmktop.1 b/man/coqmktop.1
new file mode 100644
index 00000000..05e73d75
--- /dev/null
+++ b/man/coqmktop.1
@@ -0,0 +1,41 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coqmktop \- The Coq Proof Assistant user-tactics linker
+
+
+.SH SYNOPSIS
+.B coqmktop
+[
+.I options
+]
+.I files
+
+
+.SH DESCRIPTION
+
+.B coqmktop
+builds a new Coq toplevel extended with user-tactics.
+.IR files \&
+are the Objective Caml object or library files (i.e. with suffix .cmo,
+.cmx, .cma or .cmxa) to link with the Coq system.
+The linker produces an executable Coq toplevel which can be called
+directly or through coqc(1), using the -image option.
+
+.SH OPTIONS
+
+.TP
+.BI \-h
+Help. List the available options.
+
+.SH SEE ALSO
+
+.BR coqtop (1),
+.BR ocamlmktop (1).
+.BR ocamlc (1).
+.BR ocamlopt (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/man/coqtop.1 b/man/coqtop.1
new file mode 100644
index 00000000..d75b283f
--- /dev/null
+++ b/man/coqtop.1
@@ -0,0 +1,39 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coqtop \- The Coq Proof Assistant toplevel system
+
+
+.SH SYNOPSIS
+.B coqtop
+[
+.B options
+]
+
+.SH DESCRIPTION
+
+.B coqtop
+is the toplevel system of Coq, for interactive use.
+It reads phrases on the standard input, and prints results on the
+standard output.
+
+For batch-oriented use of Coq, see 
+.BR coqc(1).
+
+
+.SH OPTIONS
+
+.TP
+.B \-h
+Help. Will give you the complete list of options accepted by coqtop.
+
+.SH SEE ALSO
+
+.BR coqc (1),
+.BR coq-tex (1),
+.BR coqdep (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/man/coqtop.byte.1 b/man/coqtop.byte.1
new file mode 100644
index 00000000..ad1a358c
--- /dev/null
+++ b/man/coqtop.byte.1
@@ -0,0 +1,35 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coqtop.byte \- The bytecode Coq toplevel
+
+
+.SH SYNOPSIS
+.B coqtop.byte
+[
+.B options
+]
+[
+.I file
+]
+
+.SH DESCRIPTION
+
+.B coqopt.byte
+is the bytecode version of Coq. It should not be called directly, but
+only by
+.B coqtop
+and
+.B coqc
+
+.SH SEE ALSO
+
+.BR coqtop (1),
+.BR coqc (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
+
+
diff --git a/man/coqtop.opt.1 b/man/coqtop.opt.1
new file mode 100644
index 00000000..17c763da
--- /dev/null
+++ b/man/coqtop.opt.1
@@ -0,0 +1,35 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+coqtop.opt \- The native-code Coq toplevel
+
+
+.SH SYNOPSIS
+.B coqopt.opt
+[
+.B options
+]
+[
+.I file
+]
+
+.SH DESCRIPTION
+
+.B coqopt.opt
+is the native-code version of Coq. It should not be called directly, but
+only by
+.B coqtop
+and
+.B coqc
+
+.SH SEE ALSO
+
+.BR coqtop (1),
+.BR coqc (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
+
+
diff --git a/man/coqwc.1 b/man/coqwc.1
new file mode 100644
index 00000000..7011d148
--- /dev/null
+++ b/man/coqwc.1
@@ -0,0 +1,47 @@
+.TH COQ 1 "16 March 2004" "Coq tools"
+
+.SH NAME
+coqwc \- print the number of specification, proof and comment lines in
+Coq files
+
+.SH SYNOPSIS
+.B coqwc
+[
+.BI \-p
+]
+[
+.BI \-s
+]
+[
+.BI \-r
+]
+[
+.BI \-e
+]
+.I files ...
+
+.SH DESCRIPTION
+
+.B coqwc
+computes the number of specification lines, proof lines and comment
+lines in Coq files.
+
+.SH OPTIONS
+
+.TP
+.BI \-p
+Print the percentage of comments
+.TP
+.BI \-s
+Print only the number of specification lines
+.TP
+.BI \-r
+Print only the number of proof lines
+.TP
+.BI \-e
+Do not skip headers
+
+.SH BUGS
+
+Please report any bug to
+.B coq-bugs@pauillac.inria.fr
diff --git a/man/gallina.1 b/man/gallina.1
new file mode 100644
index 00000000..8c607216
--- /dev/null
+++ b/man/gallina.1
@@ -0,0 +1,74 @@
+.TH COQ 1 "29 March 1995" "Coq tools"
+
+.SH NAME
+gallina \- extracts specification from Coq vernacular files
+
+.SH SYNOPSIS
+.B gallina
+[
+.BI \-
+]
+[
+.BI \-stdout
+]
+[
+.BI \-nocomments
+]
+.I file ...
+
+.SH DESCRIPTION
+
+.B gallina 
+takes Coq files as arguments and builds the corresponding
+specification files.
+The Coq file
+.IR foo.v \&
+gives bearth to the specification file
+.IR foo.g. \&
+The suffix '.g' stands for Gallina.
+
+For that purpose, gallina removes all commands that follow a
+"Theorem", "Lemma", "Fact", "Remark" or "Goal" statement until it
+reaches a command "Abort.", "Save.", "Qed.", "Defined." or "Proof
+<...>.". It also removes every "Hint", "Syntax",
+"Immediate"  or "Transparent" command.
+
+Files without the .v suffix are ignored.
+
+
+.SH OPTIONS
+
+.TP
+.BI \-stdout
+Prints the result on standard output.
+.TP
+.BI \-
+Coq source is taken on standard input. The result is printed on
+standard output.
+.TP
+.BI \-nocomments
+Comments are removed in the *.g file.
+
+.SH NOTES
+
+Nested comments are correctly handled. In particular, every command
+"Save." or "Abort." in a comment is not taken into account.
+
+
+.SH BUGS
+
+Please report any bug to
+.B coq@pauillac.inria.fr
+
+
+
+
+
+
+	
+
+	
+
+	
+
+	
diff --git a/man/parser.1 b/man/parser.1
new file mode 100644
index 00000000..d89465d8
--- /dev/null
+++ b/man/parser.1
@@ -0,0 +1,30 @@
+.TH COQ 1 "April 25, 2001"
+
+.SH NAME
+parser \- Coq parser
+
+
+.SH SYNOPSIS
+.B parser
+[
+.B options
+]
+
+.SH DESCRIPTION
+
+.B parser
+is a program reading Coq proof developments and outputing them in the
+structured format given in the INRIA technical report RT154. This
+program is not for the casual user.
+
+.SH SEE ALSO
+
+.BR coq-interface (1),
+.BR coqc (1),
+.BR coqtop (1),
+.BR coqdep (1).
+.br
+.I
+The Coq Reference Manual.
+.I
+The Coq web site: http://coq.inria.fr
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
new file mode 100644
index 00000000..5fa781ad
--- /dev/null
+++ b/parsing/argextend.ml4
@@ -0,0 +1,289 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: argextend.ml4,v 1.9.2.2 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Ast
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+let rec make_rawwit loc = function
+  | BoolArgType -> <:expr< Genarg.rawwit_bool >>
+  | IntArgType -> <:expr< Genarg.rawwit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.rawwit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.rawwit_string >>
+  | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.rawwit_ident >>
+  | HypArgType -> <: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 >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.rawwit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.rawwit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >>
+
+let rec make_globwit loc = function
+  | BoolArgType -> <:expr< Genarg.globwit_bool >>
+  | IntArgType -> <:expr< Genarg.globwit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.globwit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.globwit_string >>
+  | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.globwit_ident >>
+  | HypArgType -> <: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 >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.globwit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.globwit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >>
+
+let rec make_wit loc = function
+  | BoolArgType -> <:expr< Genarg.wit_bool >>
+  | IntArgType -> <:expr< Genarg.wit_int >>
+  | IntOrVarArgType -> <:expr< Genarg.wit_int_or_var >>
+  | StringArgType -> <:expr< Genarg.wit_string >>
+  | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >>
+  | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >>
+  | IdentArgType -> <:expr< Genarg.wit_ident >>
+  | HypArgType -> <: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 >>
+  | CastedOpenConstrArgType -> <:expr< Genarg.wit_casted_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Genarg.wit_bindings >>
+  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
+  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
+  | PairArgType (t1,t2) -> 
+      <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
+  | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >>
+
+let make_act loc act pil =
+  let rec make = function
+    | [] -> <:expr< Gramext.action (fun loc -> ($act$ : 'a)) >>
+    | None :: tl -> <:expr< Gramext.action (fun _ -> $make tl$) >>
+    | Some (p, t) :: tl ->
+	<:expr<
+          Gramext.action 
+            (fun $lid:p$ -> let _ = in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
+        >> in
+  make (List.rev pil)
+
+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 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 se = mlexpr_of_string s in
+  let wit = <:expr< $lid:"wit_"^s$ >> in
+  let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
+  let globwit = <:expr< $lid:"globwit_"^s$ >> in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  <:str_item<
+    declare
+      value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
+        Genarg.create_arg $se$;
+      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)))))),
+        (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)))))),
+        (fun subst x ->
+          (in_gen $globwit$
+             (out_gen $make_globwit loc typ$
+          	($substitute$ subst
+         	  (in_gen $make_globwit loc rawtyp$
+	             (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 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<
+    declare
+      value $lid:"rawwit_"^s$ = let (_,_,x) = Genarg.create_arg $se$ in x;
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
+      Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None 
+        [(None, None, $rules$)];
+    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
+  GLOBAL: str_item;
+  str_item:
+    [ [ "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 =
+        (* Necessary if the globalized type is different from the final type *)
+          OPT [ "RAW_TYPED"; "AS"; t = argtype; 
+                "RAW_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 true 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 ] ]
+  ;
+  argtype:
+    [ [ e = LIDENT -> fst (interp_entry_name loc e) 
+      | e1 = LIDENT; "*"; e2 = LIDENT ->
+          let e1 = fst (interp_entry_name loc e1) in
+          let e2 = fst (interp_entry_name loc e2) in
+          PairArgType (e1, e2) ] ]
+  ;
+  argrule:
+    [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ]
+  ;
+  genarg:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e 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)
+    ] ]
+  ;
+  END
+
diff --git a/parsing/ast.ml b/parsing/ast.ml
new file mode 100755
index 00000000..b2a30f9c
--- /dev/null
+++ b/parsing/ast.ml
@@ -0,0 +1,600 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..7bc0b607
--- /dev/null
+++ b/parsing/ast.mli
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..0f447766
--- /dev/null
+++ b/parsing/coqast.ml
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..546725c0
--- /dev/null
+++ b/parsing/coqast.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: coqast.mli,v 1.10.6.1 2004/07/16 19:30:37 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
+
+(*
+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
+*)
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
new file mode 100644
index 00000000..9886bbf1
--- /dev/null
+++ b/parsing/egrammar.ml
@@ -0,0 +1,479 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: egrammar.ml,v 1.48.2.1 2004/07/16 19:30:37 herbelin Exp $ *)
+
+open Pp
+open Util
+open Extend
+open Pcoq
+open Topconstr
+open Ast
+open Genarg
+open Libnames
+open Nameops
+
+(* State of the grammar extensions *)
+
+type all_grammar_command =
+  | Notation of
+      (int * Gramext.g_assoc option * notation * prod_item list *
+      int list option)
+  | Grammar of grammar_command
+  | TacticGrammar of
+      (string * (string * grammar_production list) * 
+      (Names.dir_path * Tacexpr.raw_tactic_expr))
+      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 -> TacticGrammar g (* TODO ... *)
+
+let (grammar_state : all_grammar_command list ref) = ref []
+
+
+(**************************************************************************)
+(* 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
+ *   [ 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:
+ *
+ *      ((fun env ->
+ *          (fun vi -> 
+ *             (fun env -> ...
+ *           
+ *                  (fun v1 ->
+ *                     (fun env -> gram_action .. env act)
+ *                     ((x1,v1)::env))
+ *                  ...)
+ *             ((xi,vi)::env)))
+ *         [])
+ *)
+
+open Names
+
+type 'a action_env = (identifier * 'a) list
+
+let make_act (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)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, (ETConstr _| ETOther _)) :: tl -> (* constr non-terminal *)
+        Gramext.action (fun (v:constr_expr) -> make ((p,v) :: env) tl)
+    | Some (p, ETReference) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:reference) -> make ((p,CRef v) :: env) tl)
+    | Some (p, ETIdent) :: tl -> (* non-terminal *)
+        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)
+    | Some (p, ETConstrList _) :: tl ->
+        Gramext.action (fun (v:constr_expr list) ->
+          let dummyid = Ident (dummy_loc,id_of_string "") in
+	  make ((p,CAppExpl (dummy_loc,(None,dummyid),v)) :: env) tl)
+    | Some (p, ETPattern) :: tl -> 
+	failwith "Unexpected entry of type cases pattern" in
+  make [] (List.rev pil)
+
+let make_act_in_cases_pattern (* For Notations *)
+  (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, ETConstr _) :: tl -> (* pattern non-terminal *)
+        Gramext.action (fun (v:cases_pattern_expr) -> make ((p,v) :: env) tl)
+    | Some (p, ETReference) :: tl -> (* non-terminal *)
+        Gramext.action (fun (v:reference) ->
+	  make ((p,CPatAtom (dummy_loc,Some v)) :: env) tl)
+    | Some (p, ETIdent) :: tl -> (* non-terminal *)
+        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)
+    | Some (p, ETConstrList _) :: tl ->
+        Gramext.action (fun (v:cases_pattern_expr list) ->
+          let dummyid = Ident (dummy_loc,id_of_string "") in
+	  make ((p,CPatCstr (dummy_loc,dummyid,v)) :: env) tl)
+    | Some (p, (ETPattern | ETOther _)) :: tl -> 
+	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
+  | 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 (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)
+
+(* 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 make_prod_item = function
+  | TacTerm s -> (Gramext.Stoken (Extend.terminal s), None)
+  | TacNonTerm (_,(nont,t), po) ->
+      (nont, option_app (fun p -> (p,t)) po)
+
+let make_gen_act f pil =
+  let rec make env = function
+    | [] -> 
+	Gramext.action (fun loc -> f loc env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gramext.action (fun _ -> make env tl)
+    | Some (p, t) :: tl -> (* non-terminal *)
+        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
+  (symbs, act)
+
+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
+  Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+
+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
+  Gram.extend Vernac_.command None [(None, None, List.rev rules)]
+
+let rec interp_entry_name u 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
+    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
+    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
+    OptArgType t, Gramext.Sopt g
+  else
+    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 _ -> 
+      try get_entry (get_univ "prim") s
+      with _ ->
+      try get_entry (get_univ "constr") s
+      with _ -> error ("Unknown entry "^s)
+    in
+    let o = object_of_typed_entry e in
+    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)
+  | 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 add_tactic_entries gl =
+  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 _ = find_position true true None None (* to synchronise with remove *) in
+  grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)]
+
+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);
+  grammar_state := gram :: !grammar_state
+
+let reset_extend_grammars_v8 () =
+  let te = List.rev !tac_exts in
+  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) -> extend_vernac_command_grammar s gl) tv
+
+
+(* Summary functions: the state of the lexer is included in that of the parser.
+   Because the grammar affects the set of keywords when adding or removing
+   grammar rules. *)
+type frozen_t = all_grammar_command list * Lexer.frozen_t
+
+let freeze () = (!grammar_state, Lexer.freeze ())
+
+(* We compare the current state of the grammar and the state to unfreeze, 
+   by computing the longest common suffixes *)
+let factorize_grams l1 l2 =
+  if l1 == l2 then ([], [], l1) else list_share_tails 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)
+      | TacticGrammar _ -> n + 1)
+    0 gcl
+
+let unfreeze (grams, lex) =
+  let (undo, redo, common) = factorize_grams !grammar_state grams in
+  let n = number_of_entries undo in
+  remove_grammars n;
+  remove_levels n;
+  grammar_state := common;
+  Lexer.unfreeze lex;
+  List.iter extend_grammar (List.rev redo)
+ 
+let init_grammar () =
+  remove_grammars (number_of_entries !grammar_state);
+  grammar_state := []
+
+let init () =
+  init_grammar ()
+
+open Summary
+
+let _ = 
+  declare_summary "GRAMMAR_LEXER"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init;
+      survive_module = false;
+      survive_section = false }
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
new file mode 100644
index 00000000..c601c5fc
--- /dev/null
+++ b/parsing/egrammar.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: egrammar.mli,v 1.14.2.2 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Topconstr
+open Ast
+open Coqast
+open Vernacexpr
+open Extend
+open Rawterm
+(*i*)
+
+type all_grammar_command =
+  | Notation of
+      (int * Gramext.g_assoc option * notation * prod_item list *
+      int list option)
+  | Grammar of grammar_command
+  | TacticGrammar of
+      (string * (string * grammar_production list) * 
+      (Names.dir_path * Tacexpr.raw_tactic_expr))
+      list
+
+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
+
+val extend_tactic_grammar :
+  string -> (string * grammar_tactic_production list) list -> unit
+
+val extend_vernac_command_grammar :
+  string -> (string * grammar_tactic_production list) list -> unit
+
+val get_extend_tactic_grammars :
+ unit -> (string * (string * grammar_tactic_production list) list) list
+val get_extend_vernac_grammars :
+ unit -> (string * (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
diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml
new file mode 100644
index 00000000..6a4758ab
--- /dev/null
+++ b/parsing/esyntax.ml
@@ -0,0 +1,276 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e05e1ca4
--- /dev/null
+++ b/parsing/esyntax.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.1 2004/07/16 19:30:37 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
+
+(*
+val declare_infix_symbol : Libnames.section_path -> string -> unit
+*)
+
+(* Generic printing functions *) 
+(*
+val token_printer: std_printer -> std_printer
+*)
+(*
+val print_syntax_entry : 
+  string -> unparsing_subfunction -> Ast.env -> Ast.astpat syntax_entry -> std_ppcmds
+*)
+val genprint : std_printer -> unparsing_subfunction
diff --git a/parsing/extend.ml b/parsing/extend.ml
new file mode 100644
index 00000000..2778de44
--- /dev/null
+++ b/parsing/extend.ml
@@ -0,0 +1,378 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: extend.ml,v 1.20.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+open Util
+open Pp
+open Gramext
+open Names
+open Ast
+open Ppextend
+open Topconstr
+open Genarg
+
+type entry_type = argument_type
+
+type production_position =
+  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | InternalProd
+
+type production_level =
+  | NextLevel
+  | NumLevel of int
+
+type ('lev,'pos) constr_entry_key =
+  | ETIdent | ETReference | ETBigint
+  | ETConstr of ('lev * 'pos)
+  | ETPattern
+  | ETOther of string * string
+  | ETConstrList of ('lev * 'pos) * Token.pattern list
+
+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
+
+(**********************************************************************)
+(* 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
+
+type syntax_modifier =
+  | SetItemLevel of string list * production_level
+  | SetLevel of int
+  | SetAssoc of Gramext.g_assoc
+  | SetEntryType of string * simple_constr_production_entry
+  | 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
new file mode 100644
index 00000000..761d0e04
--- /dev/null
+++ b/parsing/extend.mli
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: extend.mli,v 1.19.2.1 2004/07/16 19:30:37 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Ast
+open Coqast
+open Ppextend
+open Topconstr
+open Genarg
+(*i*)
+
+type entry_type = argument_type
+
+type production_position =
+  | BorderProd of bool * Gramext.g_assoc option  (* true=left; false=right *)
+  | InternalProd
+
+type production_level =
+  | NextLevel
+  | NumLevel of int
+
+type ('lev,'pos) constr_entry_key =
+  | ETIdent | ETReference | ETBigint
+  | ETConstr of ('lev * 'pos)
+  | ETPattern
+  | ETOther of string * string
+  | ETConstrList of ('lev * 'pos) * Token.pattern list
+
+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
+
+(* Globalisation and type-checking of Grammar actions *)
+type entry_context = identifier list
+
+val set_constr_globalizer : 
+  (entry_context -> constr_expr -> constr_expr) -> unit
+
+type syntax_modifier =
+  | SetItemLevel of string list * production_level
+  | SetLevel of int
+  | SetAssoc of Gramext.g_assoc
+  | SetEntryType of string * simple_constr_production_entry
+  | 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
+
+(*val subst_unparsing_hunk : 
+  Names.substitution -> (Names.substitution -> 'pat -> 'pat) -> 
+  'pat unparsing_hunk -> 'pat unparsing_hunk
+*)
+
+(* 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_basevernac.ml4 b/parsing/g_basevernac.ml4
new file mode 100644
index 00000000..c4badbc3
--- /dev/null
+++ b/parsing/g_basevernac.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b952305d
--- /dev/null
+++ b/parsing/g_cases.ml4
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..7b0f7da2
--- /dev/null
+++ b/parsing/g_constr.ml4
@@ -0,0 +1,368 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.52.2.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pcoq
+open Constr
+open Rawterm
+open Term
+open Names
+open Libnames
+open Prim
+open Topconstr
+
+(* Initialize the lexer *)
+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 ? *)
+
+
+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 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 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)
+
+open Util
+
+let rec abstract_constr loc c = function
+  | [] -> 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)
+
+(* 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)
+
+(* 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)
+
+(* Hack to parse "`id:...`" at level 0 without conflicting with
+   "`...`" from ZArith *)
+let test_ident_colon =
+  Gram.Entry.of_parser "test_ident_colon"
+    (fun strm ->
+      match Stream.npeek 1 strm with
+        | [("IDENT", _)] ->
+            begin match Stream.npeek 2 strm with
+              | [_; ("", ":")] -> ()
+              | _ -> raise Stream.Failure
+            end
+        | _ -> raise Stream.Failure)
+
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: operconstr lconstr constr sort global constr_pattern Constr.ident annot
+          (*ne_name_comma_list*);
+  Constr.ident:
+    [ [ id = Prim.ident -> id
+
+      (* This is used in quotations and Syntax *)
+      | id = METAIDENT -> id_of_string id ] ]
+  ;
+  global:
+    [ [ r = Prim.reference -> r
+
+      (* This is used in quotations *)
+      | id = METAIDENT -> Ident (loc,id_of_string id) ] ]
+  ;
+  constr_pattern:
+    [ [ c = constr -> c ] ]
+  ;
+  ne_constr_list:
+    [ [ cl = LIST1 constr -> cl ] ]
+  ;
+  sort:
+    [ [ "Set"  -> RProp Pos
+      | "Prop" -> RProp Null
+      | "Type" -> RType None ] ]
+  ;
+  constr:
+    [ [ c = operconstr LEVEL "8" -> c ] ]
+  ;
+  lconstr:
+    [ [ c = operconstr LEVEL "10" -> 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"; ".." ->
+          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) ] ]
+  ;
+  constr91:
+    [ [ test_int_bang; n = INT; "!"; c = operconstr LEVEL "9" ->
+        (c, Some (loc,ExplByPos (int_of_string n)))
+      | c = operconstr LEVEL "9" -> (c, None) ] ]
+  ;
+  (* 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 ] ]
+  ;
+  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) ] ]
+  ;
+  ne_name_comma_list:
+    [ [ nal = LIST1 name SEP "," -> nal ] ]
+  ;
+  name_comma_list_tail:
+    [ [ ","; idl = ne_name_comma_list -> idl
+      | -> [] ] ]
+  ;
+  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)
+
+      (* This is used in quotations *)
+      | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c)
+    ] ]
+  ;
+  ne_vardecls_list:
+    [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl
+      | id = vardecls -> [id] ] ]
+  ;
+  binders:
+    [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ]
+  ;
+  simple_params:
+    [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c)
+      | idl = LIST1 name SEP "," -> (idl, CHole loc)
+    ] ]
+  ;
+  simple_binders:
+    [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ]
+  ;
+  ne_simple_binders_list:
+    [ [ bll = LIST1 simple_binders -> List.flatten bll ] ]
+  ;
+  type_option:
+    [ [ ":"; c = constr -> c 
+      | -> CHole loc ] ]
+  ;
+  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) ] ]
+  ;
+  fixbinders:
+    [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ]
+  ;
+  cofixbinder:
+    [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr ->
+          (id, [],type_, def) ] ]
+  ;
+  cofixbinders:
+    [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ]
+  ;
+  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) ] ]
+  ;
+END;;
diff --git a/parsing/g_constrnew.ml4 b/parsing/g_constrnew.ml4
new file mode 100644
index 00000000..18dc5683
--- /dev/null
+++ b/parsing/g_constrnew.ml4
@@ -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        *)
+(************************************************************************)
+
+(* $Id: g_constrnew.ml4,v 1.41.2.1 2004/07/16 19:30:38 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:
+    [ "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_ltac.ml4 b/parsing/g_ltac.ml4
new file mode 100644
index 00000000..7349a6f8
--- /dev/null
+++ b/parsing/g_ltac.ml4
@@ -0,0 +1,213 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_ltac.ml4,v 1.28.2.2 2004/07/16 19:30:38 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 *)
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: tactic Vernac_.command tactic_arg;
+
+(*
+  GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun;
+*)
+  input_fun:
+    [ [ l = base_ident -> Some l
+      | "()" -> None ] ]
+  ;
+  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) ] ]
+  ;
+  rec_clause:
+    [ [ 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 ] ]
+  ;
+  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 ] ]
+  ;
+  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 ] ]
+  ;
+  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) ] ]
+  ;
+
+  (* 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: 
+    [ [ deftok; "Definition"; b = tacdef_body ->
+          VernacDeclareTacticDefinition (false, [b])
+      | IDENT "Recursive"; deftok; "Definition"; 
+        l = LIST1 tacdef_body SEP "And" ->
+          VernacDeclareTacticDefinition (true, l) ] ]
+  ;
+  END
diff --git a/parsing/g_ltacnew.ml4 b/parsing/g_ltacnew.ml4
new file mode 100644
index 00000000..9c8d1675
--- /dev/null
+++ b/parsing/g_ltacnew.ml4
@@ -0,0 +1,189 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2 2004/07/16 19:30:38 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;
+
+  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:
+    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
+	  ConstrMayEval (ConstrEval (rtc,c))
+      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
+	  ConstrMayEval (ConstrContext (id,c))
+      | IDENT "type"; IDENT "of"; c = Constr.constr ->
+	  ConstrMayEval (ConstrTypeOf c)
+      | IDENT "fresh"; s = OPT STRING ->
+	  TacFreshId s ] ]
+  ;
+  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
new file mode 100644
index 00000000..dd4ef517
--- /dev/null
+++ b/parsing/g_minicoq.ml4
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_minicoq.ml4,v 1.17.6.1 2004/07/16 19:30:38 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Univ
+open Term
+open Environ
+
+let lexer =
+  {Token.func = Lexer.func; Token.using = Lexer.add_token;
+   Token.removing = (fun _ -> ()); Token.tparse = Lexer.tparse;
+   Token.text = Lexer.token_text}
+;;
+
+type command =
+  | Definition of identifier * constr option * constr
+  | Parameter of identifier * constr
+  | Variable of identifier * constr
+  | Inductive of 
+      (identifier * constr) list *
+      (identifier * constr * (identifier * constr) list) list
+  | Check of constr
+
+let gram = Grammar.create lexer
+
+let term = Grammar.Entry.create gram "term"
+let name = Grammar.Entry.create gram "name"
+let nametype = Grammar.Entry.create gram "nametype"
+let inductive = Grammar.Entry.create gram "inductive"
+let constructor = Grammar.Entry.create gram "constructor"
+let command = Grammar.Entry.create gram "command"
+
+let path_of_string s = make_path [] (id_of_string s)
+
+EXTEND
+  name: 
+  [ [ id = IDENT -> Name (id_of_string id)
+    | "_" -> Anonymous
+  ] ];
+  nametype: 
+  [ [ id = IDENT; ":"; t = term -> (id_of_string id, t) 
+  ] ];
+  term: 
+  [ [ id = IDENT -> 
+	mkVar (id_of_string id) 
+    | IDENT "Rel"; n = INT ->
+	mkRel (int_of_string n)
+    | "Set" ->
+	mkSet
+    | "Prop" ->
+	mkProp
+    | "Type" ->
+	mkType (new_univ())
+    | "Const"; id = IDENT ->
+	mkConst (path_of_string id, [||])
+    | "Ind"; id = IDENT; n = INT ->
+	let n = int_of_string n in
+	mkMutInd ((path_of_string id, n), [||])
+    | "Construct"; id = IDENT; n = INT; i = INT ->
+	let n = int_of_string n and i = int_of_string i in
+	mkMutConstruct (((path_of_string id, n), i), [||])
+    | "["; na = name; ":"; t = term; "]"; c = term ->
+	mkLambda (na,t,c)
+    | "("; na = name; ":"; t = term; ")"; c = term ->
+	mkProd (na,t,c)
+    | c1 = term; "->"; c2 = term ->
+	mkArrow c1 c2
+    | "("; id = IDENT; cl = LIST1 term; ")" ->
+	let c = mkVar (id_of_string id) in
+	mkApp (c, Array.of_list cl)
+    | "("; cl = LIST1 term; ")" ->
+	begin match cl with
+	  | [c] -> c
+	  | c::cl -> mkApp (c, Array.of_list cl)
+	end
+    | "("; c = term; "::"; t = term; ")" ->
+	mkCast (c, t)
+    | "<"; p = term; ">"; 
+	IDENT "Case"; c = term; ":"; "Ind"; id = IDENT; i = INT;
+	"of"; bl = LIST0 term; "end" ->
+	  let ind = (path_of_string id,int_of_string i) in
+	  let nc = List.length bl in
+	  let dummy_pats = Array.create nc RegularPat in
+	  let dummy_ci = [||],(ind,[||],nc,None,dummy_pats) in
+	  mkMutCase (dummy_ci, p, c, Array.of_list bl)
+  ] ];
+  command: 
+  [ [ "Definition"; id = IDENT; ":="; c = term; "." ->
+	Definition (id_of_string id, None, c)
+    | "Definition"; id = IDENT; ":"; t = term; ":="; c = term; "." ->
+	Definition (id_of_string id, Some t, c)
+    | "Parameter"; id = IDENT; ":"; t = term; "." ->
+	Parameter (id_of_string id, t)
+    | "Variable"; id = IDENT; ":"; t = term; "." ->
+	Variable (id_of_string id, t)
+    | "Inductive"; "["; params = LIST0 nametype SEP ";"; "]"; 
+      inds = LIST1 inductive SEP "with" ->
+	Inductive (params, inds)
+    | IDENT "Check"; c = term; "." ->
+	Check c
+    | EOI -> raise End_of_file
+  ] ];
+  inductive: 
+  [ [ id = IDENT; ":"; ar = term; ":="; constrs = LIST0 constructor SEP "|" ->
+        (id_of_string id,ar,constrs)
+  ] ];
+  constructor:
+  [ [ id = IDENT; ":"; c = term -> (id_of_string id,c) ] ];
+END
+
+(* Pretty-print. *)
+
+let print_univers = ref false
+let print_casts = ref false
+
+let print_type u =
+  if !print_univers then (str "Type" ++ pr_uni u)
+  else (str "Type")
+
+let print_name = function
+  | Anonymous -> (str "_")
+  | Name id -> pr_id id
+
+let print_rel bv n = print_name (List.nth bv (pred n))
+
+let rename bv = function
+  | Anonymous -> Anonymous
+  | Name id as na -> 
+      let idl = 
+	List.fold_left 
+	  (fun l n -> match n with Name x -> x::l | _ -> l) [] bv 
+      in
+      if List.mem na bv then Name (next_ident_away id idl) else na
+
+let rec pp bv t =
+  match kind_of_term t with
+  | Sort (Prop Pos) -> (str "Set")
+  | Sort (Prop Null) -> (str "Prop")
+  | Sort (Type u) -> print_type u
+  | Lambda (na, t, c) ->
+      (str"[" ++ print_name na ++ str":" ++ pp bv t ++ str"]" ++ pp (na::bv) c)
+  | Prod (Anonymous, t, c) ->
+      (pp bv t ++ str"->" ++ pp (Anonymous::bv) c)
+  | Prod (na, t, c) ->
+      (str"(" ++ print_name na ++ str":" ++ pp bv t ++ str")" ++ pp (na::bv) c)
+  | Cast (c, t) ->
+      if !print_casts then 
+	(str"(" ++ pp bv c ++ str"::" ++ pp bv t ++ str")")
+      else 
+	pp bv c
+  | App(h, v) ->
+      (str"(" ++ pp bv h ++ spc () ++
+         prvect_with_sep (fun () -> (spc ())) (pp bv) v ++ str")")
+  | Const (sp, _) ->
+      (str"Const " ++ pr_id (basename sp))
+  | Ind ((sp,i), _) ->
+      (str"Ind " ++ pr_id (basename sp) ++ str" " ++ int i)
+  | Construct (((sp,i),j), _) ->
+      (str"Construct " ++ pr_id (basename sp) ++ str" " ++ int i ++ 
+	 str" " ++ int j)
+  | Var id -> pr_id id
+  | Rel n -> print_rel bv n
+  | _ -> (str"<???>")
+
+let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx [])
+
diff --git a/parsing/g_minicoq.mli b/parsing/g_minicoq.mli
new file mode 100644
index 00000000..e19b1163
--- /dev/null
+++ b/parsing/g_minicoq.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: g_minicoq.mli,v 1.8.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Environ
+(*i*)
+
+val term : constr Grammar.Entry.e
+
+type command =
+  | Definition of identifier * constr option * constr
+  | Parameter of identifier * constr
+  | Variable of identifier * constr
+  | Inductive of 
+      (identifier * constr) list *
+      (identifier * constr * (identifier * constr) list) list
+  | Check of constr
+
+val command : command Grammar.Entry.e
+
+val pr_term : path_kind -> env -> constr -> std_ppcmds
diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4
new file mode 100644
index 00000000..0b542608
--- /dev/null
+++ b/parsing/g_module.ml4
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e43142ba
--- /dev/null
+++ b/parsing/g_natsyntax.ml
@@ -0,0 +1,229 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_natsyntax.ml,v 1.19.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+(* This file to allow writing (3) for (S (S (S O))) 
+   and still write (S y) for (S y) *)
+
+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 Coqlib
+open Symbols
+open Pp
+open Util
+open Names
+(*i*)
+
+(**********************************************************************)
+(* Parsing via scopes *)
+(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
+
+let nat_of_int dloc n =
+  match n with
+  | POS n ->
+      if less_than (of_string "5000") n & Options.is_verbose () then begin
+	warning ("You may experiment stack overflow and segmentation fault\
+                  \nwhile parsing numbers in nat greater than 5000");
+	flush_all ()
+      end;
+      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 
+	  mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+	else 
+	  acc
+      in 
+      mk_nat ref_O n
+  | NEG n ->
+      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 *)
+
+exception Non_closed_number
+
+let rec int_of_nat = function
+  | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
+  | RRef (_,z) when z = glob_O -> zero
+  | _ -> raise Non_closed_number
+	  
+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))
+  with
+    Non_closed_number -> None
+
+(************************************************************************)
+(* 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
+()
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
new file mode 100644
index 00000000..1471aed2
--- /dev/null
+++ b/parsing/g_natsyntax.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_natsyntax.mli,v 1.3.16.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for naturals. *)
diff --git a/parsing/g_natsyntaxnew.mli b/parsing/g_natsyntaxnew.mli
new file mode 100644
index 00000000..50d38133
--- /dev/null
+++ b/parsing/g_natsyntaxnew.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_natsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for naturals. *)
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
new file mode 100644
index 00000000..ce6d4e2f
--- /dev/null
+++ b/parsing/g_prim.ml4
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_prim.ml4,v 1.22.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+open Coqast
+open Pcoq
+open Names
+open Libnames
+open Topconstr
+open Prim
+
+let _ = reset_all_grammars()
+
+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;
+
+ (* Compatibility: Prim.var is a synonym of Prim.ident *)
+  var:
+    [ [ id = ident -> id ] ]
+  ;
+  hyp:
+    [ [ id = ident -> id ] ]
+  ;
+  metaident:
+    [ [ s = METAIDENT -> Nmeta (loc,s) ] ]
+  ;
+  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 ] ]
+  ;
+  natural:
+    [ [ i = INT -> local_make_posint i ] ]
+  ;
+  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 ] ]
+  ;
+  field:
+    [ [ s = FIELD -> local_id_of_string s ] ]
+  ;
+  dirpath:
+    [ [ id = base_ident; l = LIST0 field ->
+        local_make_dirpath (local_append l id) ] ]
+  ;
+  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
+      ] ]
+  ;
+  qualid:
+    [ [ qid = basequalid -> loc, qid ] ]
+  ;
+  reference:
+    [ [ id = base_ident; (l,id') = fields ->
+        Qualid (loc, local_make_qualid (local_append l id) id')
+      | id = base_ident -> Ident (loc,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)
+      ] ]
+  ;
+  (* 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 ] ]
+  ;
+END
diff --git a/parsing/g_primnew.ml4 b/parsing/g_primnew.ml4
new file mode 100644
index 00000000..c1875634
--- /dev/null
+++ b/parsing/g_primnew.ml4
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..5262b785
--- /dev/null
+++ b/parsing/g_proofs.ml4
@@ -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        *)
+(************************************************************************)
+
+(* $Id: g_proofs.ml4,v 1.33.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 = Gram.Entry.create "vernac:thm_token"
+
+(* Proof commands *)
+if !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.constr -> VernacGoal c
+      | "Proof" -> VernacProof (Tacexpr.TacId "")
+      | "Proof"; "with"; ta = tactic -> VernacProof ta
+      | IDENT "Abort" -> VernacAbort None
+      | IDENT "Abort"; IDENT "All" -> VernacAbortAll
+      | IDENT "Abort"; id = identref -> VernacAbort (Some id)
+      | IDENT "Admitted" -> VernacEndProof Admitted
+      | "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 "Suspend" -> VernacSuspend
+      | IDENT "Resume" -> VernacResume None
+      | IDENT "Resume"; id = identref -> VernacResume (Some id)
+      | IDENT "Restart" -> VernacRestart
+      | "Proof"; c = Constr.constr -> 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 "Implicits"; n = natural ->
+	  VernacShow (ShowGoalImplicitly (Some n))
+      | IDENT "Show"; IDENT "Implicits" -> VernacShow (ShowGoalImplicitly None)
+      | 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 "Intro" -> VernacShow (ShowIntros false)
+      | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true)
+      | IDENT "Explain"; "Proof"; l = LIST0 integer ->
+	  VernacShow (ExplainProof l)
+      | IDENT "Explain"; "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 "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)
+	  
+
+(*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"; 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)) ] ]
+    ;
+  END
diff --git a/parsing/g_proofsnew.ml4 b/parsing/g_proofsnew.ml4
new file mode 100644
index 00000000..04bf7a8b
--- /dev/null
+++ b/parsing/g_proofsnew.ml4
@@ -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: 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
new file mode 100644
index 00000000..8f5aad33
--- /dev/null
+++ b/parsing/g_rsyntax.ml
@@ -0,0 +1,332 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 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
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+
+(* TODO: temporary hack *)
+let make_path dir id = Libnames.encode_kn dir (id_of_string id)
+
+let glob_R = ConstRef (make_path rdefinitions "R")
+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)
+  else RApp(dloc,RRef (dloc,glob_Rplus),
+            [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+
+let r_of_posint dloc n =
+  let r1 = RRef (dloc, glob_R1) in
+  let r2 = small_r dloc two in
+  let rec r_of_pos n =
+    if less_than n four then small_r dloc n
+    else
+      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)
+
+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
+
+(**********************************************************************)
+(* Printing R via scopes                                              *)
+(**********************************************************************)
+
+let bignat_of_r =
+(* for numbers > 1 *)
+let rec bignat_of_pos = function
+  (* 1+1 *)
+  | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)])
+      when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
+  (* 1+(1+1) *)
+  | RApp (_,RRef (_,p1), [RRef (_,o1);
+      RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])])
+      when p1 = glob_Rplus & p2 = glob_Rplus &
+           o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
+  (* (1+1)*b *)
+  | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult ->
+      if bignat_of_pos a <> two then raise Non_closed_number;
+      mult_2 (bignat_of_pos b)
+  (* 1+(1+1)*b *)
+  | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
+      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  -> 
+      if bignat_of_pos a <> two then raise Non_closed_number;
+        add_1 (mult_2 (bignat_of_pos b))
+  | _ -> raise Non_closed_number
+in
+let bignat_of_r = function
+  | RRef (_,a) when a = glob_R0 -> zero
+  | RRef (_,a) when a = glob_R1 -> one
+  | r -> bignat_of_pos r
+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)
+
+let uninterp_r p =
+  try
+    Some (bigint_of_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)
+  ([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)],
+    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 ()
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
new file mode 100644
index 00000000..2e067215
--- /dev/null
+++ b/parsing/g_tactic.ml4
@@ -0,0 +1,367 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_tactic.ml4,v 1.83.2.2 2004/07/16 19:30:39 herbelin Exp $ *)
+
+open Pp
+open Ast
+open Pcoq
+open Util
+open Tacexpr
+open Rawterm
+open Genarg
+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
+
+(* 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 !Options.v7 then
+GEXTEND Gram
+  GLOBAL: simple_tactic constrarg bindings constr_with_bindings 
+  quantified_hypothesis red_expr int_or_var castedopenconstr
+  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) ] ]
+  ;
+  (* 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)
+      ] ]
+  ;
+  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 ] ]
+  ;
+  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:
+    [ [ nl = LIST1 integer; c1 = constr; "with"; c2 = constr ->
+         (Some (nl,c1), c2)
+      |	c1 = constr; "with"; c2 = constr -> (Some ([],c1), c2)
+      | c = constr -> (None, c) ] ]
+  ;
+  pattern_occ:
+    [ [ nl = LIST0 integer; c = constr -> (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
+      ] ]
+  ;
+  simple_binding:
+    [ [ id = base_ident; ":="; c = constr -> (loc, NamedHyp id, c)
+      | n = natural; ":="; c = constr -> (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) ] ]
+  ;
+  constr_with_bindings:
+    [ [ c = constr; l = with_bindings -> (c, l) ] ]
+  ;
+  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
+    ] ]
+  ;
+  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 ] ]
+  ;
+  (* 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
+      | s = IDENT; c = constr -> ExtraRedExpr (s,c) ] ]
+  ;
+  hypident:
+    [ [ id = id_or_meta -> id,[],(InHyp,ref None)
+      | "("; "Type"; "of"; id = id_or_meta; ")" ->
+          id,[],(InHypTypeOnly,ref None)
+    ] ]
+  ;
+  clause:
+    [ [ "in"; idl = LIST1 hypident ->
+        {onhyps=Some idl;onconcl=false; concl_occs=[]}
+      | -> {onhyps=Some[];onconcl=true;concl_occs=[]} ] ]
+  ;
+  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=[] } ] ]
+  ;
+  fixdecl:
+    [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ]
+  ;
+  cofixdecl:
+    [ [ id = base_ident; ":"; c = constr -> (id,c) ] ]
+  ;
+  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 "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 ->
+	  TacSpecialize (n,lcb)
+      | 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;
+	  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
+        -> TacDecompose (l,c)
+
+      (* Automation tactic *)
+      | IDENT "Trivial"; db = hintbases -> TacTrivial db
+      | IDENT "Auto"; n = OPT natural; 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 natural; 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)
+
+      (* 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 ->
+	  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_tacticnew.ml4 b/parsing/g_tacticnew.ml4
new file mode 100644
index 00000000..2070b40e
--- /dev/null
+++ b/parsing/g_tacticnew.ml4
@@ -0,0 +1,401 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2 2004/07/16 19:30:39 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 -> 0
+      | _, 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 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)
+      ] ]
+  ;
+  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; c = constr -> ExtraRedExpr (s,c) ] ]
+  ;
+  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 natural; 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 natural; 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
new file mode 100644
index 00000000..e2eecf55
--- /dev/null
+++ b/parsing/g_vernac.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_vernac.ml4,v 1.93.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+open Names
+open Topconstr
+open Vernacexpr
+open Pcoq
+open Pp
+open Tactic
+open Util
+open Constr
+open Vernac_
+open Prim
+open Decl_kinds
+
+open Genarg
+
+let evar_constr loc = CHole loc
+
+let class_rawexpr = G_basevernac.class_rawexpr
+let thm_token = G_proofs.thm_token
+
+(* 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 
+
+if !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
+      | 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)
+*)
+    ] ]
+  ;
+    
+  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)
+    ] ]
+  ;
+  constr_body:
+    [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t)
+      | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t)
+      | ":="; c = constr -> c ] ]
+  ;
+  vernac_list_tail:
+    [ [ v = located_vernac; l = vernac_list_tail -> v :: l
+      | "]"; "." -> [] ] ]
+  ;
+  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"
+  | _ -> ()
+
+(* Gallina declarations *)
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: gallina gallina_ext thm_token;
+
+  thm_token:
+    [ [ "Theorem" -> Theorem
+      | IDENT "Lemma" -> Lemma
+      | IDENT "Fact" -> Fact
+      | IDENT "Remark" -> Remark ] ]
+  ;
+  def_token:
+    [ [ "Definition" -> (fun _ _ -> ()), (Global, Definition)
+      | IDENT "Local" -> (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 "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; ":"; c = constr ->
+         VernacStartTheoremProof (thm, id, ([], 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 ] ]
+  ;
+  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] ] ]
+  ;
+  oneind_old_style:
+    [ [ id = identref; ":"; c = constr; ":="; lc = constructor_list ->
+          (id,c,lc) ] ]
+  ;
+  oneind:
+    [ [ id = identref; indpar = simple_binders_list; ":"; c = constr; 
+        ":="; lc = constructor_list; ntn = OPT decl_notation ->
+	  (id,ntn,indpar,c,lc) ] ]
+  ;
+  simple_binders_list:
+    [ [ bl = ne_simple_binders_list -> bl
+      |  -> [] ] ]
+  ;
+  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 ] ]
+  ;
+  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) ] ]
+  ;
+  specifrec:
+    [ [ l = LIST1 onerec SEP "with" -> l ] ]
+  ;
+  onecorec:
+    [ [ id = base_ident; ":"; c = constr; ":="; def = constr ->
+          (id,[],c,def) ] ]
+  ;
+  specifcorec:
+    [ [ l = LIST1 onecorec SEP "with" -> l ] ]
+  ;
+  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 ] ]
+  ;
+  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]) ] ]
+  ;
+  csort:
+    [ [ s = sort -> CSort (loc,s) ] ]
+  ;
+  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) ] ]
+  ;
+  module_binders:
+    [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ]
+  ;
+  module_binders_list:
+    [ [ bls = LIST0 module_binders -> List.flatten bls ] ]
+  ;
+  of_module_type:
+    [ [ ":"; mty = Module.module_type -> (mty, true) 
+      | "<:"; mty = Module.module_type -> (mty, false) ] ]
+  ;
+  is_module_type:
+    [ [ ":="; mty = Module.module_type -> mty ] ]
+  ;
+  is_module_expr:
+    [ [ ":="; mexpr = Module.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 *)
+
+      | IDENT "End"; id = identref -> VernacEndSegment id
+
+
+(* 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)
+      (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed
+         (they were unused and undocumented) *)
+
+(* 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)
+      | 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)
+  ] ]
+  ;
+END
+
+(* Modules management *)   
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  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 ] ->
+	  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 ->
+	  VernacDeclareMLModule l
+      | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
+      | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
+  ] 
+]
+  ;
+END
+
+if !Options.v7 then
+GEXTEND Gram
+  GLOBAL: command;
+
+  command:
+    [ [ 
+
+(* State management *)
+        IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s
+      | IDENT "Write"; IDENT "State"; s = STRING -> VernacWriteState s
+      | IDENT "Restore"; IDENT "State"; s = IDENT -> VernacRestoreState s
+      | IDENT "Restore"; IDENT "State"; s = 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
+;;
diff --git a/parsing/g_vernacnew.ml4 b/parsing/g_vernacnew.ml4
new file mode 100644
index 00000000..8a99a51e
--- /dev/null
+++ b/parsing/g_vernacnew.ml4
@@ -0,0 +1,729 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.1 2004/07/16 19:30:39 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; *) ":";
+        c = lconstr ->
+          let bl = [] in
+          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_zsyntax.ml b/parsing/g_zsyntax.ml
new file mode 100644
index 00000000..27eead96
--- /dev/null
+++ b/parsing/g_zsyntax.ml
@@ -0,0 +1,406 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_zsyntax.ml,v 1.16.2.1 2004/07/16 19:30:39 herbelin Exp $ *)
+
+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
+
+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                                        *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let positive_module = ["Coq";"NArith";"BinPos"]
+
+(* 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 glob_xI = ConstructRef path_of_xI
+let glob_xO = ConstructRef path_of_xO
+let glob_xH = ConstructRef path_of_xH
+
+let pos_of_bignat dloc x =
+  let ref_xI = RRef (dloc, glob_xI) in
+  let ref_xH = RRef (dloc, glob_xH) in
+  let ref_xO = RRef (dloc, glob_xO) in
+  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) -> 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 pat_interp_positive dloc = function
+  | POS n -> pat_pos_of_bignat dloc n
+  | NEG n ->
+      user_err_loc (dloc, "interp_positive",
+        str "No negative number in type \"positive\"!")
+
+(**********************************************************************)
+(* Printing positive via scopes                                       *)
+(**********************************************************************)
+
+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
+  | _ -> raise Non_closed_number
+
+let uninterp_positive p =
+  try 
+    Some (POS (bignat_of_pos p))
+  with Non_closed_number -> 
+    None
+
+(************************************************************************)
+(* 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); 
+    RRef (dummy_loc, glob_xO); 
+    RRef (dummy_loc, glob_xH)],
+   uninterp_positive,
+   None)
+
+(**********************************************************************)
+(* 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 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
+    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 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")
+
+(**********************************************************************)
+(* 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)
+  | _ -> raise Non_closed_number
+
+let uninterp_n p =
+  try Some (bignat_of_n p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* 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)
+  ([RRef (dummy_loc, glob_N0); 
+    RRef (dummy_loc, glob_Npos)],
+  uninterp_n,
+  None)
+   
+(**********************************************************************)
+(* 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 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
+    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)
+  | _ -> raise Non_closed_number
+
+let uninterp_z p =
+  try
+    Some (bigint_of_z p)
+  with Non_closed_number -> None
+
+(************************************************************************)
+(* 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)
+  ([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
+()
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
new file mode 100644
index 00000000..6a7aeb14
--- /dev/null
+++ b/parsing/g_zsyntax.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_zsyntax.mli,v 1.6.6.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for integers. *)
diff --git a/parsing/g_zsyntaxnew.mli b/parsing/g_zsyntaxnew.mli
new file mode 100644
index 00000000..51bb6d41
--- /dev/null
+++ b/parsing/g_zsyntaxnew.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_zsyntaxnew.mli,v 1.1.2.1 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+(* Nice syntax for integers. *)
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
new file mode 100644
index 00000000..bf5f3bfe
--- /dev/null
+++ b/parsing/lexer.ml4
@@ -0,0 +1,539 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: lexer.ml4,v 1.24.2.6 2004/07/16 20:51:12 herbelin Exp $ i*)
+
+open Pp
+open Token
+
+(* Dictionaries: trees annotated with string options, each node being a map
+   from chars to dictionaries (the subtrees). A trie, in other words. *)
+
+module CharMap = Map.Make (struct type t = char let compare = compare end)
+
+type ttree = { 
+  node : string option;
+  branch : ttree CharMap.t }
+
+let empty_ttree = { node = None; branch = CharMap.empty }
+
+let ttree_add ttree str =
+  let rec insert tt i =
+    if i == String.length str then 
+      {node = Some str; branch = tt.branch}
+    else
+      let c = str.[i] in
+      let br =
+        match try Some (CharMap.find c tt.branch) with Not_found -> None with
+          | Some tt' ->
+              CharMap.add c (insert tt' (i + 1)) (CharMap.remove c tt.branch)
+          | None ->
+              let tt' = {node = None; branch = CharMap.empty} in
+              CharMap.add c (insert tt' (i + 1)) tt.branch
+      in
+      { node = tt.node; branch = br }
+  in 
+  insert ttree 0
+
+(* Search a string in a dictionary: raises [Not_found]
+   if the word is not present. *)
+
+let ttree_find ttree str =
+  let rec proc_rec tt i =
+    if i == String.length str then
+      match tt.node with
+	| Some s -> s
+	| None -> raise Not_found
+    else 
+      proc_rec (CharMap.find str.[i] tt.branch) (i+1)
+  in 
+  proc_rec ttree 0
+
+(* Lexer conventions on tokens *)
+
+type error =
+  | Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+  | Undefined_token
+  | Bad_token of string
+
+exception Error of error
+
+let bad_token str = raise (Error (Bad_token str))
+
+let check_special_token str =
+  let rec loop_symb = parser
+    | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
+    | [< _ = Stream.empty >] -> ()
+    | [< '_ ; s >] -> loop_symb s
+  in
+  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
+  in
+  if String.length str > 0 && first_letter str.[0] then
+    loop_id (Stream.of_string str)
+  else
+    bad_token str
+
+let check_keyword str =
+  try check_special_token str
+  with Error _ -> check_ident str
+
+(* Keyword and symbol dictionary *)
+let token_tree = ref empty_ttree
+
+let find_keyword s = ttree_find !token_tree s
+
+let is_keyword s = 
+  try let _ = ttree_find !token_tree s in true with Not_found -> false
+
+let add_keyword str =
+  check_keyword str;
+  token_tree := ttree_add !token_tree str
+
+(* Adding a new token (keyword or special token). *)
+let add_token (con, str) = match con with
+  | "" -> add_keyword str
+  | "METAIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI"
+      -> ()
+  | _ ->
+      raise (Token.Error ("\
+the constructor \"" ^ con ^ "\" is not recognized by Lexer"))
+
+
+(* Freeze and unfreeze the state of the lexer *)
+type frozen_t = ttree
+
+let freeze () = !token_tree
+
+let unfreeze tt =
+  token_tree := tt
+
+let init () =
+  unfreeze empty_ttree
+
+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)
+
+let store len x =
+  if len >= String.length !buff then
+    buff := !buff ^ String.create (String.length !buff);
+  !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 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 number len = parser
+  | [< ' ('0'..'9' as c); s >] -> number (store len c) s
+  | [< >] -> len
+
+let escape len c = store len c
+
+let rec string_v8 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
+  | [< _ = 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 _ -> ())
+let set_xml_output_comment f = xml_output_comment := f
+
+(* Utilities for comment translation *)
+let comment_begin = ref None
+let comm_loc bp = if !comment_begin=None then comment_begin := Some bp
+
+let current = Buffer.create 8192
+let between_com = ref true
+
+type com_state = int option * string * bool
+let restore_com_state (o,s,b) =
+  comment_begin := o; 
+  Buffer.clear current; Buffer.add_string current s; 
+  between_com := b
+let dflt_com = (None,"",true)
+let com_state () =
+  let s = (!comment_begin, Buffer.contents current, !between_com) in
+  restore_com_state dflt_com; s
+
+let real_push_char c = Buffer.add_char current c
+
+(* Add a char if it is between two commands, if it is a newline or
+   if the last char is not a space itself. *)
+let push_char c =
+  if
+    !between_com || List.mem c ['\n';'\r'] ||
+    (List.mem c [' ';'\t']&&
+     (Buffer.length current = 0 ||
+      not (let s = Buffer.contents current in
+	   List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r'])))
+  then
+    real_push_char c
+
+let push_string s = Buffer.add_string current s
+
+let null_comment s =
+  let rec null i =
+    i<0 || (List.mem s.[i] [' ';'\t';'\n';'\r'] && null (i-1)) in
+  null (String.length s - 1)
+
+let comment_stop ep =
+  let current_s = Buffer.contents current in
+  if !Options.xml_export && Buffer.length current > 0 &&
+    (!between_com || not(null_comment current_s)) then
+      !xml_output_comment current_s;
+  (if Options.do_translate() && Buffer.length current > 0 &&
+    (!between_com || not(null_comment current_s)) then
+    let bp = match !comment_begin with
+        Some bp -> bp
+      | None ->
+          msgerrnl(str"No begin location for comment '"++str current_s ++str"' ending at  "++int ep);
+          ep-1 in
+    Pp.comments := ((bp,ep),current_s) :: !Pp.comments);
+  Buffer.clear current;
+  comment_begin := None;
+  between_com := false
+
+(* Does not unescape!!! *)
+let rec comm_string bp = parser
+  | [< ''"' >] -> push_string "\""
+  | [< ''\\'; _ =
+           (parser [< ' ('"' | '\\' as c) >] ->
+             if c='"' then real_push_char c;
+             real_push_char c
+                 | [< >] -> real_push_char '\\'); s >]
+     -> comm_string bp s
+  | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
+  | [< 'c; s >] -> real_push_char c; comm_string bp s 
+
+let rec comment bp = parser bp2
+  | [< ''(';
+       _ = (parser
+              | [< ''*'; s >] -> push_string "(*"; comment bp s
+              | [< >] -> push_string "(" ); 
+       s >] -> comment bp s
+  | [< ''*';
+       _ = parser
+         | [< '')' >] ep -> 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
+
+(* 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
+
+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 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
+
+
+(* Parse a token in a char stream *)
+
+let rec next_token = parser bp
+  | [< '' ' | '\t' | '\n' |'\r' as c; s >] ep ->
+      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;
+      (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))
+  | [< ''\"'; len = string bp 0 >] ep ->
+      comment_stop bp;
+      (("STRING", get_buff len), (bp, ep))
+  | [< ' ('(' as c);
+      t = parser
+        | [< ''*'; s >] ->
+            comm_loc bp;
+            push_string "(*";
+	    comment bp s;
+	    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))
+
+(* Location table system for creating tables associating a token count
+   to its location in a char stream (the source) *)
+
+let locerr () = invalid_arg "Lexer: location function"
+
+let tsz = 256   (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *)
+
+let loct_create () = ref [| [| |] |]
+
+let loct_func loct i =
+  match
+    if i < 0 || i/tsz >= Array.length !loct then None
+    else if !loct.(i/tsz) = [| |] then None
+    else !loct.(i/tsz).(i mod tsz)
+  with
+    | Some loc -> Util.make_loc loc
+    | _ -> locerr ()
+
+let loct_add loct i loc =
+  while i/tsz >= Array.length !loct do
+    let new_tmax = Array.length !loct * 2 in
+    let new_loct = Array.make new_tmax [| |] in
+    Array.blit !loct 0 new_loct 0 (Array.length !loct);
+    loct := new_loct;
+  done;
+  if !loct.(i/tsz) = [| |] then !loct.(i/tsz) <- Array.make tsz None;
+  !loct.(i/tsz).(i mod tsz) <- Some loc
+
+let current_location_table = ref (ref [| [| |] |])
+
+let location_function n =
+  loct_func !current_location_table n
+
+let func cs =
+  let loct = loct_create () in
+  let ts =
+    Stream.from
+      (fun i ->
+         let (tok, loc) = next_token cs in
+	 loct_add loct i loc; Some tok)
+  in
+  current_location_table := loct;
+  (ts, loct_func loct)
+
+type location_table = (int * int) option array array ref
+let location_table () = !current_location_table
+let restore_location_table t = current_location_table := t
+
+(* Names of tokens, for this lexer, used in Grammar error messages *)
+
+let token_text = function
+  | ("", t) -> "'" ^ t ^ "'"
+  | ("IDENT", "") -> "identifier"
+  | ("IDENT", t) -> "'" ^ t ^ "'"
+  | ("INT", "") -> "integer"
+  | ("INT", s) -> "'" ^ s ^ "'"
+  | ("STRING", "") -> "string"
+  | ("EOI", "") -> "end of input"
+  | (con, "") -> con
+  | (con, prm) -> con ^ " \"" ^ prm ^ "\"" 
+
+let tparse (p_con, p_prm) =
+  None
+  (*i was
+  if p_prm = "" then
+    (parser [< '(con, prm) when con = p_con >] -> prm)
+  else
+    (parser [< '(con, prm) when con = p_con && prm = p_prm >] -> prm)
+  i*)
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
new file mode 100644
index 00000000..133bca65
--- /dev/null
+++ b/parsing/lexer.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: lexer.mli,v 1.20.2.2 2004/07/16 19:30:39 herbelin Exp $ i*)
+
+open Pp
+open Util
+
+type error =
+  | Illegal_character
+  | Unterminated_comment
+  | Unterminated_string
+  | Undefined_token
+  | Bad_token of string
+
+exception Error of error
+
+val add_token : string * string -> unit
+val is_keyword : string -> bool
+
+val func : char Stream.t -> (string * string) Stream.t * (int -> loc)
+val location_function : int -> loc
+
+(* for coqdoc *)
+type location_table
+val location_table : unit -> location_table
+val restore_location_table : location_table -> unit
+
+val check_ident : string -> unit
+val check_keyword : string -> unit
+
+val tparse : string * string -> ((string * string) Stream.t -> string) option
+
+val token_text : string * string -> string
+
+type frozen_t
+val freeze : unit -> frozen_t
+val unfreeze : frozen_t -> unit
+val init : unit -> unit
+
+type com_state
+val com_state: unit -> com_state
+val restore_com_state: com_state -> unit
+
+val set_xml_output_comment : (string -> unit) -> unit
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
new file mode 100644
index 00000000..cda482af
--- /dev/null
+++ b/parsing/pcoq.ml4
@@ -0,0 +1,803 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pcoq.ml4,v 1.80.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Rawterm
+open Topconstr
+open Ast
+open Genarg
+open Tacexpr
+open Ppextend
+open Extend
+
+(* The lexer of Coq *)
+
+(* Note: removing a token.
+   We do nothing because [remove_token] is called only when removing a grammar
+   rule with [Grammar.delete_rule]. The latter command is called only when
+   unfreezing the state of the grammar entries (see GRAMMAR summary, file
+   env/metasyntax.ml). Therefore, instead of removing tokens one by one,
+   we unfreeze the state of the lexer. This restores the behaviour of the
+   lexer. B.B. *)
+
+let lexer = {
+  Token.func = Lexer.func;
+  Token.using = Lexer.add_token;
+  Token.removing = (fun _ -> ());
+  Token.tparse = Lexer.tparse;
+  Token.text = Lexer.token_text }
+
+module L =
+  struct
+    let lexer = lexer
+  end
+
+(* The parser of Coq *)
+
+module G = Grammar.Make(L)
+
+let grammar_delete e rls =
+  List.iter
+    (fun (_,_,lev) ->
+       List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
+    (List.rev rls)
+
+(* grammar_object is the superclass of all grammar entry *)
+module type Gramobj =
+sig
+  type grammar_object
+  val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e
+end
+
+module Gramobj : Gramobj =
+struct
+  type grammar_object = Obj.t
+  let weaken_entry e = Obj.magic e
+end
+
+type grammar_object = Gramobj.grammar_object
+type typed_entry = entry_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
+let weaken_entry x = Gramobj.weaken_entry x
+
+module type Gramtypes =
+sig
+  open Decl_kinds
+  val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry
+  val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e
+end
+
+module Gramtypes : Gramtypes =
+struct
+  let inGramObj rawwit = in_typed_entry (unquote rawwit)
+  let outGramObj (a:'a raw_abstract_argument_type) o =
+    if type_of_typed_entry o <> unquote a
+      then anomaly "outGramObj: wrong type";
+    (* downcast from grammar_object *)
+    Obj.magic (object_of_typed_entry o)
+end
+
+open Gramtypes
+
+type ext_kind =
+  | ByGrammar of
+      grammar_object G.Entry.e * Gramext.position option *
+      (string option * Gramext.g_assoc option *
+       (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
+  | ByGEXTEND of (unit -> unit) * (unit -> unit)
+
+let camlp4_state = ref []
+
+(* The apparent parser of Coq; encapsulate G to keep track of the
+   extensions. *)
+module Gram =
+  struct
+    include G
+    let extend e pos rls =
+      camlp4_state :=
+      (ByGEXTEND ((fun () -> grammar_delete e rls),
+                  (fun () -> G.extend e pos rls)))
+      :: !camlp4_state;
+      G.extend e pos rls
+    let delete_rule e pil =
+      errorlabstrm "Pcoq.delete_rule" (str "GDELETE_RULE forbidden.")
+  end
+
+
+let camlp4_verbosity silent f x =
+  let a = !Gramext.warning_verbose in
+  Gramext.warning_verbose := silent;
+  f x;
+  Gramext.warning_verbose := a
+
+(* This extension command is used by the Grammar constr *)
+
+let grammar_extend te pos rls =
+  camlp4_state := ByGrammar (Gramobj.weaken_entry te,pos,rls) :: !camlp4_state;
+  camlp4_verbosity (Options.is_verbose ()) (G.extend te pos) rls
+
+(* n is the number of extended entries (not the number of Grammar commands!)
+   to remove. *)
+let rec remove_grammars n =
+  if n>0 then
+    (match !camlp4_state with
+       | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove"
+       | ByGrammar(g,_,rls)::t ->
+           grammar_delete g rls;
+           camlp4_state := t;
+           remove_grammars (n-1)
+       | ByGEXTEND (undo,redo)::t ->
+           undo();
+           camlp4_state := t;
+           remove_grammars n;
+           redo();
+           camlp4_state := ByGEXTEND (undo,redo) :: !camlp4_state)
+
+(* An entry that checks we reached the end of the input. *)
+let eoi_entry en =
+  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_eoi") in
+  GEXTEND Gram
+    e: [ [ x = en; EOI -> x ] ]
+    ;
+  END;
+  e
+
+let map_entry f en =
+  let e = Gram.Entry.create ((Gram.Entry.name en) ^ "_map") in
+  GEXTEND Gram
+    e: [ [ x = en -> f x ] ]
+    ;
+  END;
+  e
+
+(* Parse a string, does NOT check if the entire string was read
+   (use eoi_entry) *)
+
+let parse_string f x =
+  let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm)
+
+type gram_universe = (string, typed_entry) Hashtbl.t
+
+let trace = ref false
+
+(* The univ_tab is not part of the state. It contains all the grammar that
+   exist or have existed before in the session. *)
+
+let univ_tab = (Hashtbl.create 7 : (string, string * gram_universe) Hashtbl.t)
+
+let create_univ s =
+  let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+
+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"
+
+let create_univ_if_new s =
+  (* compatibilite *)
+  let s = if s = "command" then (warning "'command' grammar universe is obsolete; use name 'constr' instead"; "constr") else s in
+  try
+    Hashtbl.find univ_tab s
+  with Not_found -> 
+    if !trace then begin 
+      Printf.eprintf "[Creating univ %s]\n" s; flush stderr; () 
+    end;
+    let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u
+
+let get_univ = create_univ_if_new
+
+let get_entry (u, utab) s =
+  try
+    Hashtbl.find utab s 
+  with Not_found -> 
+    errorlabstrm "Pcoq.get_entry"
+      (str "unknown grammar entry " ++ str u ++ str ":" ++ str s)
+
+let new_entry etyp (u, utab) s =
+  let ename = u ^ ":" ^ s in
+  let e = in_typed_entry etyp (Gram.Entry.create ename) in
+  Hashtbl.add utab s e; e
+
+let entry_type (u, utab) s =
+  try
+    let e = Hashtbl.find utab s in
+    Some (type_of_typed_entry e)
+  with Not_found -> None
+
+let get_entry_type (u,n) =  type_of_typed_entry (get_entry (get_univ u) n)
+
+let create_entry_if_new (u, utab) s etyp =
+  try
+    if type_of_typed_entry (Hashtbl.find utab s) <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type")
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+    let _ = new_entry etyp (u, utab) s in ()
+
+let create_entry (u, utab) s etyp =
+  try
+    let e = Hashtbl.find utab s in
+    if type_of_typed_entry e <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
+    e
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+    new_entry etyp (u, utab) s
+
+let create_constr_entry u s =
+  outGramObj rawwit_constr (create_entry u s ConstrArgType)
+
+let create_generic_entry s wit = 
+  let (u,utab) = utactic in
+  let etyp = unquote wit in
+  try
+    let e = Hashtbl.find utab s in
+    if type_of_typed_entry e <> etyp then
+      failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
+    outGramObj wit e
+  with Not_found ->
+    if !trace then begin
+      Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; ()
+    end;
+  let e = Gram.Entry.create s in
+  Hashtbl.add utab s (inGramObj wit e); e
+
+let get_generic_entry s =
+  let (u,utab) = utactic in
+  try
+    object_of_typed_entry (Hashtbl.find utab s)
+  with Not_found -> 
+    error ("unknown grammar entry "^u^":"^s)
+
+let get_generic_entry_type (u,utab) s =
+  try type_of_typed_entry (Hashtbl.find utab s)
+  with Not_found -> 
+    error ("unknown grammar entry "^u^":"^s)
+
+let force_entry_type (u, utab) s etyp =
+  try
+    let entry = Hashtbl.find utab s in
+    let extyp = type_of_typed_entry entry in
+    if etyp = extyp then 
+      entry
+    else begin
+      prerr_endline
+        ("Grammar entry " ^ u ^ ":" ^ s ^
+         " redefined with another type;\n older entry hidden.");
+      Hashtbl.remove utab s;
+      new_entry etyp (u, utab) s
+    end
+  with Not_found -> 
+    new_entry etyp (u, utab) s
+
+(* [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 *)
+
+let make_gen_entry (u,univ) rawwit s =
+  let e = Gram.Entry.create (u ^ ":" ^ s) in
+  Hashtbl.add univ s (inGramObj rawwit e); e
+
+(* Grammar entries *)
+
+module Prim =
+  struct
+    let gec_gen x = make_gen_entry uprim x
+    
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Typically for tactic or vernac extensions *)
+    let preident = gec_gen rawwit_pre_ident "preident"
+    let ident = gec_gen rawwit_ident "ident"
+    let natural = gec_gen rawwit_int "natural"
+    let integer = gec_gen rawwit_int "integer"
+    let bigint = Gram.Entry.create "Prim.bigint"
+    let string = gec_gen rawwit_string "string"
+    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 name = Gram.Entry.create "Prim.name"
+    let identref = Gram.Entry.create "Prim.identref"
+
+    (* A synonym of ident - maybe ident will be located one day *)
+    let base_ident = Gram.Entry.create "Prim.base_ident"
+
+    let qualid = Gram.Entry.create "Prim.qualid"
+    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
+
+
+module Constr =
+  struct
+    let gec_constr = make_gen_entry uconstr rawwit_constr
+    let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr)
+
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    let constr = gec_constr "constr"
+    let operconstr = gec_constr "operconstr"
+    let constr_eoi = eoi_entry constr
+    let lconstr = gec_constr "lconstr"
+    let binder_constr = create_constr_entry uconstr "binder_constr"
+    let ident = make_gen_entry uconstr rawwit_ident "ident"
+    let global = make_gen_entry uconstr rawwit_ref "global"
+    let sort = make_gen_entry uconstr rawwit_sort "sort"
+    let pattern = Gram.Entry.create "constr:pattern"
+    let annot = Gram.Entry.create "constr:annot"
+    let constr_pattern = gec_constr "constr_pattern"
+    let lconstr_pattern = gec_constr "lconstr_pattern"
+    let binder = Gram.Entry.create "constr:binder"
+    let binder_let = Gram.Entry.create "constr:binder_let"
+  end
+
+module Module =
+  struct
+    let module_expr = Gram.Entry.create "module_expr"
+    let module_type = Gram.Entry.create "module_type"
+  end
+
+module Tactic =
+  struct
+    (* Main entry for extensions *)
+    let simple_tactic = Gram.Entry.create "tactic:simple_tactic"
+
+    (* Entries that can be refered via the string -> Gram.Entry.e table *)
+    (* Typically for tactic user extensions *)
+    let castedopenconstr = 
+      make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr"
+    let constr_with_bindings =
+      make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings"
+    let bindings =
+      make_gen_entry utactic rawwit_bindings "bindings"
+    let constrarg = make_gen_entry utactic rawwit_constr_may_eval "constrarg"
+    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"
+    let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr"
+    let simple_intropattern = 
+      make_gen_entry utactic rawwit_intro_pattern "simple_intropattern"
+
+    (* Main entries for ltac *)
+    let tactic_arg = Gram.Entry.create "tactic:tactic_arg"
+    let tactic = make_gen_entry utactic rawwit_tactic "tactic"
+
+    (* Main entry for quotations *)
+    let tactic_eoi = eoi_entry tactic
+  end
+
+
+module Vernac_ =
+  struct
+    let gec_vernac s = Gram.Entry.create ("vernac:" ^ s)
+
+    (* The different kinds of vernacular commands *)
+    let gallina = gec_vernac "gallina"
+    let gallina_ext = gec_vernac "gallina_ext"
+    let command = gec_vernac "command"
+    let syntax = gec_vernac "syntax_command"
+    let vernac = gec_vernac "Vernac_.vernac"
+
+    let vernac_eoi = eoi_entry vernac
+  end
+
+
+(* 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()
+
+let main_entry = Gram.Entry.create "vernac"
+
+GEXTEND Gram
+  main_entry:
+    [ [ a = Vernac_.vernac -> Some (loc,a) | EOI -> None ] ]
+  ;
+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
+   a reference to the current level (to be translated into "SELF" on the
+   left border and into "constr LEVEL n" elsewhere), to the level below
+   (to be translated into "NEXT") or to an below wrt associativity (to be
+   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 default_levels_v8 =
+  [200,Gramext.RightA;
+   100,Gramext.RightA;
+   99,Gramext.RightA;
+   90,Gramext.RightA;
+   10,Gramext.RightA;
+   9,Gramext.RightA;
+   1,Gramext.LeftA;
+   0,Gramext.RightA]
+
+let default_pattern_levels_v8 =
+  [10,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)]
+
+(* 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
+  | Gramext.LeftA, Some (Gramext.RightA | Gramext.NonA) -> false
+  | Gramext.RightA, Some Gramext.LeftA -> false
+  | _ -> true
+
+let create_assoc = function
+  | None -> Gramext.RightA
+  | Some a -> a
+
+let error_level_assoc p current expected =
+  let pr_assoc = function
+    | Gramext.LeftA -> str "left"
+    | Gramext.RightA -> str "right" 
+    | Gramext.NonA -> str "non" in
+  errorlabstrm ""
+    (str "Level " ++ int p ++ str " is already declared " ++
+     pr_assoc current ++ str " associative while it is now expected to be " ++
+     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 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
+      in
+      try
+	(* Create the entry *)
+	let updated =
+	  if forpat then (ccurrent, add_level default pcurrent)
+	  else (add_level default 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))
+      with
+          Found a ->
+            level_stack := current :: !level_stack;
+	    (* Just inherit the existing associativity and name (None) *)
+	    Some (Gramext.Level (constr_level2 (n,a))), None, None
+
+let remove_levels n =
+  level_stack := list_skipn n !level_stack
+
+(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *)
+let camlp4_assoc = function
+  | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA 
+  | None | Some Gramext.LeftA -> Gramext.LeftA
+
+(* [adjust_level assoc from prod] where [assoc] and [from] are the name
+   and associativity of the level where to add the rule; the meaning of
+   the result is
+
+     None = SELF
+     Some None = NEXT
+     Some (Some (n,cur)) = constr LEVEL n
+         s.t. if [cur] is set then [n] is the same as the [from] level *)
+let adjust_level assoc from = function
+(* Associativity is None means force the level *)
+  | (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))) ->
+      Some None
+  (* If RightA on the right-hand side, set to the explicit (current) level *)
+  | (NumLevel n,BorderProd (false,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
+  (* If the expected assoc is the current one, set to SELF *)
+  | (NumLevel n,BorderProd (true,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)) ->
+      if a = Gramext.LeftA then Some (Some (n,true)) else Some None
+  (* None means NEXT *)
+  | (NextLevel,_) -> Some None
+(* Compute production name elsewhere *)
+  | (NumLevel n,InternalProd) ->
+      match from with
+	| ETConstr (p,()) when p = n+1 -> Some None
+	| 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
+  | ETIdent -> weaken_entry Constr.ident, None, false
+  | ETBigint -> weaken_entry Prim.bigint, None, false
+  | ETReference -> weaken_entry Constr.global, None, false
+  | ETPattern -> weaken_entry Constr.pattern, None, false
+  | ETOther ("constr","annot") -> 
+      weaken_entry Constr.annot, None, false
+  | ETConstrList _ -> error "List of entries cannot be registered"
+  | ETOther (u,n) ->
+      let u = get_univ u in
+      let e =
+        try get_entry u n
+        with e when allow_create -> create_entry u n ConstrArgType in
+      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
+
+(* 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)
+
+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'
+    | (ETIdent,ETIdent | ETReference, ETReference | ETBigint,ETBigint
+      | ETPattern, ETPattern) -> true
+    | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
+    | _ -> false
+
+let is_binder_level from e =
+  match from, e with
+      ETConstr(200,()), ETConstr(NumLevel 200,_) -> not !Options.v7
+    | _ -> 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
+  else
+    match typ with
+    | ETConstrList (typ',[]) ->
+        Gramext.Slist1 (symbol_of_production assoc from forpat (ETConstr typ'))
+    | ETConstrList (typ',tkl) ->
+        Gramext.Slist1sep
+          (symbol_of_production assoc from forpat (ETConstr typ'),
+           Gramext.srules
+             [List.map (fun x -> Gramext.Stoken x) tkl,
+              List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
+                (Gramext.action (fun loc -> ()))])
+    | _ ->
+    match get_constr_production_entry assoc from forpat typ with
+      | (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)
+
+
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
new file mode 100644
index 00000000..5c6c8354
--- /dev/null
+++ b/parsing/pcoq.mli
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pcoq.mli,v 1.63.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+open Util
+open Names
+open Rawterm
+open Ast
+open Genarg
+open Topconstr
+open Tacexpr
+open Vernacexpr
+open Libnames
+open Extend
+
+(* The lexer and parser of Coq. *)
+
+val lexer : Token.lexer
+
+module Gram : Grammar.S with type te = Token.t
+
+type grammar_object
+type typed_entry
+
+val type_of_typed_entry : typed_entry -> Extend.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 ->
+    (string option * Gramext.g_assoc option *
+     (Token.t Gramext.g_symbol list * Gramext.g_action) list) list
+    -> unit
+
+val remove_grammars : int -> unit
+
+val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit
+
+(* Parse a string *)
+
+val parse_string : 'a Gram.Entry.e -> string -> 'a
+val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e
+val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e
+
+(* Entry types *)
+
+(* Table of Coq's grammar entries *)
+
+type gram_universe
+
+val create_univ_if_new : string -> string * gram_universe
+val get_univ : string -> string * gram_universe
+val get_entry : string * gram_universe -> string -> typed_entry
+
+val entry_type : string * gram_universe -> string -> entry_type option
+
+val get_entry_type : string * string -> entry_type
+val create_entry_if_new :
+  string * gram_universe -> string -> entry_type -> unit
+val create_entry :
+  string * gram_universe -> string -> entry_type -> typed_entry
+val force_entry_type :
+  string * gram_universe -> string -> entry_type -> typed_entry
+
+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 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
+
+val entry_type_of_parser : parser_type -> entry_type option
+val parser_type_from_name : string -> parser_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
+
+(* The default parser for actions in grammar rules *)
+
+val default_action_parser : dynamic_grammar Gram.Entry.e
+val set_default_action_parser : parser_type -> unit
+
+(* The main entry: reads an optional vernac command *)
+
+val main_entry : (loc * vernac_expr) option Gram.Entry.e
+
+(* Initial state of the grammar *)
+
+module Prim :
+  sig
+    open Util
+    open Names
+    open Libnames
+    val preident : string Gram.Entry.e
+    val ident : identifier Gram.Entry.e
+    val name : name located Gram.Entry.e
+    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 integer : int Gram.Entry.e
+    val string : string Gram.Entry.e
+    val qualid : qualid 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
+  end
+
+module Constr :
+  sig
+    val constr : constr_expr Gram.Entry.e
+    val constr_eoi : constr_expr Gram.Entry.e
+    val lconstr : constr_expr Gram.Entry.e
+    val binder_constr : constr_expr Gram.Entry.e
+    val operconstr : constr_expr Gram.Entry.e
+    val ident : identifier Gram.Entry.e
+    val global : reference Gram.Entry.e
+    val sort : rawsort Gram.Entry.e
+    val pattern : cases_pattern_expr Gram.Entry.e
+    val annot : constr_expr Gram.Entry.e
+    val constr_pattern : constr_expr Gram.Entry.e
+    val lconstr_pattern : constr_expr Gram.Entry.e
+    val binder : (name located list * constr_expr) Gram.Entry.e
+    val binder_let : local_binder Gram.Entry.e
+  end
+
+module Module : 
+  sig
+    val module_expr : module_ast Gram.Entry.e
+    val module_type : module_type_ast Gram.Entry.e
+  end
+
+module Tactic :
+  sig
+    open Rawterm
+    val castedopenconstr : constr_expr Gram.Entry.e
+    val constr_with_bindings : constr_expr with_bindings Gram.Entry.e
+    val bindings : constr_expr bindings Gram.Entry.e
+    val constrarg : (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 : raw_tactic_expr Gram.Entry.e
+    val tactic_eoi : raw_tactic_expr Gram.Entry.e
+  end
+
+module Vernac_ :
+  sig
+    open Decl_kinds
+    val gallina : vernac_expr Gram.Entry.e
+    val gallina_ext : vernac_expr Gram.Entry.e
+    val command : vernac_expr Gram.Entry.e
+    val syntax : vernac_expr Gram.Entry.e
+    val vernac : vernac_expr Gram.Entry.e
+    val vernac_eoi : vernac_expr Gram.Entry.e
+  end
+
+val reset_all_grammars : unit -> unit
+
+(* Registering/resetting the level of an entry *)
+
+val find_position : 
+  bool -> bool -> Gramext.g_assoc option -> int option ->
+    Gramext.position option * Gramext.g_assoc option * string option
+
+val remove_levels : int -> unit 
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
new file mode 100644
index 00000000..6a5242e8
--- /dev/null
+++ b/parsing/ppconstr.ml
@@ -0,0 +1,388 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.ml,v 1.32.2.1 2004/07/16 19:30:40 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 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 lapp = 10
+let ltop = (8,E)
+
+let prec_less child (parent,assoc) = 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 =
+  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
+
+open Rawterm
+
+let pr_opt pr = function
+  | None -> mt ()
+  | Some x -> spc () ++ pr x
+
+let pr_universe u = str "<univ>"
+
+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_explicitation = function
+  | None -> mt ()
+  | Some (_,ExplByPos n) -> int n ++ str "!"
+  | Some (_,ExplByName n) -> anomaly "Argument made explicit by name"
+
+let pr_expl_args pr (a,expl) =
+  pr_explicitation expl ++ pr (lapp,L) a
+
+let pr_opt_type pr = function
+  | CHole _ -> mt ()
+  | t -> str ":" ++ pr ltop t
+
+let pr_tight_coma () = str "," ++ cut ()
+
+let pr_name = function
+  | Anonymous -> str "_"
+  | Name id -> pr_id id
+
+let pr_located pr (loc,x) = pr x
+
+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
+
+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))
+  | _ -> 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 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 (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
+
+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_recursive fix 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 "}")
+
+let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr)
+let pr_cofix pr = pr_recursive "CoFix" (pr_cofixdecl pr)
+
+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_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_proj pr pr_app a f l =
+  hov 0 (pr (latom,E) 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_app pr a l =
+  hov 0 (
+    pr (lapp,L) a ++ 
+    prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l)
+
+let rec pr 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) *)
+      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 0 (
+	hov 0 (
+	pr_annotation pr po ++
+	  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
+*)
+  | 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
+  | 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
+  | 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 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_occurrences prc (nl,c) = prlist (fun n -> int n ++ spc ()) nl ++ prc c
+
+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
+  | Cbv f ->
+      if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
+	str "Compute"
+      else
+	hov 1 (str "Cbv" ++ spc () ++ pr_red_flag pr_ref f)
+  | Lazy f -> 
+      hov 1 (str "Lazy" ++ spc () ++ 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)
+  | Red true -> error "Shouldn't be accessible from user"
+  | ExtraRedExpr (s,c) ->
+      hov 1 (str s ++ pr_arg pr_constr c)
+
+let rec pr_may_eval pr 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)
+  | 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
+
+let pr_rawconstr c = pr_constr (Constrextern.extern_rawconstr Idset.empty c)
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
new file mode 100644
index 00000000..d238b371
--- /dev/null
+++ b/parsing/ppconstr.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.mli,v 1.7.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Environ
+open Term
+open Libnames
+open Pcoq
+open Rawterm
+open Extend
+open Coqast
+open Topconstr
+open Names
+open Util
+
+val split_fix : int -> constr_expr -> constr_expr -> 
+  (name located list * constr_expr) list * constr_expr * constr_expr
+
+val pr_global : Idset.t -> global_reference -> std_ppcmds
+
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+val pr_name : name -> std_ppcmds
+val pr_qualid : qualid -> std_ppcmds
+val pr_red_expr :
+  ('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
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
new file mode 100644
index 00000000..95e134ae
--- /dev/null
+++ b/parsing/pptactic.ml
@@ -0,0 +1,758 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pptactic.ml,v 1.54.2.2 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Names
+open Nameops
+open Util
+open Extend
+open Tacexpr
+open Rawterm
+open Topconstr
+open Genarg
+open Libnames
+open Pattern
+
+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
+
+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
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) -> (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
+type 'a extra_genarg_printer =
+    (Term.constr -> std_ppcmds) -> (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 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 pr_arg pr x = spc () ++ pr x
+
+let pr_or_var pr = function
+  | ArgArg x -> pr x
+  | ArgVar (_,s) -> pr_id s
+
+let pr_or_metaid pr = function
+  | AI x -> pr x
+  | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable"
+
+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 
+
+let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h
+
+let pr_binding prc = function
+  | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+
+let pr_bindings prc prlc = function
+  | ImplicitBindings l ->
+      brk (1,1) ++ str "with" ++ brk (1,1) ++
+      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
+  | NoBindings -> mt ()
+
+let pr_bindings_no_with prc prlc = function
+  | ImplicitBindings l ->
+      brk (1,1) ++
+      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
+  | 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)
+
+let pr_with_constr prc = function
+  | None -> mt ()
+  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
+
+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 pr_autoarg_usingTDB = function
+  | true -> spc () ++ str "Using TDB"
+  | false -> mt ()
+
+let rec pr_raw_generic prc prlc prtac prref x =
+  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)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen rawwit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen rawwit_string x) ++ str "\""
+  | 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)
+  | RefArgType -> pr_arg prref (out_gen rawwit_ref x)
+  | SortArgType -> pr_arg pr_sort (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)
+  | 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)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (out_gen rawwit_casted_open_constr x)
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen rawwit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen rawwit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_raw_generic prc prlc prtac prref x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prref) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_raw_generic prc prlc prtac prref a ++ spc () ++ 
+            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
+      with Not_found -> str " [no printer for " ++ str s ++ str "] "
+
+
+let rec pr_glob_generic prc prlc prtac x =
+  match Genarg.genarg_tag x with
+  | BoolArgType -> pr_arg str (if out_gen globwit_bool x then "true" else "false")
+  | IntArgType -> pr_arg int (out_gen globwit_int x)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen globwit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen globwit_string x) ++ str "\""
+  | 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)
+  | 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)
+  | 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)
+  | 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)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (out_gen globwit_casted_open_constr x)
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen globwit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen globwit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_glob_generic prc prlc prtac x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_glob_generic prc prlc prtac a ++ spc () ++ 
+            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
+      with Not_found -> str " [no printer for " ++ str s ++ str "] "
+
+open Closure
+
+let rec pr_generic prc prlc prtac x =
+  match Genarg.genarg_tag x with
+  | BoolArgType -> pr_arg str (if out_gen wit_bool x then "true" else "false")
+  | IntArgType -> pr_arg int (out_gen wit_int x)
+  | IntOrVarArgType -> pr_arg (pr_or_var pr_int) (out_gen wit_int_or_var x)
+  | StringArgType -> spc () ++ str "\"" ++ str (out_gen wit_string x) ++ str "\""
+  | 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)
+  | RefArgType -> pr_arg pr_global (out_gen wit_ref x)
+  | SortArgType -> pr_arg prc (Term.mkSort (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)
+  | CastedOpenConstrArgType ->
+      pr_arg prc (snd (out_gen wit_casted_open_constr x))
+  | ConstrWithBindingsArgType -> 
+      pr_arg (pr_with_bindings prc prlc) (out_gen wit_constr_with_bindings x)
+  | BindingsArgType -> 
+      pr_arg (pr_bindings_no_with prc prlc) (out_gen wit_bindings x)
+  | List0ArgType _ -> 
+      hov 0 (fold_list0 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt()))
+  | List1ArgType _ ->
+      hov 0 (fold_list1 (fun x a -> pr_generic prc prlc prtac x ++ a) x (mt()))
+  | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac) (mt()) x)
+  | PairArgType _ ->
+      hov 0
+        (fold_pair
+	  (fun a b -> pr_generic prc prlc prtac a ++ spc () ++ 
+            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
+      with Not_found -> str " [no printer for " ++ str s ++ str "]"
+
+let rec pr_tacarg_using_rule pr_gen = function
+  | Some s :: l, al -> spc () ++ str s ++ pr_tacarg_using_rule pr_gen (l,al)
+  | None :: l, a :: al -> pr_gen a ++ pr_tacarg_using_rule  pr_gen (l,al)
+  | [], [] -> 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
+  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)
+  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_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_intarg n = spc () ++ int n 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"
+  | 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)
+
+  (* Basic tactics *)
+  | TacIntroPattern [] as t -> pr_atom0 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 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_id 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)
+  | TacElim (cb,cbo) ->
+      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)
+  | 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)
+  | 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)
+  | TacGeneralize 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)
+  | 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)
+  (* 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)
+  | 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)
+  | 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_arg pr_constr c)
+  | TacDecomposeOr c ->
+      hov 1 (str "Decompose Sum" ++ pr_arg pr_constr c)
+  | TacDecompose (l,c) ->
+      hov 1 (str "Decompose" ++ spc () ++
+        hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
+	  ++ str "]" ++ pr_arg pr_constr c))
+  | TacSpecialize (n,c) ->
+      hov 1 (str "Specialize" ++ pr_opt int n ++ pr_with_bindings c)
+  | TacLApply c -> 
+      hov 1 (str "LApply" ++ pr_constr 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 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)
+  | TacDAuto (n,p) ->
+      hov 1 (str "Auto" ++ pr_opt 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 l)
+  | TacRight l -> hov 1 (str "Right" ++ pr_bindings l)
+  | TacSplit (_,l) -> hov 1 (str "Split" ++ pr_bindings l)
+  | TacAnyConstructor (Some t) ->
+      hov 1 (str "Constructor" ++ pr_arg pr_tac0 t)
+  | TacAnyConstructor None as t -> pr_atom0 t
+  | TacConstructor (n,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)
+
+  (* 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
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,ids),hyp) ->
+      hov 1 (str "Dependent " ++ pr_induction_kind k ++ 
+      pr_quantified_hypothesis hyp ++
+      pr_with_names ids ++ pr_with_constr pr_constr 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 ++ 
+      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
+  | TacAbstract (t,Some s) -> 
+      hov 0
+       (str "Abstract " ++ pr6 t ++ spc () ++ str "using" ++ spc () ++ pr_id s)
+  | TacLetRecIn (l,t) -> 
+      hv 0
+        (str "Rec " ++ pr_rec_clauses prtac l ++
+        spc () ++ str "In" ++ fnl () ++ prtac t)
+  | 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"
+        ++ 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")
+	++ prlist
+	  (fun r -> fnl () ++ str "|" ++ spc () ++
+            pr_match_rule false pr_pat prtac r)
+	lrul)
+  | 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
+  | 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)
+
+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_inductive,
+     pr_ltac_constant,
+     pr_id,
+     pr_extend)
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
new file mode 100644
index 00000000..a80ec6fb
--- /dev/null
+++ b/parsing/pptactic.mli
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: pptactic.mli,v 1.9.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Genarg
+open Tacexpr
+open Pretyping
+open Proof_type
+open Topconstr
+open Rawterm
+
+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
+
+type 'a glob_extra_genarg_printer =
+    (rawconstr_and_expr -> std_ppcmds) -> (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
+
+  (* 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
+
+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 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) ->
+  (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
+
+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
+
+val pr_extend :
+  (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
+  (glob_tactic_expr -> std_ppcmds) -> string -> closed_generic_argument list -> std_ppcmds
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
new file mode 100644
index 00000000..169eff94
--- /dev/null
+++ b/parsing/prettyp.ml
@@ -0,0 +1,605 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: prettyp.ml,v 1.50.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Inductive
+open Inductiveops
+open Sign
+open Reduction
+open Environ
+open Instantiate
+open Declare
+open Impargs
+open Libobject
+open Printer
+open Printmod
+open Libnames
+open Nametab
+
+(*********************)
+(** Basic printing   *)
+
+let print_basename sp = pr_global (ConstRef sp)
+
+let print_closed_sections = ref false
+
+(********************************)
+(** Printing implicit arguments *)
+			  		  
+let print_impl_args_by_pos = function
+  | []  -> mt ()
+  | [i] -> str"Position [" ++ int i ++ str"] is implicit" ++ fnl()
+  | l   -> 
+      str"Positions [" ++ 
+      prlist_with_sep (fun () -> str "; ") int l ++
+      str"] are implicit" ++ fnl()
+
+let print_impl_args_by_name = function
+  | []  -> mt ()
+  | [i] -> str"Argument " ++ pr_id (name_of_implicit i) ++ str" is implicit" ++
+      fnl()
+  | l   -> 
+      str"Arguments " ++ 
+      prlist_with_sep (fun () -> str ", ")
+        (fun imp -> pr_id (name_of_implicit imp)) l ++
+      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)
+
+(*********************)
+(** Printing Scopes  *)
+
+let print_ref reduce ref =
+  let typ = Global.type_of_global ref in
+  let typ = 
+    if reduce then
+      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 ()
+
+let print_argument_scopes = function
+  | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl()
+  | l when not (List.for_all ((=) None) l) ->
+      hov 2 (str"Argument scopes are" ++ spc() ++ 
+      str "[" ++ 
+      prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++
+      str "]") ++ fnl()
+  | _  -> mt()
+
+let need_expansion impl ref = 
+  let typ = Global.type_of_global ref in
+  let ctx = fst (decompose_prod_assum typ) in
+  let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in
+  impl <> [] & let _,lastimpl = list_chop nprods impl in
+  List.filter is_status_implicit lastimpl <> []
+
+let print_name_infos ref =
+  let impl = implicits_of_global ref in
+  let scopes = Symbols.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 *)
+      str "Expanded type for implicit arguments" ++ fnl () ++ 
+      print_ref true ref ++ fnl()
+    else mt() in
+  (if (List.filter is_status_implicit impl<>[])
+      or not (List.for_all ((=) None) scopes) 
+  then fnl()
+  else mt())
+  ++ type_for_implicit 
+  ++ print_impl_args impl ++ print_argument_scopes scopes
+
+let print_id_args_data test pr id l =
+  if List.exists test l then
+    str"For " ++ pr_id id ++ str": " ++ pr l
+  else 
+    mt()
+
+let print_args_data_of_inductive_ids get test pr sp mipv =
+  prvecti
+    (fun i mip -> 
+      print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) ++
+      prvecti 
+	(fun j idc ->
+	  print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1))))
+        mip.mind_consnames)
+    mipv
+
+let print_inductive_implicit_args =
+  print_args_data_of_inductive_ids
+    implicits_of_global is_status_implicit print_impl_args
+
+let print_inductive_argument_scopes =
+  print_args_data_of_inductive_ids 
+    Symbols.find_arguments_scope ((<>) None) print_argument_scopes
+
+(*********************)
+(* "Locate" commands *)
+
+type logical_name =
+  | Term of global_reference
+  | Dir of global_dir_reference
+  | Syntactic of kernel_name
+  | ModuleType of qualid * kernel_name
+  | Undefined of qualid
+
+let locate_any_name ref =
+  let module N = Nametab in
+  let (loc,qid) = qualid_of_reference ref in
+  try Term (N.locate qid)
+  with Not_found -> 
+  try Syntactic (N.locate_syntactic_definition qid)
+  with Not_found ->
+  try Dir (N.locate_dir qid)
+  with Not_found ->
+  try ModuleType (qid, N.locate_modtype qid)
+  with Not_found -> Undefined qid
+
+let pr_located_qualid = function
+  | Term ref ->
+      let ref_str = match ref with
+	  ConstRef _ -> "Constant"
+	| IndRef _ -> "Inductive"
+	| ConstructRef _ -> "Constructor"
+	| 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)
+  | Dir dir ->
+      let s,dir = match dir with
+	| DirOpenModule (dir,_) -> "Open Module", dir
+	| DirOpenModtype (dir,_) -> "Open Module Type", dir
+	| DirOpenSection (dir,_) -> "Open Section", dir
+	| DirModule (dir,_) -> "Module", dir
+	| DirClosedSection dir -> "Closed Section", dir
+      in
+      str s ++ spc () ++ pr_dirpath dir
+  | ModuleType (qid,_) ->
+      str "Module Type" ++ spc () ++ pr_sp (Nametab.full_name_modtype qid)
+  | Undefined qid ->    
+      pr_qualid qid ++ str " is not a defined object"
+
+let print_located_qualid ref =
+  let (loc,qid) = qualid_of_reference ref in
+  let module N = Nametab in
+  let expand = function
+    | TrueGlobal ref -> Term ref, N.shortest_qualid_of_global Idset.empty ref
+    | SyntacticDef kn -> Syntactic kn, N.shortest_qualid_of_syndef kn in
+  match List.map expand (N.extended_locate_all qid) with
+    | [] -> 
+	let (dir,id) = repr_qualid qid in
+	if dir = empty_dirpath then
+	  str "No object of basename " ++ pr_id id
+	else
+	  str "No object of suffix " ++ pr_qualid qid
+    | l ->
+	prlist_with_sep fnl
+	(fun (o,oqid) ->
+	  hov 2 (pr_located_qualid o ++
+	  (if oqid <> qid then
+	    spc() ++ str "(visible as " ++ pr_qualid oqid ++ str")"
+	  else
+	    mt ()))) l
+
+(******************************************)
+(**** Printing declarations and judgments *)
+
+let print_typed_value_in_env env (trm,typ) =
+  (prterm_env env trm ++ fnl () ++
+     str "     : " ++ prtype_env env typ ++ fnl ())
+
+let print_typed_value x = print_typed_value_in_env (Global.env ()) x
+
+let print_judgment env {uj_val=trm;uj_type=typ} =
+  print_typed_value_in_env env (trm, typ)
+    
+let print_safe_judgment env j =
+  let trm = Safe_typing.j_val j in
+  let typ = Safe_typing.j_type j in
+  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
+   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
+  (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 ())
+
+let print_named_decl (id,c,typ) =
+  let s = string_of_id id in
+  match c with
+    | Some body -> print_named_def s body typ
+    | None -> print_named_assum s typ
+
+let assumptions_for_print lna =
+  List.fold_right (fun na env -> add_name na env) lna empty_names_context
+
+(*********************)
+(* *)
+
+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))
+
+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)
+      (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 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 cstrtypes = arities_of_constructors env (sp,tyi) in
+  let cstrtypes =
+    Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
+  let cstrnames = mip.mind_consnames in
+  (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes)
+
+let print_one_inductive (sp,tyi) =
+  let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in
+  let env = Global.env () in
+  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 " :=") ++
+  brk(0,2) ++ print_constructors envpar cstrnames cstrtypes
+
+let pr_mutual_inductive finite indl =
+  hov 0 (
+    str (if finite then "Inductive " else "CoInductive ") ++
+    prlist_with_sep (fun () -> fnl () ++ str"  with ")
+      print_one_inductive indl) ++
+  fnl ()
+
+let print_mutual sp =
+  let (mib,mip) = Global.lookup_inductive (sp,0) in
+  let mipv = mib.mind_packets in
+  let names = list_tabulate (fun x -> (sp,x)) (Array.length mipv) in
+  pr_mutual_inductive mib.mind_finite names ++
+  print_inductive_implicit_args sp mipv ++
+  print_inductive_argument_scopes sp mipv
+
+let print_section_variable sp =
+  let d = get_variable sp in
+  print_named_decl d ++ 
+  print_name_infos (VarRef sp)
+
+let print_body = function
+  | Some lc  -> prterm (Declarations.force lc)
+  | None -> (str"<no body>")
+
+let print_typed_body (val_0,typ) =
+  (print_body val_0 ++ fnl () ++ str "     : " ++ prtype typ ++ fnl ())
+
+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
+  hov 0 (
+    match val_0 with 
+    | None -> 
+	str"*** [ " ++ 
+	print_basename sp ++ str " : " ++ cut () ++ prtype typ ++ 
+	str" ]" ++ fnl ()
+    | _ -> 
+	print_basename sp ++ str sep ++ cut () ++
+	(if with_values then print_typed_body (val_0,typ) else prtype typ) ++
+	fnl ())
+
+let print_constant_with_infos sp =
+  print_constant true " = " sp ++ print_name_infos (ConstRef sp)
+
+let print_inductive sp = (print_mutual sp)
+
+let print_syntactic_def sep kn =
+  let qid = Nametab.shortest_qualid_of_syndef 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 ())
+
+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))
+    | (_,"CONSTANT") ->
+	Some (print_constant with_values sep kn)
+    | (_,"INDUCTIVE") ->
+	Some (print_inductive kn)
+    | (_,"MODULE") ->
+	let (mp,_,l) = repr_kn kn in 
+	Some (print_module with_values (MPdot (mp,l)))
+    | (_,"MODULE TYPE") ->
+	Some (print_modtype kn)
+    | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"|
+	"COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None
+    (* To deal with forgotten cases... *)
+    | (_,s) -> None
+(*
+    | (_,s) -> 
+	(str(string_of_path sp) ++ str" : " ++
+           str"Unrecognized object " ++ str s ++ fnl ())
+*)
+
+let rec print_library_entry with_values ent = 
+  let sep = if with_values then " = " else " : " in 
+  let pr_name (sp,_) = pr_id (basename sp) in
+  match ent with
+    | (oname,Lib.Leaf lobj) -> 
+	print_leaf_entry with_values sep (oname,lobj)
+    | (oname,Lib.OpenedSection (dir,_)) -> 
+        Some (str " >>>>>>> Section " ++ pr_name oname)
+    | (oname,Lib.ClosedSection _) -> 
+        Some (str " >>>>>>> Closed Section " ++ pr_name oname)
+    | (_,Lib.CompilingLibrary (dir,_)) ->
+	Some (str " >>>>>>> Library " ++ pr_dirpath dir)
+    | (oname,Lib.OpenedModule _) ->
+	Some (str " >>>>>>> Module " ++ pr_name oname)
+    | (oname,Lib.OpenedModtype _) ->
+	Some (str " >>>>>>> Module Type " ++ pr_name oname)
+    | (_,Lib.FrozenState _) ->
+	None
+	
+let print_context with_values = 
+  let rec prec n = function
+    | 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 ())
+    | _ -> mt ()
+  in 
+  prec
+
+let print_full_context () = 
+  print_context true None (Lib.contents_after None)
+
+let print_full_context_typ () =
+  print_context false None (Lib.contents_after None)
+
+(* For printing an inductive definition with
+   its constructors and elimination,
+   assume that the declaration of constructors and eliminations
+   follows the definition of the inductive type *)
+
+let list_filter_vec f vec = 
+  let rec frec n lf = 
+    if n < 0 then lf 
+    else if f vec.(n) then 
+      frec (n-1) (vec.(n)::lf)
+    else 
+      frec (n-1) lf
+  in 
+  frec (Array.length vec -1) []
+
+(* This is designed to print the contents of an opened section *)
+let read_sec_context r =
+  let loc,qid = qualid_of_reference r in
+  let dir =
+    try Nametab.locate_section qid
+    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 ->
+        if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
+    | ((_,Lib.ClosedSection (_,_,ctxt)) as hd)::rest ->
+        error "Cannot print the contents of a closed section"
+    | [] -> []
+    | hd::rest -> get_cxt (hd::in_cxt) rest 
+  in
+  let cxt = (Lib.contents_after None) in
+  List.rev (get_cxt [] cxt)
+
+let print_sec_context sec = 
+  print_context true None (read_sec_context sec)
+
+let print_sec_context_typ sec =
+  print_context false None (read_sec_context sec)
+
+let print_eval red_fun env {uj_val=trm;uj_type=typ} =
+  let ntrm = red_fun env Evd.empty trm in
+  (str "     = " ++ print_judgment env {uj_val = ntrm; uj_type = typ})
+
+let print_name ref = 
+  match locate_any_name ref with
+  | Term (ConstRef sp) -> print_constant_with_infos sp
+  | Term (IndRef (sp,_)) -> print_inductive sp
+  | Term (ConstructRef ((sp,_),_)) -> print_inductive sp
+  | Term (VarRef sp) -> print_section_variable sp
+  | Syntactic kn -> print_syntactic_def " := " kn
+  | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp
+  | Dir _ -> mt ()
+  | ModuleType (_,kn) -> print_modtype kn
+  | Undefined qid ->
+  try  (* Var locale de but, pas var de section... donc pas d'implicits *)
+    let dir,str = repr_qualid qid in 
+    if (repr_dirpath dir) <> [] then raise Not_found;
+    let (_,c,typ) = Global.lookup_named str in 
+    (print_named_decl (str,c,typ))
+  with Not_found ->
+  try 
+    let sp = Nametab.locate_obj qid in
+    let (oname,lobj) = 
+      let (oname,entry) =
+	List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None)
+      in
+      match entry with
+	| Lib.Leaf obj -> (oname,obj)
+	| _ -> raise Not_found
+    in
+    match print_leaf_entry true " = " (oname,lobj) with
+      | None -> mt ()
+      | Some pp -> pp ++ fnl()
+  with Not_found ->
+    errorlabstrm
+      "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
+        if cb.const_body <> None then
+	  print_constant_with_infos cst
+        else 
+	  error "not a defined constant"
+    | IndRef (sp,_) ->
+        print_mutual sp
+    | ConstructRef cstr -> 
+	let ty = Inductive.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
+  ++
+  hov 0 (str "Expands to: " ++ pr_located_qualid k)
+
+let print_impargs ref =
+  let ref = Nametab.global ref in
+  let impl = implicits_of_global ref in
+  let has_impl = List.filter is_status_implicit impl <> [] in
+  (* Need to reduce since implicits are computed with products flattened *)
+  print_ref (need_expansion impl ref) ref ++ fnl() ++
+  (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 
+    | Lambda (na,t,b) -> mkLambda (na,t,unfrec b)
+    | App (f,v) -> appvect (unfrec f,v)
+    | _ -> k
+  in 
+  unfrec
+
+(* for debug *)
+let inspect depth = 
+  print_context false (Some depth) (Lib.contents_after None)
+
+
+(*************************************************************************)
+(* Pretty-printing functions coming from classops.ml                     *)
+
+open Classops
+
+let print_coercion_value v = prterm (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)
+
+let _ = Classops.install_path_printer print_path
+
+let print_graph () = 
+  prlist_with_sep pr_fnl print_path (inheritance_graph())
+
+let print_classes () = 
+  prlist_with_sep pr_spc pr_class (classes())
+
+let print_coercions () = 
+  prlist_with_sep pr_spc print_coercion_value (coercions())
+  
+let index_of_class cl =
+  try 
+    fst (class_info cl)
+  with _ -> 
+    errorlabstrm "index_of_class" (pr_class cl ++ str" is not a defined class")
+
+let print_path_between cls clt = 
+  let i = index_of_class cls in
+  let j = index_of_class clt in
+  let p = 
+    try 
+      lookup_path_between (i,j) 
+    with _ -> 
+      errorlabstrm "index_cl_of_id"
+        (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt)
+  in
+  print_path ((i,j),p)
+
+(*************************************************************************)
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
new file mode 100644
index 00000000..c8471330
--- /dev/null
+++ b/parsing/prettyp.mli
@@ -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: prettyp.mli,v 1.12.2.1 2004/07/16 19:30:40 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Sign
+open Term
+open Environ
+open Reductionops
+open Libnames
+open Nametab
+(*i*)
+
+(* A Pretty-Printer for the Calculus of Inductive Constructions. *)
+
+val assumptions_for_print : name list -> Termops.names_context
+
+val print_closed_sections : bool ref
+val print_impl_args : Impargs.implicits_list -> std_ppcmds
+val print_context : bool -> int option -> Lib.library_segment -> std_ppcmds
+val print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option
+val print_full_context : unit -> std_ppcmds
+val print_full_context_typ : unit -> std_ppcmds
+val print_sec_context : reference -> std_ppcmds
+val print_sec_context_typ : reference -> std_ppcmds
+val print_judgment : env -> unsafe_judgment -> std_ppcmds
+val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds
+val print_eval :
+  reduction_function -> env -> unsafe_judgment -> std_ppcmds
+(* This function is exported for the graphical user-interface pcoq *)
+val build_inductive : mutual_inductive -> int ->
+  global_reference * rel_context * types * identifier array * types array
+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
+
+(*i
+val print_extracted_name : identifier -> std_ppcmds
+val print_extraction : unit -> std_ppcmds
+val print_extracted_vars : unit -> std_ppcmds
+i*)
+
+(* Pretty-printing functions for classes and coercions *)
+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 inspect : int -> std_ppcmds
+
+(* Locate *)
+val print_located_qualid : reference -> std_ppcmds
diff --git a/parsing/printer.ml b/parsing/printer.ml
new file mode 100644
index 00000000..dfacc764
--- /dev/null
+++ b/parsing/printer.ml
@@ -0,0 +1,249 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: printer.ml,v 1.58.2.1 2004/07/16 19:30:40 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Global
+open Declare
+open Coqast
+open Ast
+open Termast
+open Libnames
+open Extend
+open Nametab
+open Ppconstr
+
+let emacs_str s = if !Options.print_emacs then s else "" 
+
+(**********************************************************************)
+(* 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
+
+(**********************************************************************)
+(* Generic printing: choose old or new printers *)
+
+(* [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)
+
+(**********************************************************************)
+(* 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
+
+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
+	(str" := " ++ pb ++ cut () ) in
+  let pt = prtype_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 = prterm_env env c in
+	(str":=" ++ spc () ++ pb ++ spc ()) in
+  let ptyp = prtype_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)
+
+
+(* Prints out an "env" in a nice format.  We print out the
+ * signature,then a horizontal bar, then the debruijn environment.
+ * It's printed out from outermost to innermost, so it's readable. *)
+
+(* Prints a signature, all declarations on the same line if possible *)
+let pr_named_context_of env =
+  hv 0 (fold_named_context
+	  (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d)
+          env ~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::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)
+  in 
+  hov 0 (prec env (List.rev rel_context))
+
+(* Prints an env (variables and de Bruijn). Separator: newline *)
+let pr_context_unlimited 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 pr_ne_context_of header env =
+  if Environ.rel_context env = empty_rel_context &
+    Environ.named_context env = empty_named_context  then (mt ())
+  else let penv = pr_context_unlimited env in (header ++ penv ++ fnl ())
+
+let pr_context_limit n env =
+  let named_context = Environ.named_context env in
+  let lgsign = List.length named_context in
+  if n >= lgsign then 
+    pr_context_unlimited env
+  else
+    let k = lgsign-n in
+    let _,sign_env =
+      fold_named_context
+        (fun env d (i,pps) ->
+           if i < k then 
+	     (i+1, (pps ++str "."))
+	   else
+             let pidt = pr_var_decl env d in
+	     (i+1, (pps ++ fnl () ++
+		      str (emacs_str (String.make 1 (Char.chr 253))) ++
+		      pidt)))
+        env ~init:(0,(mt ())) 
+    in
+    let db_env =
+      fold_rel_context
+        (fun env d pps ->
+           let pnat = pr_rel_decl env d in
+	   (pps ++ fnl () ++
+	      str (emacs_str (String.make 1 (Char.chr 253))) ++
+	      pnat))
+        env ~init:(mt ())
+    in 
+    (sign_env ++ db_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)
diff --git a/parsing/printer.mli b/parsing/printer.mli
new file mode 100644
index 00000000..b4cd87b0
--- /dev/null
+++ b/parsing/printer.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: printer.mli,v 1.26.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Libnames
+open Term
+open Sign
+open Environ
+open Rawterm
+open Pattern
+open Nametab
+open Termops
+(*i*)
+
+(* These are the entry points for printing terms, context, tac, ... *)
+(*
+val gentacpr  : Tacexpr.raw_tactic_expr -> std_ppcmds
+*)
+
+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
+
diff --git a/parsing/printmod.ml b/parsing/printmod.ml
new file mode 100644
index 00000000..aaf4a662
--- /dev/null
+++ b/parsing/printmod.ml
@@ -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        *)
+(************************************************************************)
+
+open Pp
+open Util
+open Names
+open Declarations
+open Nameops
+open Libnames
+
+let get_new_id locals id = 
+  let rec get_id l id = 
+    let dir = make_dirpath [id] in
+      if not (Nametab.exists_module dir) then
+	id
+      else
+	get_id (id::l) (Nameops.next_ident_away id l)
+  in
+    get_id (List.map snd locals) id
+
+let rec print_local_modpath locals = function
+  | MPbound mbid -> pr_id (List.assoc mbid locals)
+  | MPdot(mp,l) ->
+      print_local_modpath locals mp ++ str "." ++ pr_lab l
+  | MPself _ | MPfile _ -> raise Not_found
+
+let print_modpath locals mp = 
+  try (* must be with let because streams are lazy! *)
+    let qid = Nametab.shortest_qualid_of_module mp in 
+      pr_qualid qid
+  with
+    | Not_found -> print_local_modpath locals mp
+
+let print_kn locals kn = 
+  try
+    let qid = Nametab.shortest_qualid_of_modtype kn in 
+      pr_qualid qid
+  with
+      Not_found -> 
+	let (mp,_,l) = repr_kn kn in
+	  print_local_modpath locals mp ++ str"." ++ pr_lab l
+
+let rec flatten_app mexpr l = match mexpr with
+  | MEBapply (mexpr,marg,_) -> flatten_app mexpr (marg::l)
+  | mexpr -> mexpr::l
+
+let rec print_module name locals with_body mb =
+  let body = match mb.mod_equiv, with_body, mb.mod_expr with 
+    | None, false, _ 
+    | None, true, None -> mt()
+    | None, true, Some mexpr -> 
+	spc () ++ str ":= " ++ print_modexpr locals mexpr
+    | Some mp, _, _ -> str " == " ++ print_modpath locals mp
+  in
+  hv 2 (str "Module " ++ name ++ spc () ++ str": " ++ 
+	print_modtype locals mb.mod_type ++ body)
+
+and print_modtype locals mty = match mty with
+  | MTBident kn -> print_kn locals kn
+  | MTBfunsig (mbid,mtb1,mtb2) ->
+(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env 
+      in *) 
+      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
+      hov 2 (str "Funsig" ++ spc () ++ str "(" ++ 
+        pr_id (id_of_mbid mbid) ++ str " : " ++ print_modtype locals mtb1 ++ 
+      str ")" ++ spc() ++ print_modtype locals' mtb2)
+  | MTBsig (msid,sign) -> 
+      hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End")
+
+and print_sig locals msid sign = 
+  let print_spec (l,spec) = (match spec with
+    | SPBconst {const_body=Some _; const_opaque=false} -> str "Definition "
+    | SPBconst {const_body=None}
+    | SPBconst {const_opaque=true} -> str "Parameter "
+    | SPBmind _ -> str "Inductive "
+    | SPBmodule _ -> str "Module "
+    | SPBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
+  in
+    prlist_with_sep spc print_spec sign
+
+and print_struct locals msid struc = 
+  let print_body (l,body) = (match body with
+    | SEBconst {const_body=Some _; const_opaque=false} -> str "Definition "
+    | SEBconst {const_body=Some _; const_opaque=true} -> str "Theorem "
+    | SEBconst {const_body=None} -> str "Parameter "
+    | SEBmind _ -> str "Inductive "
+    | SEBmodule _ -> str "Module "
+    | SEBmodtype _ -> str "Module Type ") ++ str (string_of_label l)
+  in
+    prlist_with_sep spc print_body struc
+
+and print_modexpr locals mexpr = match mexpr with 
+  | MEBident mp -> print_modpath locals mp
+  | MEBfunctor (mbid,mty,mexpr) ->
+(*    let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env 
+      in *)
+      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
+      hov 2 (str "Functor" ++ spc() ++ str"[" ++ pr_id(id_of_mbid mbid) ++ 
+	     str ":" ++ print_modtype locals mty ++ 
+      str "]" ++ spc () ++ print_modexpr locals' mexpr)
+  | MEBstruct (msid, struc) -> 
+      hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End")
+  | MEBapply (mexpr,marg,_) -> 
+      let lapp = flatten_app mexpr [marg] in
+	hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")")
+
+
+
+let rec printable_body dir =     
+  let dir = dirpath_prefix dir in
+    dir = empty_dirpath || 
+    try 
+      match Nametab.locate_dir (qualid_of_dirpath dir) with
+	  DirOpenModtype _ -> false
+	| DirModule _ | DirOpenModule _ -> printable_body dir
+	| _ -> true
+    with 
+	Not_found -> true
+
+
+let print_module with_body mp = 
+  let name = print_modpath [] mp in
+    print_module name [] with_body (Global.lookup_module mp) ++ fnl ()
+
+let print_modtype kn = 
+  let name = print_kn [] kn in
+    str "Module Type " ++ name ++ str " = " ++ 
+      print_modtype [] (Global.lookup_modtype kn) ++ fnl ()
diff --git a/parsing/printmod.mli b/parsing/printmod.mli
new file mode 100644
index 00000000..2df0581c
--- /dev/null
+++ b/parsing/printmod.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Pp
+open Names
+
+(* false iff the module is an element of an open module type *)
+val printable_body : dir_path -> bool
+
+val print_module : bool -> module_path -> std_ppcmds
+
+val print_modtype : kernel_name -> std_ppcmds
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
new file mode 100644
index 00000000..aa0fce9d
--- /dev/null
+++ b/parsing/q_coqast.ml4
@@ -0,0 +1,567 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: q_coqast.ml4,v 1.47.2.2 2004/07/16 20:51:12 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Q_util
+
+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 anti loc x =
+  let e =
+    let loc = unloc loc in
+    let loc = make_loc (1, snd loc - fst loc) in <:expr< $lid:purge_str 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
+
+let dloc = <:expr< Util.dummy_loc >>
+
+let mlexpr_of_ident id =
+  <:expr< Names.id_of_string $str:Names.string_of_id id$ >>
+
+let mlexpr_of_name = function
+  | Names.Anonymous -> <:expr< Names.Anonymous >>
+  | Names.Name id -> 
+      <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >>
+
+let mlexpr_of_dirpath dir =
+  let l = Names.repr_dirpath dir in
+  <:expr< Names.make_dirpath $mlexpr_of_list mlexpr_of_ident l$ >>
+
+let mlexpr_of_qualid qid =
+  let (dir, id) = repr_qualid qid in
+  <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >>
+
+let mlexpr_of_reference = function
+  | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >>
+  | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >>
+
+let mlexpr_of_intro_pattern = function
+  | Genarg.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO"
+  | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
+  | Genarg.IntroIdentifier id ->
+      <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
+
+let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident)
+
+let mlexpr_of_or_metaid f = function
+  | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >>
+  | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >>
+
+let mlexpr_of_quantified_hypothesis = function
+  | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >>
+  | Rawterm.NamedHyp id ->  <:expr< Rawterm.NamedHyp $mlexpr_of_ident id$ >>
+
+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$ >>
+
+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_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)) >>
+
+let mlexpr_of_clause cl =
+  <:expr< {Tacexpr.onhyps=
+             $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location)
+               cl.Tacexpr.onhyps$;
+           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;
+  Rawterm.rZeta = bz;
+  Rawterm.rDelta = bd;
+  Rawterm.rConst = l
+} = <:expr< {
+  Rawterm.rBeta = $mlexpr_of_bool bb$;
+  Rawterm.rIota = $mlexpr_of_bool bi$;
+  Rawterm.rZeta = $mlexpr_of_bool bz$;
+  Rawterm.rDelta = $mlexpr_of_bool bd$;
+  Rawterm.rConst = $mlexpr_of_list mlexpr_of_reference l$
+} >>
+
+let mlexpr_of_explicitation = function
+  | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >>
+  | Topconstr.ExplByPos n -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >>
+ 
+let rec mlexpr_of_constr = function
+  | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) ->
+      anti loc (string_of_id id)
+  | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >>
+  | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Topconstr.CArrow (loc,a,b) ->
+  <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >>
+  | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
+  | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
+  | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | 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$
+                $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Topconstr.CPatVar (loc,n) -> 
+      <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >>
+  | _ -> failwith "mlexpr_of_constr: TODO"
+
+let mlexpr_of_occ_constr =
+  mlexpr_of_pair (mlexpr_of_list mlexpr_of_int) mlexpr_of_constr
+
+let mlexpr_of_red_expr = function
+  | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >>
+  | Rawterm.Hnf -> <:expr< Rawterm.Hnf >>
+  | Rawterm.Simpl o -> <:expr< Rawterm.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >>
+  | Rawterm.Cbv f ->
+      <:expr< Rawterm.Cbv $mlexpr_of_red_flags f$ >>
+  | Rawterm.Lazy f ->
+      <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >>
+  | Rawterm.Unfold l ->
+      let f1 = mlexpr_of_list 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$ >>
+  | Rawterm.Fold l ->
+      <:expr< Rawterm.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Rawterm.Pattern l ->
+      let f = mlexpr_of_list mlexpr_of_occ_constr in
+      <:expr< Rawterm.Pattern $f l$ >>
+  | Rawterm.ExtraRedExpr (s,c) ->
+      let l = mlexpr_of_constr c in
+      <:expr< Rawterm.ExtraRedExpr $mlexpr_of_string s$ $l$ >>
+
+let rec mlexpr_of_argtype loc = function
+  | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >>
+  | Genarg.IntArgType -> <:expr< Genarg.IntArgType >>
+  | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >>
+  | Genarg.RefArgType -> <:expr< Genarg.RefArgType >>
+  | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >>
+  | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >>
+  | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
+  | Genarg.HypArgType -> <:expr< Genarg.HypArgType >>
+  | Genarg.StringArgType -> <:expr< Genarg.StringArgType >>
+  | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
+  | Genarg.CastedOpenConstrArgType -> <:expr< Genarg.CastedOpenConstrArgType >>
+  | 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 >>
+  | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.PairArgType (t1,t2) -> 
+      let t1 = mlexpr_of_argtype loc t1 in
+      let t2 = mlexpr_of_argtype loc t2 in
+      <:expr< Genarg.PairArgType $t1$ $t2$ >>
+  | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >>
+
+let rec mlexpr_of_may_eval f = function
+  | Rawterm.ConstrEval (r,c) ->
+      <:expr< Rawterm.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
+  | Rawterm.ConstrContext ((loc,id),c) ->
+      let id = mlexpr_of_ident id in
+      <:expr< Rawterm.ConstrContext (loc,$id$) $f c$ >>
+  | Rawterm.ConstrTypeOf c ->
+      <:expr< Rawterm.ConstrTypeOf $mlexpr_of_constr c$ >>
+  | Rawterm.ConstrTerm c ->
+      <:expr< Rawterm.ConstrTerm $mlexpr_of_constr c$ >>
+
+let mlexpr_of_binding_kind = function
+  | Rawterm.ExplicitBindings l ->
+      let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in
+      <:expr< Rawterm.ExplicitBindings $l$ >>
+  | Rawterm.ImplicitBindings l -> 
+      let l = mlexpr_of_list mlexpr_of_constr l in
+      <:expr< Rawterm.ImplicitBindings $l$ >>
+  | Rawterm.NoBindings -> 
+       <:expr< Rawterm.NoBindings >>
+
+let mlexpr_of_induction_arg = function
+  | Tacexpr.ElimOnConstr c ->
+      <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr c$ >>
+  | Tacexpr.ElimOnIdent (_,id) -> 
+      <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >>
+  | Tacexpr.ElimOnAnonHyp n ->
+      <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >>
+
+let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr
+
+let mlexpr_of_constr_with_binding =
+  mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind
+
+let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO"
+
+let mlexpr_of_pattern_ast = mlexpr_of_constr
+
+let mlexpr_of_entry_type = function
+    _ -> failwith "mlexpr_of_entry_type: TODO"
+
+let mlexpr_of_match_pattern = function
+  | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >>
+  | Tacexpr.Subterm (ido,t) ->
+      <:expr< Tacexpr.Subterm $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >>
+
+let mlexpr_of_match_context_hyps = function
+  | Tacexpr.Hyp (id,l) ->
+      let f = mlexpr_of_located mlexpr_of_name in
+      <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >>
+
+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 rec mlexpr_of_atomic_tactic = function
+  (* Basic tactics *)
+  | Tacexpr.TacIntroPattern pl ->
+      let pl = mlexpr_of_list mlexpr_of_intro_pattern pl in
+      <:expr< Tacexpr.TacIntroPattern $pl$ >>
+  | Tacexpr.TacIntrosUntil h ->
+      <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >>
+  | Tacexpr.TacIntroMove (idopt,idopt') ->
+      let idopt = mlexpr_of_ident_option idopt in
+      let idopt'=mlexpr_of_option (mlexpr_of_located mlexpr_of_ident) idopt' in
+      <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >>
+  | Tacexpr.TacAssumption ->
+      <:expr< Tacexpr.TacAssumption >>
+  | Tacexpr.TacExact c ->
+      <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >>
+  | Tacexpr.TacApply cb ->
+      <:expr< Tacexpr.TacApply $mlexpr_of_constr_with_binding cb$ >>
+  | Tacexpr.TacElim (cb,cbo) ->
+      let cb = mlexpr_of_constr_with_binding cb in
+      let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
+      <:expr< Tacexpr.TacElim $cb$ $cbo$ >>
+  | Tacexpr.TacElimType c ->
+      <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >>
+  | Tacexpr.TacCase cb ->
+      let cb = mlexpr_of_constr_with_binding cb in
+      <:expr< Tacexpr.TacCase $cb$ >>
+  | Tacexpr.TacCaseType c ->
+      <:expr< Tacexpr.TacCaseType $mlexpr_of_constr c$ >>
+  | Tacexpr.TacFix (ido,n) ->
+      let ido = mlexpr_of_ident_option ido in
+      let n = mlexpr_of_int n in
+      <:expr< Tacexpr.TacFix $ido$ $n$ >>
+  | Tacexpr.TacMutualFix (id,n,l) ->
+      let id = mlexpr_of_ident id in
+      let n = mlexpr_of_int n in
+      let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in
+      let l = mlexpr_of_list f l in
+      <:expr< Tacexpr.TacMutualFix $id$ $n$ $l$ >>
+  | Tacexpr.TacCofix ido ->
+      let ido = mlexpr_of_ident_option ido in
+      <:expr< Tacexpr.TacCofix $ido$ >>
+  | Tacexpr.TacMutualCofix (id,l) ->
+      let id = mlexpr_of_ident id in
+      let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in
+      let l = mlexpr_of_list f l in
+      <:expr< Tacexpr.TacMutualCofix $id$ $l$ >>
+
+  | 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.TacGeneralize cl ->
+      <:expr< Tacexpr.TacGeneralize $mlexpr_of_list mlexpr_of_constr cl$ >>
+  | Tacexpr.TacGeneralizeDep c ->
+      <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >>
+  | Tacexpr.TacLetTac (na,c,cl) ->
+      let na = mlexpr_of_name na in
+      let cl = mlexpr_of_clause_pattern cl in
+      <: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) ->
+      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 [])>>
+  | 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 []) >>
+
+  (* Context management *)
+  | Tacexpr.TacClear l ->
+      let l = mlexpr_of_list (mlexpr_of_hyp) l in
+      <:expr< Tacexpr.TacClear $l$ >>
+  | Tacexpr.TacClearBody l ->
+      let l = mlexpr_of_list (mlexpr_of_hyp) l in
+      <:expr< Tacexpr.TacClearBody $l$ >>
+  | Tacexpr.TacMove (dep,id1,id2) ->
+      <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$
+              $mlexpr_of_hyp id1$
+              $mlexpr_of_hyp id2$ >>
+
+  (* Constructors *)
+  | Tacexpr.TacLeft l ->
+      <:expr< Tacexpr.TacLeft $mlexpr_of_binding_kind l$>>
+  | Tacexpr.TacRight l ->
+      <:expr< Tacexpr.TacRight $mlexpr_of_binding_kind l$>>
+  | Tacexpr.TacSplit (b,l) ->
+      <:expr< Tacexpr.TacSplit
+        ($mlexpr_of_bool b$,$mlexpr_of_binding_kind l$)>>
+  | Tacexpr.TacAnyConstructor t ->
+      <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_option mlexpr_of_tactic t$>>
+  | Tacexpr.TacConstructor (n,l) ->
+      let n = mlexpr_of_or_metaid mlexpr_of_int n in
+      <:expr< Tacexpr.TacConstructor $n$ $mlexpr_of_binding_kind l$>>
+
+  (* Conversion *)
+  | Tacexpr.TacReduce (r,cl) ->
+      let l = mlexpr_of_clause cl in
+      <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >>
+  | Tacexpr.TacChange (occl,c,cl) ->
+      let l = mlexpr_of_clause cl in
+      let g = mlexpr_of_option mlexpr_of_occ_constr in
+      <:expr< Tacexpr.TacChange $g occl$ $mlexpr_of_constr c$ $l$ >>
+
+  (* Equivalence relations *)
+  | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >>
+  | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >>
+  | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_constr c$ >>
+
+  (* Automation tactics *)
+  | Tacexpr.TacAuto (n,l) ->
+      let n = mlexpr_of_option mlexpr_of_int n in
+      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
+      <:expr< Tacexpr.TacAuto $n$ $l$ >>
+(*
+  | Tacexpr.TacTrivial l ->
+      let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
+      <:expr< Tacexpr.TacTrivial $l$ >>
+*)
+
+(*
+  | Tacexpr.TacExtend (s,l) ->
+      let l = mlexpr_of_list mlexpr_of_tactic_arg l in
+      let $dloc$ = MLast.loc_of_expr l in
+      <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $l$ >>
+*)
+  | _ -> failwith "Quotation of atomic tactic expressions: TODO"
+
+and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
+  | Tacexpr.TacAtom (loc,t) ->
+      <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >>
+  | Tacexpr.TacThen (t1,t2) -> 
+      <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
+  | Tacexpr.TacThens (t,tl) ->
+      <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>>
+  | Tacexpr.TacFirst tl ->
+      <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >>
+  | Tacexpr.TacSolve tl ->
+      <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >>
+  | Tacexpr.TacTry t ->
+      <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacOrelse (t1,t2) ->
+      <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
+  | Tacexpr.TacDo (n,t) ->
+      <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacRepeat t ->
+      <: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.TacInfo t -> TacInfo (loc,f t)
+
+  | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t)))
+  | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t)
+*)
+  | Tacexpr.TacLetIn (l,t) ->
+      let f =
+	mlexpr_of_triple
+	  (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident)
+	  (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) ->
+      <:expr< Tacexpr.TacMatch
+        $mlexpr_of_tactic t$
+        $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
+  | Tacexpr.TacMatchContext (lr,l) ->
+      <:expr< Tacexpr.TacMatchContext 
+        $mlexpr_of_bool lr$
+        $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
+(*
+  | Tacexpr.TacFun of $dloc$ * tactic_fun_ast
+  | Tacexpr.TacFunRec of $dloc$ * identifier * tactic_fun_ast
+*)
+(*
+  | Tacexpr.TacArg (Tacexpr.AstTacArg (Coqast.Nmeta $dloc$ id)) -> anti loc id
+*)
+  | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,id)) -> anti loc id
+  | Tacexpr.TacArg t ->
+      <:expr< Tacexpr.TacArg $mlexpr_of_tactic_arg t$ >>
+  | _ -> failwith "Quotation of tactic expressions: TODO"
+
+and mlexpr_of_tactic_arg = function
+  | Tacexpr.MetaIdArg (loc,id) -> anti loc id
+  | Tacexpr.TacCall (loc,t,tl) ->
+      <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>>
+  | Tacexpr.Tacexp t ->
+      <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >>
+  | Tacexpr.ConstrMayEval c ->
+      <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >>
+  | Tacexpr.Reference r ->
+      <: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
+                     (Pcoq.Gram.parsable (Stream.of_string s)))
+  in
+  let ep s = patt_of_expr (ee s) in
+  Quotation.ExAst (ee, ep)
+
+let ftac e =
+  let ee s =
+    mlexpr_of_tactic (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 _ = 
+  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
new file mode 100644
index 00000000..b3f5393c
--- /dev/null
+++ b/parsing/q_util.ml4
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: q_util.ml4,v 1.2.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+
+(* This file defines standard combinators to build ml expressions *)
+
+open Util
+
+let not_impl name x =
+  let desc =
+    if Obj.is_block (Obj.repr x) then
+      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
+    else 
+      "int_val = " ^ string_of_int (Obj.magic x)
+  in
+  failwith ("<Q_util." ^ name ^ ", not impl: " ^ desc)
+
+let rec patt_of_expr e =
+  let loc = MLast.loc_of_expr e in
+  match e with
+    | <:expr< $e1$.$e2$ >> -> <:patt< $patt_of_expr e1$.$patt_of_expr e2$ >>
+    | <:expr< $e1$ $e2$ >> -> <:patt< $patt_of_expr e1$ $patt_of_expr e2$ >>
+    | <:expr< loc >> -> <:patt< _ >>
+    | <:expr< $lid:s$ >> -> <:patt< $lid:s$ >>
+    | <:expr< $uid:s$ >> -> <:patt< $uid:s$ >>
+    | <:expr< $str:s$ >> -> <:patt< $str:s$ >>
+    | <:expr< $anti:e$ >> -> <:patt< $anti:patt_of_expr e$ >>
+    | _ -> not_impl "patt_of_expr" e
+
+let mlexpr_of_list f l =
+  List.fold_right
+    (fun e1 e2 ->
+      let e1 = f e1 in
+       let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
+       <:expr< [$e1$ :: $e2$] >>)
+    l (let loc = dummy_loc in <:expr< [] >>)
+
+let mlexpr_of_pair m1 m2 (a1,a2) =
+  let e1 = m1 a1 and e2 = m2 a2 in
+  let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in
+  <:expr< ($e1$, $e2$) >>
+
+let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)=
+  let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in
+  let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e3)) in
+  <:expr< ($e1$, $e2$, $e3$) >>
+
+(* We don't give location for tactic quotation! *)
+let loc = dummy_loc
+
+
+let mlexpr_of_bool = function
+  | true -> <:expr< True >>
+  | false -> <:expr< False >>
+
+let mlexpr_of_int n = <:expr< $int:string_of_int n$ >>
+
+let mlexpr_of_string s = <:expr< $str:s$ >>
+
+let mlexpr_of_option f = function
+  | None -> <:expr< None >>
+  | Some e -> <:expr< Some $f e$ >>
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
new file mode 100644
index 00000000..a2c22bc3
--- /dev/null
+++ b/parsing/q_util.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: q_util.mli,v 1.2.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+val patt_of_expr : MLast.expr -> MLast.patt
+
+val mlexpr_of_list :  ('a -> MLast.expr) -> 'a list -> MLast.expr
+
+val mlexpr_of_pair :
+  ('a -> MLast.expr) -> ('b -> MLast.expr)
+    -> 'a * 'b -> MLast.expr
+
+val mlexpr_of_triple :
+  ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr)
+    -> 'a * 'b * 'c -> MLast.expr
+
+val mlexpr_of_bool : bool -> MLast.expr
+
+val mlexpr_of_int : int -> MLast.expr
+
+val mlexpr_of_string : string -> MLast.expr
+
+val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr
+
diff --git a/parsing/search.ml b/parsing/search.ml
new file mode 100644
index 00000000..a3d6e000
--- /dev/null
+++ b/parsing/search.ml
@@ -0,0 +1,224 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: search.ml,v 1.30.2.1 2004/07/16 19:30:41 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Rawterm
+open Declarations
+open Libobject
+open Declare
+open Coqast
+open Environ
+open Pattern
+open Matching
+open Printer
+open Libnames
+open Nametab
+
+(* The functions print_constructors and crible implement the behavior needed
+   for the Coq searching commands.
+   These functions take as first argument the procedure
+   that will be called to treat each entry.  This procedure receives the name
+   of the object, the assumptions that will make it possible to print its type,
+   and the constr term that represent its type. *)
+
+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))
+  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
+  | _            -> 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)
+	   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
+        if refopt = None
+	  || head_const typ = constr_of_reference (out_some refopt)
+	then
+	  fn (ConstRef kn) env typ
+    | "INDUCTIVE" -> 
+	let kn = locate_mind (qualid_of_sp sp) in
+        let mib = Global.lookup_mind kn in 
+        (match refopt with 
+	  | Some (IndRef ((kn',tyi) as ind)) when kn=kn' ->
+	      print_constructors ind fn env
+	        (Array.length (mib.mind_packets.(tyi).mind_user_lc))
+          | Some _ -> ()
+	  | _ ->
+              Array.iteri 
+	        (fun i mip -> print_constructors (kn,i) fn env
+	          (Array.length mip.mind_user_lc)) mib.mind_packets)
+    | _ -> ()
+  in 
+  try 
+    Declaremods.iter_all_segments false crible_rec
+  with Not_found -> 
+    ()
+
+let crible ref = gen_crible (Some ref)
+
+(* Fine Search. By Yves Bertot. *)
+
+exception No_section_path
+
+let rec head c = 
+  let c = strip_outer_cast c in
+  match kind_of_term c with
+  | Prod (_,_,c) -> head c
+  | LetIn (_,_,_,c) -> head c
+  | _              -> c
+      
+let constr_to_section_path c = match kind_of_term c with
+  | Const sp -> sp
+  | _ -> raise No_section_path
+      
+let xor a b = (a or b) & (not (a & b))
+
+let plain_display ref a c =
+  let pc = prterm_env a c in
+  let pr = pr_global ref in
+  msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
+
+let filter_by_module (module_list:dir_path list) (accept:bool) 
+  (ref:global_reference) _ _ =
+  try
+    let sp = sp_of_global ref in
+    let sl = dirpath sp in
+    let rec filter_aux = function
+      | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl)
+      | [] -> true 
+    in
+    xor accept (filter_aux module_list)
+  with No_section_path -> 
+    false
+
+let gref_eq =
+  IndRef (Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0)
+let gref_eqT =
+  IndRef (Libnames.encode_kn Coqlib.logic_type_module (id_of_string "eqT"), 0)
+
+let mk_rewrite_pattern1 eq pattern =
+  PApp (PRef eq, [| PMeta None; pattern; PMeta None |])
+
+let mk_rewrite_pattern2 eq pattern =
+  PApp (PRef eq, [| PMeta None; PMeta None; pattern |])
+
+let pattern_filter pat _ a c =
+  try 
+    try
+      is_matching pat (head c) 
+    with _ -> 
+      is_matching
+	pat (head (Typing.type_of (Global.env()) Evd.empty c))
+    with UserError _ -> 
+      false
+
+let filtered_search filter_function display_function ref =
+  crible ref
+    (fun s a c -> if filter_function s a c then display_function s a c) 
+
+let rec id_from_pattern = function
+  | PRef gr -> gr
+(* should be appear as a PRef (VarRef sp) !!
+  | PVar id -> Nametab.locate (make_qualid [] (string_of_id id))
+ *)
+  | PApp (p,_) -> id_from_pattern p
+  | _ -> error "the pattern is not simple enough"
+	
+let raw_pattern_search extra_filter display_function pat =
+  let name = id_from_pattern pat in
+  filtered_search 
+    (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) 
+    display_function name
+
+let raw_search_rewrite extra_filter display_function pattern =
+  filtered_search
+    (fun s a c ->
+       ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) ||
+        (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) 
+       && extra_filter s a c)
+    display_function gref_eq
+(*
+  ;
+  filtered_search
+    (fun s a c ->
+       ((pattern_filter (mk_rewrite_pattern1 gref_eqT pattern) s a c) ||
+        (pattern_filter (mk_rewrite_pattern2 gref_eqT pattern) s a c)) 
+       && extra_filter s a c)
+    display_function gref_eqT
+*)
+
+let text_pattern_search extra_filter =
+  raw_pattern_search extra_filter plain_display
+    
+let text_search_rewrite extra_filter =
+  raw_search_rewrite extra_filter plain_display
+
+let filter_by_module_from_list = function
+  | [], _ -> (fun _ _ _ -> true)
+  | l, outside -> filter_by_module l (not outside)
+
+let search_by_head ref inout = 
+  filtered_search (filter_by_module_from_list inout) plain_display ref
+
+let search_rewrite pat inout =
+  text_search_rewrite (filter_by_module_from_list inout) pat
+
+let search_pattern pat inout =
+  text_pattern_search (filter_by_module_from_list inout) pat
+
+
+let gen_filtered_search filter_function display_function =
+  gen_crible None
+    (fun s a c -> if filter_function s a c then display_function s a c) 
+
+(** SearchAbout *)
+
+let name_of_reference ref = string_of_id (id_of_global ref)
+
+type glob_search_about_item =
+  | GlobSearchRef of global_reference
+  | GlobSearchString of string
+
+let search_about_item (itemref,typ) = function
+  | GlobSearchRef ref -> Termops.occur_term (constr_of_reference ref) typ
+  | GlobSearchString s -> string_string_contains (name_of_reference itemref) s
+
+let raw_search_about filter_modules display_function l =
+  let filter ref' env typ =
+    filter_modules ref' env typ &&
+    List.for_all (search_about_item (ref',typ)) l
+  in
+  gen_filtered_search filter display_function
+
+let search_about ref inout = 
+  raw_search_about (filter_by_module_from_list inout) plain_display ref
diff --git a/parsing/search.mli b/parsing/search.mli
new file mode 100644
index 00000000..62ba865d
--- /dev/null
+++ b/parsing/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        *)
+(************************************************************************)
+
+(*i $Id: search.mli,v 1.16.2.1 2004/07/16 19:30:41 herbelin Exp $ i*)
+
+open Pp
+open Names
+open Term
+open Environ
+open Pattern
+open Libnames
+open Nametab
+
+(*s Search facilities. *)
+
+type glob_search_about_item =
+  | GlobSearchRef of global_reference
+  | GlobSearchString of string
+
+val search_by_head : global_reference -> dir_path list * bool -> unit
+val search_rewrite : constr_pattern -> dir_path list * bool -> unit
+val search_pattern : constr_pattern -> dir_path list * bool -> unit
+val search_about  : glob_search_about_item list -> dir_path list * bool -> unit
+
+(* The filtering function that is by standard search facilities.
+   It can be passed as argument to the raw search functions.
+   It is used in pcoq. *)
+
+val filter_by_module_from_list :
+  dir_path list * bool -> global_reference -> env -> 'a -> bool
+
+(* raw search functions can be used for various extensions.
+   They are also used for pcoq. *)
+val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
+      (global_reference -> env -> constr -> unit) -> unit
+val filtered_search : (global_reference -> env -> constr -> bool) -> 
+  (global_reference -> env -> constr -> unit) -> global_reference -> unit
+val raw_pattern_search : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
+val raw_search_rewrite : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
+val raw_search_about : (global_reference -> env -> constr -> bool) ->
+  (global_reference -> env -> constr -> unit) -> 
+      glob_search_about_item list -> unit
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
new file mode 100644
index 00000000..bbacd013
--- /dev/null
+++ b/parsing/tacextend.ml4
@@ -0,0 +1,283 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tacextend.ml4,v 1.10.2.2 2004/07/16 19:30:41 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Argextend
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+type grammar_tactic_production_expr =
+  | TacTerm of string
+  | TacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
+
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | TacNonTerm(loc',_,_,Some p)::l ->
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_when loc = function
+  | [] -> <:expr< True >>
+  | TacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_when loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
+  | _::l -> make_when loc l
+
+let rec make_let e = function
+  | [] -> e
+  | TacNonTerm(loc,t,_,Some p)::l ->
+      let loc = join_loc loc (MLast.loc_of_expr e) in
+      let e = make_let e l in
+      let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in
+      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
+          <: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 p = make_patt pt in
+  let w = Some (make_when (MLast.loc_of_expr e) pt) in
+  (p, w, make_let e pt)::l
+
+let rec extract_signature = function
+  | [] -> []
+  | TacNonTerm (_,t,_,_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let check_unicity s l =
+  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"^
+      "non-terminals in the same order: put them in distinct tactic entries")
+
+let make_clauses s l =
+  check_unicity s l;
+  let default =
+    (<:patt< _ >>,None,<:expr< failwith "Tactic extension: cannot occur" >>) in
+  List.fold_right (add_clause s) l [default]
+
+let rec make_args = function
+  | [] -> <:expr< [] >>
+  | TacNonTerm(loc,t,_,Some p)::l ->
+      <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >>
+  | _::l -> make_args l
+
+let rec make_eval_tactic e = function
+  | [] -> e
+  | TacNonTerm(loc,TacticArgType,_,Some p)::l ->
+      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
+           form to avoid marshalling closures and to be reprinted *)
+      <:expr< let $lid:p$ = ($lid:p$,Tacinterp.eval_tactic $lid:p$) in $e$ >>
+  | _::l -> make_eval_tactic e l
+
+let rec make_fun e = function
+  | [] -> e
+  | TacNonTerm(loc,_,_,Some p)::l -> 
+      <:expr< fun $lid:p$ -> $make_fun e l$ >>
+  | _::l -> make_fun e l
+
+let mlexpr_of_grammar_production = function
+  | TacTerm s ->
+      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
+  | TacNonTerm (loc,nt,g,sopt) ->
+      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
+
+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))
+
+let rec make_tags loc = function
+  | [] -> <:expr< [] >>
+  | TacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_tags loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< [ $t$ :: $l$ ] >>
+  | _::l -> make_tags loc l
+
+let make_one_printing_rule (s,pt,e) =
+  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
+
+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 rec contains_epsilon = function
+  | List0ArgType _ -> true
+  | List1ArgType t -> contains_epsilon t
+  | OptArgType _ -> true
+  | 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 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 gl = mlexpr_of_clause cl in
+  let hide_tac (_,p,e) =
+    (* reste a definir les fonctions cachees avec des noms frais *)
+    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$
+        >>
+      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 atomic_tactics =
+    mlexpr_of_list (fun (s,_,_) -> mlexpr_of_string s)
+      (List.filter (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
+        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$;
+    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
+  GLOBAL: str_item;
+  str_item:
+    [ [ "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 ] ]
+  ;
+  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)
+    ] ]
+  ;
+  tacargs:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e in
+        TacNonTerm (loc, t, g, Some s)
+      | s = STRING ->
+        TacTerm s
+    ] ]
+  ;
+  END
+
diff --git a/parsing/termast.ml b/parsing/termast.ml
new file mode 100644
index 00000000..47e45d42
--- /dev/null
+++ b/parsing/termast.ml
@@ -0,0 +1,503 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c66e8f0f
--- /dev/null
+++ b/parsing/termast.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..bdc1ea66
--- /dev/null
+++ b/parsing/vernacextend.ml4
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: vernacextend.ml4,v 1.5.2.2 2004/07/16 19:30:42 herbelin Exp $ *)
+
+open Genarg
+open Q_util
+open Q_coqast
+open Ast
+open Argextend
+
+let join_loc (deb1,_) (_,fin2) = (deb1,fin2)
+let loc = Util.dummy_loc
+let default_loc = <:expr< Util.dummy_loc >>
+
+type grammar_tactic_production_expr =
+  | VernacTerm of string
+  | VernacNonTerm of Util.loc * Genarg.argument_type * MLast.expr * string option
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | VernacNonTerm(_,_,_,Some p)::l ->
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_when loc = function
+  | [] -> <:expr< True >>
+  | VernacNonTerm(loc',t,_,Some p)::l ->
+      let l = make_when loc l in
+      let loc = join_loc loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
+  | _::l -> make_when loc l
+
+let rec make_let e = function
+  | [] -> e
+  | VernacNonTerm(loc,t,_,Some p)::l ->
+      let loc = join_loc loc (MLast.loc_of_expr e) in
+      let e = make_let e l in
+      <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
+  | _::l -> make_let 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
+
+let rec extract_signature = function
+  | [] -> []
+  | VernacNonTerm (_,t,_,_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let check_unicity s l =
+  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 entry "^s^" have the same\n"^
+      "non-terminals in the same order: put them in distinct vernac entries")
+
+let make_clauses s l =
+  check_unicity s l;
+  let default =
+    (<:patt< _ >>,None,<:expr< failwith "Vernac extension: cannot occur" >>) in
+  List.fold_right (add_clause s) l [default]
+
+let rec make_fun e = function
+  | [] -> e
+  | VernacNonTerm(loc,_,_,Some p)::l -> 
+      <:expr< fun $lid:p$ -> $make_fun e l$ >>
+  | _::l -> make_fun e l
+
+let mlexpr_of_grammar_production = function
+  | VernacTerm s ->
+      <:expr< Egrammar.TacTerm $mlexpr_of_string s$ >>
+  | VernacNonTerm (loc,nt,g,sopt) ->
+      <:expr< Egrammar.TacNonTerm $default_loc$ ($g$,$mlexpr_of_argtype loc nt$) $mlexpr_of_option mlexpr_of_string sopt$ >>
+
+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)))
+
+let declare_command loc s cl =
+  let gl = mlexpr_of_clause cl in
+  let icl = make_clauses s cl in
+  <:str_item<
+    declare
+      open Pcoq;
+      try Vernacinterp.vinterp_add $mlexpr_of_string s$ (fun [ $list:icl$ ])
+      with e -> Pp.pp (Cerrors.explain_exn e);
+      Egrammar.extend_vernac_command_grammar $mlexpr_of_string s$ $gl$;
+    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
+  GLOBAL: str_item;
+  str_item:
+    [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT;
+        OPT "|"; l = LIST1 rule SEP "|";
+        "END" ->
+         declare_command loc s l ] ]
+  ;
+  rule:
+    [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]"
+        -> 
+      if s = "" then Util.user_err_loc (loc,"",Pp.str "Command name is empty");
+      (s,l,<:expr< fun () -> $e$ >>)
+    ] ]
+  ;
+  args:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name loc e in
+        VernacNonTerm (loc, t, g, Some s)
+      | s = STRING ->
+        VernacTerm s
+    ] ]
+  ;
+  END
+;;
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
new file mode 100644
index 00000000..2126f015
--- /dev/null
+++ b/pretyping/cases.ml
@@ -0,0 +1,1773 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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,v 1.111.2.1 2004/07/16 19:30:43 herbelin Exp $ *)
+
+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
+
+(* Pattern-matching errors *)
+
+type pattern_matching_error =
+  | BadPattern of constructor * constr
+  | BadConstructor of constructor * inductive
+  | WrongNumargConstructor of constructor * 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 c n =
+  raise_pattern_matching_error (loc, Global.env(), WrongNumargConstructor (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)))
+
+(*********************************************************************)
+(* 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  
+
+(************************************************************************)
+(*            Pattern-matching compilation (Cases)                      *)
+(************************************************************************)
+
+(************************************************************************)
+(* Configuration, errors and warnings *)
+
+open Pp
+
+let mssg_may_need_inversion () =
+  str "This pattern-matching is not exhaustive."
+
+let mssg_this_case_cannot_occur () =
+  "This pattern-matching is not exhaustive."
+
+(* 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 '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;
+      rhs_lift   : int;
+      it         : rawconstr }
+
+type equation =
+    { dependencies : constr lifted list;
+      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 (n,dep,pred)] types a pushed term ([Pushed]), if dep is true,
+     the term is dependent, if n<>0 then the type of the pushed term is
+     necessarily 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 (int * bool) * 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  : evar_defs;
+      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            *
+ *  [n]Cases n of O => true | _ => false end                                *
+ *--------------------------------------------------------------------------*)
+
+(* Computing the inductive type from the matrix of patterns *)
+
+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 hole_source = match tmloc with 
+    | Some loc -> fun i -> (loc, TomatchTypeParameter (tyi,i))
+    | None -> fun _ -> (dummy_loc, InternalHole) in
+   let (_,evarl,_) =
+    List.fold_right
+      (fun (na,ty) (env,evl,n) ->
+	 (push_rel (na,None,ty) env,
+	    (new_isevar isevars env (hole_source n) ty)::evl,n+1))
+      ntys (env,[],1) in
+  let expected_typ = applist (mkInd tyi,evarl) 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
+  (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.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+
+(************************************************************************)
+(* Utils *)
+
+   (* 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)
+
+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_app 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 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
+	(* 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 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:
+
+   [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]
+
+   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]
+
+  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.other_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 push_rels_eqn sign eqn =
+  {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 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) 
+	  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
+  { eqn with
+      alias_stack = alias_rest;
+      rhs = {eqn.rhs with rhs_env = push_rels thissign eqn.rhs.rhs_env } }
+
+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
+
+(* Infering 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 "Inference of annotation not yet implemented in this case" 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 "Cases z of (Ci xi1..xipi) => ..."
+  should be inserted somewhere in Ti.
+
+- If T is undefined, an easy solution is to insert a "Cases z of (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) (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 =
+  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 *)
+    let typs =
+      Array.map (local_strong (whd_betaevar empty_env (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 (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)
+    in
+    if array_for_all (fun (_,_,typ) -> the_conv_x_leq 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 ((nargs,dep as tm),pred) ->
+      let k' = nargs + (if dep then 1 else 0) in
+      PrLetIn (tm, map_predicate f (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 ((0,dep),pred) ->
+      subst_predicate ([],if dep then Some cur else None) pred
+  | PrLetIn ((_,dep),pred) ->
+      (match typ with
+        | IsInd (_,IndType (_,realargs)) ->
+            subst_predicate (realargs,if dep 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 c ny d = function
+  | PrLetIn ((nargs,dep as tm),pred) ->
+      if not dep then anomaly "Undetected dependency";
+      let p = nargs + 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 ((0,dep),pred), Pushed ((cur,_),_)::tms ->
+      extract_predicate (if dep 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 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 ((nrealargs,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 k =
+        if nrealargs = 0 & n <> 1 then 
+          (* Real args were not considered *) if dep then n-1 else n
+        else
+          (* Real args are OK *) if dep 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
+  | 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 = deps <> [] || alreadydep in
+  let pred = if dep then pred else lift_predicate (-1) pred in
+  (* There is no dependency in realargs for subpattern *)
+  (k-1, PrLetIn ((0,dep), pred))
+
+
+(*****************************************************************************)
+(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
+(*                                                                           *)
+(*  Gamma |- Cases Pushed(c:I(realargs)) rest of...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' |- Cases Pushed(x1')..Pushed(xn') rest of...end: pred' *)
+(*                                                                           *)
+(*****************************************************************************)
+let specialize_predicate tomatchs deps cs = function
+  | (PrProd _ | PrCcl _) ->
+      anomaly "specialize_predicate: a matched pattern must be pushed"
+  | PrLetIn ((nrealargs,isdep),pred) ->
+      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
+      let k = nrealargs + (if isdep 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 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 (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 mind 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 mind cstrs pat with 
+	   | PatVar (_,name) -> 
+	       (* This is a default clause that we expand *)
+	       for i=1 to Array.length cstrs do
+		 let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in
+		 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 ->
+	       (* 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 current = function
+  | [] -> pb
+  | i::l ->
+      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+      let pb' = generalize_problem pb current 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_app (generalize_predicate current 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 -> empty_tycon
+    | 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_app (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 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)
+      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
+
+  sign,
+  { 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;
+      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
+
+  Concretely, each term "c" or type "T" comes with a delayed lift
+  index, but it works as if the lifting were effective.
+
+*)
+
+(**********************************************************************)
+(* 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 ((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
+  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 (cstrs <> [||] or not (initial_history pb.history)) & 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 current 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_app 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 (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_app (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                            *)
+
+(* 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;
+	rhs_lift = 0;
+	it = initial_rhs } in
+    { dependencies = [];
+      patterns = initial_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 decomp_lam_force p =
+    match kind_of_term p with
+      | Lambda (_,_,c) -> c
+      | _ -> (* eta-expansion *) applist (lift 1 p, [mkRel 1]) in
+  let rec buildrec p = function
+    | [] -> 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
+              buildrec p ltm 
+	  | Some n ->
+              let n = if isdep then n+1 else n in
+              let p = iterate decomp_lam_force n p in
+              buildrec 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 c =
+  let cook (n, l, env) = 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)
+	else
+	  (n + p, (List.rev realargs)@l, push_rels sign env)
+    | c,NotInd _ ->
+	(n, l, env) in
+  let n, allargs, env = List.fold_left cook (0, [], env) tomatchs in
+  let allargs =
+    List.map (fun c -> lift n (nf_betadeltaiota env (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)
+    else
+      map_constr_with_full_binders push_rel build_skeleton env c in
+  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 pred tomatchl =
+  let nar = List.fold_left (fun n (_,t) ->
+    let p = match t with IsInd (_,IndType(_,a)) -> List.length a | _ -> 0 in
+    if isdep then n+p+1 else n+p) 0 tomatchl in
+  let cook = function
+    | _,IsInd (_,IndType(_,realargs)) -> List.length realargs
+    | _,NotInd _ -> 0 in
+  let rec buildrec n pred = function
+    | [] -> PrCcl pred
+    | tm::ltm ->
+        let nrealargs = cook tm 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
+	PrLetIn ((nrealargs,p=1), buildrec (n+nrealargs+user_p) pred ltm)
+  in buildrec 0 pred tomatchl
+
+let extract_arity_signature env0 tomatchl tmsign =
+  let get_one_sign n tm {contents = (na,t)} =
+    match tm with
+      | NotInd (bo,typ) -> 
+	  (match t with
+	    | None -> [na,option_app (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',nal) ->
+		  let nparams = List.length params in
+		  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");
+		  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
+	(buildrec (n + List.length l) (ltm,tmsign)) @ l
+    | _ -> assert false
+  in buildrec 0 (tomatchl,tmsign)
+
+(* 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
+
+ * 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}) ->
+      (match tycon with
+       | None -> None
+       | Some t ->
+	 let pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in
+	 Some (build_initial_predicate false pred tomatchs))
+
+  (* v8 style type annotation *)
+  | (None,{contents = Some rtntyp}) ->
+
+      (* We extract the signature of the arity *)
+      let arsign = extract_arity_signature env tomatchs sign in
+      let env = push_rels arsign env in
+      let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in
+      Some (build_initial_predicate true predccl tomatchs)
+
+  (* 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
+      in
+      let predccl = extract_predicate_conclusion dep tomatchs predj.uj_val in
+(*
+      let etapred,cdep = case_dependent env (evars_of isevars) loc predj tomatchs in
+*)
+      set_arity_signature dep n sign tomatchs pred x;
+      Some (build_initial_predicate dep predccl tomatchs)
+
+
+(**************************************************************************)
+(* Main entry of the matching compilation                                 *)
+
+let compile_cases loc (typing_fun,isevars) tycon 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
+
+  (* We build the elimination predicate if any and check its consistency *)
+  (* with the type of arguments to match *)
+  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;
+      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;
+  
+  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
new file mode 100644
index 00000000..1d2f9025
--- /dev/null
+++ b/pretyping/cases.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: cases.mli,v 1.22.2.2 2004/07/16 19:30:43 herbelin Exp $ 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
+  | 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
+
+(*s Used for old cases in pretyping *)
+
+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 
+
+(*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 ->
+    unsafe_judgment
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
new file mode 100644
index 00000000..88f59ded
--- /dev/null
+++ b/pretyping/cbv.ml
@@ -0,0 +1,352 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: cbv.ml,v 1.12.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Term
+open Names
+open Environ
+open Instantiate
+open Univ
+open Evd
+open Closure
+open Esubst
+
+(**** Call by value reduction ****)
+
+(* The type of terms with closure. The meaning of the constructors and
+ * the invariants of this datatype are the following:
+ *  VAL(k,c) represents the constr c with a delayed shift of k. c must be
+ *          in normal form and neutral (i.e. not a lambda, a construct or a
+ *          (co)fix, because they may produce redexes by applying them,
+ *          or putting them in a case)
+ *  LAM(x,a,b,S) is the term [S]([x:a]b). the bindings is propagated
+ *          only when the abstraction is applied, and then we use the rule
+ *                  ([S]([x:a]b) c) --> [S.c]b
+ *          This corresponds to the usual strategy of weak reduction
+ *  FIXP(op,bd,S,args) is the fixpoint (Fix or Cofix) of bodies bd under
+ *          the bindings S, and then applied to args. Here again,
+ *          weak reduction.
+ *  CONSTR(c,args) is the constructor [c] applied to [args].
+ *
+ * Note that any term has not an equivalent in cbv_value: for example,
+ * a product (x:A)B must be in normal form because only VAL may
+ * represent it, and the argument of VAL is always in normal
+ * form. This remark precludes coding a head reduction with these
+ * functions. Anyway, does it make sense to head reduce with a
+ * call-by-value strategy ?
+ *)
+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
+
+(* les vars pourraient etre des constr,
+   cela permet de retarder les lift: utile ?? *) 
+
+(* relocation of a value; used when a value stored in a context is expanded
+ * in a larger context. e.g.  [%k (S.t)](k+1) --> [^k]t  (t is shifted of k)
+ *)
+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))
+  | FIXP (fix,s,args) ->
+      FIXP (fix,subs_shft (n,s), List.map (shift_value n) args)
+  | COFIXP (cofix,s,args) ->
+      COFIXP (cofix,subs_shft (n,s), List.map (shift_value n) args)
+  | CONSTR (c,args) ->
+      CONSTR (c, List.map (shift_value n) args)
+	
+
+(* Contracts a fixpoint: given a fixpoint and a bindings,
+ * returns the corresponding fixpoint body, and the bindings in which
+ * it should be evaluated: its first variables are the fixpoint bodies
+ * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1}))
+ *    -> (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 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)
+
+let contract_cofixp env (i,(_,_,bds as bodies)) =
+  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)
+
+let make_constr_ref n = function
+  | FarRelKey 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
+ *      this corresponds to the application stack of the KAM.
+ *      The members of l are values: we evaluate arguments before 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
+ *      (Weak reduction: we propagate the sub only when the selected branch
+ *      is determined)
+ *
+ * Important remark: the APPs should be collapsed:
+ *    (APP (l,(APP ...))) forbidden
+ *)
+
+type cbv_stack =
+  | TOP
+  | APP of cbv_value list * 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)
+
+
+open RedFlags
+
+let red_set_ref flags = function
+  | FarRelKey _ -> red_set flags fDELTA
+  | VarKey id -> red_set flags (fVAR id)
+  | ConstKey sp -> red_set flags (fCONST sp)
+
+(* Transfer application lists from a value to the stack
+ * useful because fixpoints may be totally applied in several times
+ *)
+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)
+    | _ -> (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))
+	
+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))
+      | _ -> false
+  else 
+    false
+
+let cofixp_reducible flgs _ stk =
+  if red_set flgs fIOTA then
+    match stk with
+      | (CASE _ | APP(_,CASE _)) -> true
+      | _ -> false
+  else 
+    false
+
+(* The main recursive functions
+ *
+ * Go under applications and cases (pushed in the stack), expand head
+ * constants or substitued de Bruijn, and try to make appear a
+ * constructor, a lambda or a fixp in the head. If not, it is a value
+ * and is completely computed here. The head redexes are NOT reduced:
+ * the function returns the pair of a cbv_value and its stack.  *
+ * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last
+ * argument is [].  Because we must put all the applied terms in the
+ * stack. *)
+
+let rec norm_head info env t stack =
+  (* no reduction under binders *)
+  match kind_of_term t with
+  (* stack grows (remove casts) *)
+  | 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)
+  | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack))
+  | Cast (ct,_) -> norm_head info env ct stack
+
+  (* constants, axioms
+   * the first pattern is CRUCIAL, n=0 happens very often:
+   * when reducing closed terms, n is always 0 *)
+  | Rel i ->
+      (match expand_rel i env with
+        | 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))
+
+  | Var id -> norm_head_ref 0 info env stack (VarKey id)
+
+  | Const sp -> norm_head_ref 0 info env stack (ConstKey sp)
+
+  | LetIn (x, b, t, c) ->
+      (* zeta means letin are contracted; delta without zeta means we *)
+      (* allow bindings but leave let's in place *)
+      let zeta = red_set (info_flags info) fZETA in
+      let env' =
+	if zeta 
+          (* New rule: for Cbv, Delta does not apply to locally bound variables
+          or red_set (info_flags info) fDELTA
+          *)
+        then 
+	  subs_cons (cbv_stack_term info TOP env b,env)
+	else
+	  subs_lift env in
+      if zeta then
+        norm_head info env' c stack
+      else
+	let normt =
+	  mkLetIn (x, cbv_norm_term info env b,
+		   cbv_norm_term info env t,
+		   cbv_norm_term info env' c) in
+	(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)
+
+  (* neutral cases *)
+  | (Sort _ | Meta _ | Ind _|Evar _) -> (VAL(0, t), stack)
+  | Prod (x,t,c) -> 
+      (VAL(0, mkProd (x, cbv_norm_term info env t,
+		      cbv_norm_term info (subs_lift env) c)),
+	     stack)
+
+and norm_head_ref k info env stack normt =
+  if red_set_ref (info_flags info) normt then
+    match ref_value_cache info normt with
+      | Some body -> strip_appl (shift_value k body) stack
+      | None -> (VAL(0,make_constr_ref k normt), stack)
+  else (VAL(0,make_constr_ref k normt), stack)
+
+(* cbv_stack_term performs weak reduction on constr t under the subs
+ * env, with context stack, i.e. ([env]t stack).  First computes weak
+ * head normal form of t and checks if a redex appears with the stack.
+ * If so, recursive call to reach the real head normal form.  If not,
+ * we build a value. 
+ *)
+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))
+      when red_set (info_flags info) fBETA ->
+        let subs = subs_cons (arg,env) in
+          cbv_stack_term info (stack_app args stk) subs b
+
+    (* a Fix applied enough -> IOTA *)
+    | (FIXP(fix,env,_), stk)
+        when fixp_reducible (info_flags info) fix stk ->
+        let (envf,redfix) = contract_fixp env fix in
+        cbv_stack_term info stk envf redfix
+
+    (* constructor guard satisfied or Cofix in a Case -> IOTA *)
+    | (COFIXP(cofix,env,_), stk)
+        when cofixp_reducible (info_flags info) cofix stk->
+        let (envf,redfix) = contract_cofixp env cofix in
+        cbv_stack_term info stk envf redfix
+
+    (* 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)
+         
+    (* constructor of arity 0 in a Case -> IOTA *)
+    | (CONSTR((_,n),_), CASE(_,br,_,env,stk))
+            when red_set (info_flags info) fIOTA ->
+                    cbv_stack_term info stk env br.(n-1)
+
+    (* may be reduced later by application *)  
+    | (head, TOP) -> head
+    | (FIXP(fix,env,_), APP(appl,TOP)) -> FIXP(fix,env,appl) 
+    | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) 
+    | (CONSTR(c,_), APP(appl,TOP)) -> CONSTR(c,appl)
+
+    (* definitely a value *)
+    | (head,stk) -> VAL(0,apply_stack info (cbv_norm_value info head) stk)
+
+
+(* When we are sure t will never produce a redex with its stack, we
+ * normalize (even under binders) the applied terms and we build the
+ * final term
+ *)
+and apply_stack info t = function
+  | TOP -> t
+  | APP (args,st) ->
+      apply_stack info (applistc t (List.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,
+		    Array.map (cbv_norm_term info env) br))
+        st
+
+
+(* performs the reduction on a constr, and returns a constr *)
+and cbv_norm_term info env t =
+  (* reduction under binders *)
+  cbv_norm_value info (cbv_stack_term info TOP 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)
+  | FIXP ((lij,(names,lty,bds)),env,args) ->
+      applistc
+        (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)
+  | COFIXP ((j,(names,lty,bds)),env,args) ->
+      applistc
+        (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)
+  | CONSTR (c,args) ->
+      applistc
+        (mkConstruct c)
+        (List.map (cbv_norm_value info) args)
+
+(* with profiling *)
+let cbv_norm infos constr =
+  with_stats (lazy (cbv_norm_term infos (ESID 0) constr))
+
+
+type cbv_infos = cbv_value infos
+
+(* constant bodies are normalized at the first expansion *)
+let create_cbv_infos flgs env =
+  create
+    (fun old_info c -> cbv_stack_term old_info TOP (ESID 0) c)
+    flgs
+    env
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
new file mode 100644
index 00000000..bf8e03b3
--- /dev/null
+++ b/pretyping/cbv.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: cbv.mli,v 1.6.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Closure
+open Esubst
+(*i*)
+
+(************************************************************************)
+(*s Call-by-value reduction *)
+
+(* Entry point for cbv normalization of a constr *)
+type cbv_infos
+
+val create_cbv_infos : RedFlags.reds -> env -> cbv_infos
+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
+
+val shift_value : int -> cbv_value -> cbv_value
+
+type cbv_stack =
+  | TOP
+  | APP of cbv_value list * 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 strip_appl : cbv_value -> cbv_stack -> cbv_value * cbv_stack
+
+(* recursive functions... *)
+val cbv_stack_term : cbv_infos ->
+  cbv_stack -> cbv_value subs -> constr -> cbv_value
+val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr
+val norm_head : cbv_infos ->
+  cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack
+val apply_stack : cbv_infos -> constr -> cbv_stack -> constr
+val cbv_norm_value : cbv_infos -> cbv_value -> constr
+(* End of cbv debug section i*)
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
new file mode 100755
index 00000000..2d8fb951
--- /dev/null
+++ b/pretyping/classops.ml
@@ -0,0 +1,397 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: classops.ml,v 1.48.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Options
+open Names
+open Libnames
+open Nametab
+open Environ
+open Libobject
+open Library
+open Term
+open Termops
+open Rawterm
+open Decl_kinds
+
+(* usage qque peu general: utilise aussi dans record *)
+
+(* A class is a type constructor, its type is an arity whose number of
+   arguments is cl_param (0 for CL_SORT and CL_FUN) *)
+
+type cl_typ = 
+  | CL_SORT 
+  | CL_FUN
+  | CL_SECVAR of variable
+  | CL_CONST of constant
+  | 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_strength : strength;
+  coe_is_identity : bool;
+  coe_param : int }
+
+type cl_index = int
+
+type coe_index = coe_info_typ
+
+type inheritance_path = coe_index list
+
+(* table des classes, des coercions et graphe d'heritage *)
+
+module Bijint = struct
+  type ('a,'b) t = { v : ('a * 'b) array; s : int; inv : ('a,int) Gmap.t }
+  let empty = { v = [||]; s = 0; inv = Gmap.empty }
+  let mem y b = Gmap.mem y b.inv
+  let map x b = if 0 <= x & x < b.s then b.v.(x) else raise Not_found
+  let revmap y b = let n = Gmap.find y b.inv in (n, snd (b.v.(n)))
+  let add x y b =
+    let v =
+      if b.s = Array.length b.v then
+	(let v = Array.make (b.s + 8) (x,y) in Array.blit b.v 0 v 0 b.s; v)
+      else b.v in
+    v.(b.s) <- (x,y); { v = v; s = b.s+1; inv = Gmap.add x b.s b.inv }
+  let replace n x y b =
+    let v = Array.copy b.v in v.(n) <- (x,y); { b with v = v }
+  let dom b = Gmap.dom b.inv
+end
+
+let class_tab =
+  ref (Bijint.empty : (cl_typ, cl_info_typ) Bijint.t)
+
+let coercion_tab =
+  ref (Gmap.empty : (coe_typ, coe_info_typ) Gmap.t)
+
+let inheritance_graph =
+  ref (Gmap.empty : (cl_index * cl_index, inheritance_path) Gmap.t)
+
+let freeze () = (!class_tab, !coercion_tab, !inheritance_graph)
+
+let unfreeze (fcl,fco,fig) = 
+  class_tab:=fcl;
+  coercion_tab:=fco;
+  inheritance_graph:=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 ->
+    class_tab := Bijint.add cl s !class_tab
+
+let add_new_coercion coe s = 
+  coercion_tab := Gmap.add coe s !coercion_tab
+
+let add_new_path x y =
+  inheritance_graph := Gmap.add x y !inheritance_graph
+
+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 };
+  coercion_tab:= Gmap.empty;
+  inheritance_graph:= Gmap.empty
+
+let _ = init()
+
+(* class_info : cl_typ -> int * cl_info_typ *)
+
+let class_info cl = Bijint.revmap cl !class_tab
+
+let class_exists cl = Bijint.mem cl !class_tab
+
+(* class_info_from_index : int -> cl_typ * cl_info_typ *)
+
+let class_info_from_index i = Bijint.map i !class_tab
+
+(* coercion_info : coe_typ -> coe_info_typ *)
+
+let coercion_info coe = Gmap.find coe !coercion_tab
+
+let coercion_exists coe = Gmap.mem coe !coercion_tab
+
+let coercion_params coe_info = coe_info.coe_param
+
+let lookup_path_between (s,t) =
+  Gmap.find (s,t) !inheritance_graph
+
+let lookup_path_to_fun_from s = 
+  lookup_path_between (s,fst(class_info CL_FUN))
+
+let lookup_path_to_sort_from s = 
+  lookup_path_between (s,fst(class_info CL_SORT))
+
+let lookup_pattern_path_between (s,t) =
+  let l = Gmap.find (s,t) !inheritance_graph in
+  List.map  
+    (fun coe ->
+       let c, _ =
+	 Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty 
+	   coe.coe_value.uj_val
+       in 
+       match kind_of_term c with
+	 | Construct sp -> (sp, coe.coe_param)
+	 | _ -> raise Not_found) l
+
+
+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 
+	if kn' == kn then ct else
+	  CL_CONST kn'
+  | 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 }
+
+(* 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 = 
+  let (t, n1, i, args) = 
+    try
+      let (cl,args) = find_class_type t in
+      let (i, { cl_param = n1 } ) = class_info cl in
+      (t, n1, i, args)
+    with Not_found ->
+      let t = Tacred.hnf_constr env sigma t in
+      let (cl, args) = find_class_type t in 
+      let (i, { cl_param = n1 } ) = class_info cl in
+      (t, n1, i, args)
+  in
+  if List.length args = n1 then t, i else raise Not_found
+
+let inductive_class_of ind = fst (class_info (CL_IND ind))
+
+let class_args_of c = snd (decompose_app 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_CONST sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp))
+  | CL_IND sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp))
+  | CL_SECVAR sp ->
+      string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp))
+
+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)
+
+(* pretty-print functions are now in Pretty *)
+(* rajouter une coercion dans le graphe *)
+
+let path_printer = ref (fun _ -> str "<a class path>"
+                        : (int * int) * inheritance_path -> std_ppcmds)
+
+let install_path_printer f = path_printer := f
+ 
+let print_path x = !path_printer x
+
+let message_ambig l = 
+  (str"Ambiguous paths:" ++ spc () ++
+   prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l)
+
+(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit 
+                         coercion,source,target *)
+
+let different_class_params i j =
+  (snd (class_info_from_index i)).cl_param > 0
+
+let add_coercion_in_graph (ic,source,target) =
+  let old_inheritance_graph = !inheritance_graph in
+  let ambig_paths =
+    (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
+  let try_add_new_path (i,j as ij) p =
+    try 
+      if i=j then begin
+	if different_class_params i j then begin
+	  let _ = lookup_path_between ij in
+          ambig_paths := (ij,p)::!ambig_paths
+	end
+      end else begin
+        let _ = lookup_path_between (i,j) in
+        ambig_paths := (ij,p)::!ambig_paths
+      end;
+      false
+    with Not_found -> begin
+      add_new_path ij p;
+      true
+    end
+  in
+  let try_add_new_path1 ij p = 
+    let _ = try_add_new_path ij p in () 
+  in
+  if try_add_new_path (source,target) [ic] then begin
+    Gmap.iter 
+      (fun (s,t) p ->
+         if s<>t then begin
+	   if t = source then begin
+             try_add_new_path1 (s,target) (p@[ic]);
+             Gmap.iter
+	       (fun (u,v) q ->
+                  if u<>v & (u = target) & (p <> q) then 
+		    try_add_new_path1 (s,v) (p@[ic]@q))
+               old_inheritance_graph
+           end;
+           if s = target then try_add_new_path1 (source,t) (ic::p)
+	 end)
+      old_inheritance_graph 
+  end;
+  if (!ambig_paths <> []) && is_verbose () then 
+    ppnl (message_ambig !ambig_paths)
+
+type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
+
+let cache_coercion (_,(coe,xf,cls,clt)) =
+  let is,_ = class_info cls in
+  let it,_ = class_info clt in
+  add_new_coercion coe xf;
+  add_coercion_in_graph (xf,is,it)
+
+let subst_coercion (_,subst,(coe,xf,cls,clt 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 *)
+
+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))
+
+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 classes () = Bijint.dom !class_tab
+let coercions () = Gmap.rng !coercion_tab
+let inheritance_graph () = Gmap.to_list !inheritance_graph
+
+let coercion_of_qualid qid =
+  let ref = Nametab.global qid in
+  if not (coercion_exists ref) then
+    errorlabstrm "try_add_coercion" 
+      (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion");
+  ref
+
+module CoercionPrinting =
+  struct
+    type t = coe_typ
+    let encode = coercion_of_qualid
+    let subst = subst_coe_typ
+    let printer x = pr_global_env Idset.empty x
+    let key = Goptions.SecondaryTable ("Printing","Coercion")
+    let title = "Explicitly printed coercions: "
+    let member_message x b =
+      str "Explicit printing of coercion " ++ printer x ++
+      str (if b then " is set" else " is unset")
+    let synchronous = true
+  end
+
+module PrintingCoercion  = Goptions.MakeRefTable(CoercionPrinting)
+
+let hide_coercion coe =
+  if not (PrintingCoercion.active coe) then
+    let coe_info = coercion_info coe in
+    Some coe_info.coe_param
+  else None
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
new file mode 100644
index 00000000..f846a9e5
--- /dev/null
+++ b/pretyping/classops.mli
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: classops.mli,v 1.30.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Evd
+open Environ
+open Nametab
+(*i*)
+
+(*s This is the type of class kinds *)
+type cl_typ = 
+  | CL_SORT 
+  | CL_FUN 
+  | CL_SECVAR of variable
+  | CL_CONST of constant
+  | CL_IND of inductive
+
+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 *)
+type coe_typ = Libnames.global_reference
+
+(* This is the type of infos for declared coercions *)
+type coe_info_typ 
+
+(* [cl_index] is the type of class keys *)
+type cl_index
+
+(* [coe_index] is the type of coercion keys *)
+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
+val class_info_from_index : cl_index -> cl_typ * cl_info_typ
+
+(* [find_class_type c] returns the head reference of c and its
+   arguments *)
+val find_class_type : constr -> cl_typ * constr list
+
+(* raises [Not_found] if not convertible to a class *)
+val class_of : env -> evar_map -> constr -> constr * cl_index
+
+(* raises [Not_found] if not mapped to a class *)
+val inductive_class_of : inductive -> cl_index
+
+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 ->
+      src:cl_typ -> target:cl_typ -> params:int -> unit
+
+(*s Access to coercions infos *)
+val coercion_exists : coe_typ -> bool
+
+val coercion_value : coe_index -> (unsafe_judgment * bool)
+
+(*s Lookup functions for coercion paths *)
+val lookup_path_between : cl_index * cl_index -> inheritance_path
+val lookup_path_to_fun_from : cl_index -> inheritance_path
+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 : 
+  ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit
+(*i*)
+
+(*s This is for printing purpose *)
+val string_of_class : cl_typ -> string
+val pr_class : cl_typ -> std_ppcmds
+val get_coercion_value : coe_index -> constr
+val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list
+val classes : unit -> cl_typ list
+val coercions : unit -> coe_index list
+
+(* [hide_coercion] returns the number of params to skip if the coercion must
+   be hidden, [None] otherwise; it raises [Not_found] if not a coercion *)
+val hide_coercion : coe_typ -> int option
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
new file mode 100644
index 00000000..f214388f
--- /dev/null
+++ b/pretyping/coercion.ml
@@ -0,0 +1,211 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coercion.ml,v 1.38.6.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+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
+
+(* 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 =
+  if !compter then begin
+    nbpathc := !nbpathc +1; 
+    nbcoer := !nbcoer + (List.length p)
+  end;
+  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)
+
+(* 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' = 
+    try 
+      inh_conv_coerce_to_fail env isevars cj 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' =
+		try 
+		  inh_conv_coerce_to_fail env isevars hj c1
+		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
+
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
new file mode 100644
index 00000000..658844eb
--- /dev/null
+++ b/pretyping/coercion.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coercion.mli,v 1.20.14.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Evd
+open Names
+open Term
+open Sign
+open Environ
+open Evarutil
+open Rawterm
+(*i*)
+
+(*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 -> 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 :
+  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
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
new file mode 100644
index 00000000..41f63ace
--- /dev/null
+++ b/pretyping/detyping.ml
@@ -0,0 +1,492 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: detyping.ml,v 1.75.2.4 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Pp
+open Util
+open Univ
+open Names
+open Term
+open Declarations
+open Inductive
+open Inductiveops
+open Environ
+open Sign
+open Rawterm
+open Nameops
+open Termops
+open Libnames
+open Nametab
+
+(****************************************************************************)
+(* Tools for printing of Cases                                              *)
+
+let encode_inductive qid =
+  let indsp = global_inductive qid in
+  let constr_lengths = mis_constr_nargs indsp in
+  (indsp,constr_lengths)
+
+(* Parameterization of the translation from constr to ast      *)
+
+(* Tables for Cases printing under a "if" form, a "let" form,  *)
+
+let has_two_constructors lc =
+  Array.length lc = 2 (* & lc.(0) = 0 & lc.(1) = 0 *)
+
+let isomorphic_to_tuple lc = (Array.length lc = 1)
+
+let encode_bool r =
+  let (_,lc as x) = encode_inductive r in
+  if not (has_two_constructors lc) then
+    user_err_loc (loc_of_reference r,"encode_if",
+      str "This type has not exactly two constructors");
+  x
+
+let encode_tuple r =
+  let (_,lc as x) = encode_inductive r in
+  if not (isomorphic_to_tuple lc) then
+    user_err_loc (loc_of_reference r,"encode_tuple",
+      str "This type cannot be seen as a tuple type");
+  x
+
+module PrintingCasesMake =
+  functor (Test : sig 
+     val encode : reference -> inductive * int array
+     val member_message : std_ppcmds -> bool -> std_ppcmds
+     val field : string
+     val title : string
+  end) ->
+  struct
+    type t = inductive * int array
+    let encode = Test.encode
+    let subst subst ((kn,i), ints as obj) =
+      let kn' = subst_kn subst kn in
+	if kn' == kn then obj else
+	  (kn',i), ints
+    let printer (ind,_) = pr_global_env Idset.empty (IndRef ind)
+    let key = Goptions.SecondaryTable ("Printing",Test.field)
+    let title = Test.title
+    let member_message x = Test.member_message (printer x)
+    let synchronous = true
+  end
+
+module PrintingCasesIf =
+  PrintingCasesMake (struct 
+    let encode = encode_bool
+    let field = "If"
+    let title = "Types leading to pretty-printing of Cases using a `if' form: "
+    let member_message s b =
+      str "Cases on elements of " ++ s ++ 
+      str
+	(if b then " are printed using a `if' form"
+         else " are not printed using a `if' form")
+  end)
+
+module PrintingCasesLet =
+  PrintingCasesMake (struct 
+    let encode = encode_tuple
+    let field = "Let"
+    let title = 
+      "Types leading to a pretty-printing of Cases using a `let' form:"
+    let member_message s b =
+      str "Cases on elements of " ++ s ++
+      str
+	(if b then " are printed using a `let' form"
+         else " are not printed using a `let' form")
+  end)
+
+module PrintingIf  = Goptions.MakeRefTable(PrintingCasesIf)
+module PrintingLet = Goptions.MakeRefTable(PrintingCasesLet)
+
+let force_let ci =
+  let indsp = ci.ci_ind in
+  let lc = mis_constr_nargs indsp in PrintingLet.active (indsp,lc)
+let force_if ci =
+  let indsp = ci.ci_ind in
+  let lc = mis_constr_nargs indsp in PrintingIf.active (indsp,lc)
+
+(* Options for printing or not wildcard and synthetisable types *)
+
+open Goptions
+
+let wildcard_value = ref true
+let force_wildcard () = !wildcard_value
+
+let _ = declare_bool_option 
+	  { optsync  = true;
+	    optname  = "forced wildcard";
+	    optkey   = SecondaryTable ("Printing","Wildcard");
+	    optread  = force_wildcard;
+	    optwrite = (:=) wildcard_value }
+
+let synth_type_value = ref true
+let synthetize_type () = !synth_type_value
+
+let _ = declare_bool_option 
+	  { optsync  = true;
+	    optname  = "synthesizability";
+	    optkey   = SecondaryTable ("Printing","Synth");
+	    optread  = synthetize_type;
+	    optwrite = (:=) synth_type_value }
+
+(* Auxiliary function for MutCase printing *)
+(* [computable] tries to tell if the predicate typing the result is inferable*)
+
+let computable p k =
+    (* We first remove as many lambda as the arity, then we look
+       if it remains a lambda for a dependent elimination. This function
+       works for normal eta-expanded term. For non eta-expanded or
+       non-normal terms, it may affirm the pred is synthetisable
+       because of an undetected ultimate dependent variable in the second
+       clause, or else, it may affirms the pred non synthetisable
+       because of a non normal term in the fourth clause.
+       A solution could be to store, in the MutCase, the eta-expanded
+       normal form of pred to decide if it depends on its variables
+
+       Lorsque le prédicat est dépendant de manière certaine, on
+       ne déclare pas le prédicat synthétisable (même si la
+       variable dépendante ne l'est pas effectivement) parce que
+       sinon on perd la réciprocité de la synthèse (qui, lui,
+       engendrera un prédicat non dépendant) *)
+
+  (nb_lam p = k+1)
+  &&
+  let _,ccl = decompose_lam p in 
+  noccur_between 1 (k+1) ccl
+
+
+let lookup_name_as_renamed env t s =
+  let rec lookup avoid env_names n c = match kind_of_term c with
+    | Prod (name,_,c') ->
+	(match concrete_name true avoid env_names name c' with
+           | (Name id,avoid') -> 
+	       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'))
+    | LetIn (name,_,_,c') ->
+	(match concrete_name true avoid env_names name c' with
+           | (Name id,avoid') -> 
+	       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
+    | _ -> None
+  in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t
+
+let lookup_index_as_renamed env t n =
+  let rec lookup n d c = match kind_of_term c with
+    | Prod (name,_,c') ->
+	  (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')
+    | LetIn (name,_,_,c') ->
+	  (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
+    | _ -> None
+  in lookup n 1 t
+
+let is_nondep_branch c n =
+  try
+    let _,ccl = decompose_lam_n_assum n c in
+    noccur_between 1 n ccl
+  with _ -> (* Not eta-expanded or not reduced *)
+    false
+
+let extract_nondep_branches test c b n =
+  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
+  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 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
+    else
+      let p = option_app detype p in
+      match p with
+        | None -> Anonymous, None, 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 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
+  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 tag =
+    try 
+      if !Options.raw_print then
+        RegularStyle
+      else if PrintingLet.active (indsp,consnargsl) then
+	LetStyle
+      else if PrintingIf.active (indsp,consnargsl) then 
+	IfStyle
+      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 =
+  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)
+	 | 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))
+    | Meta n ->
+	(* Meta in constr are not user-parsable and are mapped to Evar *)
+	REvar (dummy_loc, n, None)
+    | Var id ->
+	(try
+	  let _ = Global.lookup_named id in RRef (dummy_loc, 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
+    | 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)
+    | Evar (ev,cl) ->
+        REvar (dummy_loc, ev, 
+               Some (List.map (detype tenv avoid env) (Array.to_list cl)))
+    | Ind ind_sp ->
+	RRef (dummy_loc, 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) =
+  let def_avoid, def_env, lfi =
+    Array.fold_left
+      (fun (avoid, env, l) na ->
+	 let id = next_name_away na avoid in 
+	 (id::avoid, add_name (Name id) env, id::l))
+      (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))
+    bodies tys vn in
+  RRec(dummy_loc,RFix 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) =
+  let def_avoid, def_env, lfi =
+    Array.fold_left
+      (fun (avoid, env, l) na ->
+	 let id = next_name_away na avoid in 
+	 (id::avoid, add_name (Name id) env, id::l))
+      (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))
+    bodies tys in
+  RRec(dummy_loc,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
+  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') ->
+        let na = match (na,na') with
+            Name _, _ -> na
+          | _, Name _ -> na'
+          | _ -> na in 
+        let t = detype tenv 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'
+    (* 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 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
+    (* 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)
+    (* 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 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'
+    (* 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
+        (List.rev l,c,t)
+
+and detype_eqn tenv 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 
+      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
+  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)
+    else
+      match kind_of_term b with
+	| Lambda (x,_,b) -> 
+	    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
+
+	| LetIn (x,_,_,b) -> 
+	    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 *)
+	    buildrec ids patlist avoid env n c
+
+	| _ -> (* eta-expansion : n'arrivera plus lorsque tous les
+                  termes seront construits à partir de la syntaxe Cases *)
+            (* nommage de la nouvelle variable *)
+	    let new_b = applist (lift 1 b, [mkRel 1]) in
+            let pat,new_avoid,new_env,new_ids =
+	      make_pat Anonymous avoid env new_b ids in
+	    buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b
+	  
+  in 
+  buildrec [] [] avoid env construct_nargs branch
+
+and detype_binder tenv bk avoid env na ty c =
+  let na',avoid' =
+    if bk = BLetIn then
+      concrete_let_name (fst tenv) 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
+  match bk with
+    | BProd -> RProd (dummy_loc, na',detype tenv [] env ty, r)
+    | BLambda -> RLambda (dummy_loc, na',detype tenv [] env ty, r)
+    | BLetIn -> RLetIn (dummy_loc, na',detype tenv [] env ty, r)
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
new file mode 100644
index 00000000..c2a70928
--- /dev/null
+++ b/pretyping/detyping.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: detyping.mli,v 1.13.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Rawterm
+open Termops
+(*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 detype : bool * env -> 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
+
+(* 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
+val lookup_index_as_renamed : env -> constr -> int -> int option
+
+
+val force_wildcard : unit -> bool
+val synthetize_type : unit -> bool
+val force_if : case_info -> bool
+val force_let : case_info -> bool
diff --git a/pretyping/doc.tex b/pretyping/doc.tex
new file mode 100644
index 00000000..d92a027e
--- /dev/null
+++ b/pretyping/doc.tex
@@ -0,0 +1,14 @@
+
+\newpage
+\section*{Pre-typing}
+
+\ocwsection \label{pretyping}
+
+\bigskip
+\begin{center}\epsfig{file=pretyping.dep.ps,width=\linewidth}\end{center}
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
new file mode 100644
index 00000000..6f396b43
--- /dev/null
+++ b/pretyping/evarconv.ml
@@ -0,0 +1,397 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: evarconv.ml,v 1.44.6.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Reductionops
+open Closure
+open Instantiate
+open Environ
+open Typing
+open Classops
+open Recordops 
+open Evarutil
+open Libnames
+
+type flex_kind_of_term =
+  | Rigid of constr 
+  | MaybeFlexible of constr
+  | Flexible of existential
+
+let flex_kind_of_term c l =
+  match kind_of_term c with
+    | Const _ -> MaybeFlexible c
+    | Rel n -> MaybeFlexible c
+    | Var id -> MaybeFlexible c
+    | Lambda _ when l<>[] -> MaybeFlexible c
+    | LetIn _  -> MaybeFlexible c
+    | Evar ev -> Flexible ev
+    | _ -> Rigid c
+
+let eval_flexible_term env c =
+  match kind_of_term c with
+  | Const c -> constant_opt_value env c
+  | Rel n -> let (_,v,_) = lookup_rel n env in option_app (lift n) v
+  | Var id -> let (_,v,_) = lookup_named id env in v
+  | LetIn (_,b,_,c) -> Some (subst1 b c)
+  | Lambda _ -> Some c
+  | _ -> assert false
+(*
+let rec apprec_nobeta env sigma s =
+  let (t,stack as s) = whd_state s in
+  match kind_of_term (fst s) with
+    | Case (ci,p,d,lf) ->
+        let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
+        let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
+        if reducible_mind_case cr then 
+	  apprec_nobeta env sigma (rslt, stack)
+        else 
+	  s
+    | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with
+             | Reduced s -> apprec_nobeta env sigma s
+	     | NotReducible -> s)
+    | _ -> s
+
+let evar_apprec_nobeta env isevars stack c =
+  let rec aux s =
+    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)
+      | _ -> (t, list_of_stack stack)
+  in aux (c, append_stack (Array.of_list stack) empty_stack)
+*)
+
+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
+    match kind_of_term t with
+      | Evar (n,_ as ev) when Evd.is_defined sigma n ->
+	  aux (existential_value sigma ev, stack)
+      | _ -> (t, list_of_stack stack)
+  in aux (c, append_stack (Array.of_list stack) empty_stack)
+
+let apprec_nohdbeta env isevars c =
+  let (t,stack as s) = Reductionops.whd_stack c in
+  match kind_of_term t with
+    | (Case _ | Fix _) -> evar_apprec env isevars [] c
+    | _ -> s
+
+(* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem
+   (t1 l1) = (t2 l2) into a problem
+
+     l1 = params1@c1::extra_args1
+     l2 = us2@extra_args2
+     (t1 params1 c1) = (proji params (c xs))
+     (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)
+   with vi = (cstr us), for which we know that the i-th projection proji
+   satisfies
+
+      (proji params c) = (cstr us)
+
+   Rem: such objects, usable for conversion, are defined in the objdef
+   table; practically, it amounts to "canonically" equip t2 into a
+   object c in structure R (since, if c1 were not an evar, the
+   projection would have been reduced) *)
+
+let check_conv_record (t1,l1) (t2,l2) =
+  try
+    let proji = reference_of_constr t1 in
+    let cstr = reference_of_constr t2 in
+    let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = 
+      objdef_info (proji, cstr) in
+    let params1, c1, extra_args1 =
+      match list_chop (List.length params) l1 with 
+	| params1, c1::extra_args1 -> params1, c1, extra_args1
+	| _ -> assert false in
+    let us2,extra_args2 = list_chop (List.length us) l2 in
+    c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1
+  with _ -> 
+    raise Not_found
+
+
+(* Precondition: one of the terms of the pb is an uninstanciated evar,
+ * possibly applied to arguments. *)
+
+let rec evar_conv_x env isevars pbty term1 term2 = 
+  let sigma = evars_of isevars in
+  let term1 = whd_castappevar sigma term1 in
+  let term2 = whd_castappevar sigma term2 in
+(*
+  if eq_constr term1 term2 then 
+    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
+    solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2)
+  else if ise_undefined 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)
+
+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 () =
+	  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
+	  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)
+	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 () =
+	  match eval_flexible_term env flex2 with
+	    | Some v2 ->
+		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars l2 v2)
+	    | None -> 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 () =
+	  match eval_flexible_term env flex1 with
+	    | Some v1 ->
+		evar_eqappr_x env isevars pbty
+		  (evar_apprec env isevars l1 v1) appr2
+	    | None -> 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 
+             (try check_conv_record appr1 appr2
+	      with Not_found -> check_conv_record appr2 appr1)
+           with _ -> false)
+	and f4 () =
+          (* heuristic: unfold second argument first, exception made
+             if the first argument is a beta-redex (expand a constant
+             only if necessary) *)
+          let val2 =
+            match kind_of_term flex1 with
+                Lambda _ -> None
+              | _ -> eval_flexible_term env flex2 in
+	  match val2 with
+	    | Some v2 ->
+		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars 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
+	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))
+
+    | 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))
+        
+
+    | MaybeFlexible flex1, Rigid _ ->
+	let f3 () =
+	  (try conv_record env isevars (check_conv_record appr1 appr2)
+           with _ -> false)
+	and f4 () =
+	  match eval_flexible_term env flex1 with
+	    | Some v1 ->
+ 		evar_eqappr_x env isevars pbty
+		  (evar_apprec env isevars l1 v1) appr2
+	    | None -> 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 () =
+	  match eval_flexible_term env flex2 with
+	    | Some v2 ->
+ 		evar_eqappr_x env isevars pbty
+		  appr1 (evar_apprec env isevars l2 v2)
+	    | None -> 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 (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
+
+	| Sort s1, Sort s2 when l1=[] & l2=[] -> 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)
+
+	| 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
+	    in 
+	    ise_try isevars [f1; f2]
+
+	| LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *)
+	     let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1)
+             in evar_eqappr_x env isevars pbty appr1 appr2
+
+	| _, LetIn (_,b2,_,c'2) ->
+	    let appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
+            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)
+
+	| Ind sp1, Ind sp2 ->
+	    sp1=sp2
+            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+             
+	| Construct sp1, Construct sp2 ->
+	    sp1=sp2
+            & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+
+	| 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)
+
+	| 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)
+	     
+	| 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
+
+	| (App _ | Case _ | Fix _ | CoFix _), 
+	  (App _ | Case _ | Fix _ | CoFix _) -> 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 =
+    List.fold_left
+      (fun ks b ->
+	 let dloc = (dummy_loc,Rawterm.InternalHole) in
+	 (new_isevar isevars env dloc (substl ks b)) :: ks)
+      [] bs
+  in
+  if (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))))
+  then
+    (*TR*) (if !compter then (nbstruc:=!nbstruc+1;
+                              nbimplstruc:=!nbimplstruc+(List.length ks);true)
+            else true)
+  else false
+
+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
+ 
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
new file mode 100644
index 00000000..8785d855
--- /dev/null
+++ b/pretyping/evarconv.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: evarconv.mli,v 1.11.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Sign
+open Environ
+open Reductionops
+open Evarutil
+(*i*)
+
+val the_conv_x : env -> evar_defs -> constr -> constr -> bool
+
+val the_conv_x_leq : env -> evar_defs -> constr -> constr -> bool
+
+(*i For debugging *)
+val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> bool
+val evar_eqappr_x : 
+  env -> evar_defs ->
+    conv_pb -> constr * constr list -> constr * constr list -> bool
+(*i*)
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
new file mode 100644
index 00000000..441070fe
--- /dev/null
+++ b/pretyping/evarutil.ml
@@ -0,0 +1,579 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: evarutil.ml,v 1.64.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Nameops
+open Univ
+open Term
+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
+
+(*
+let distinct_id_list = 
+  let rec drec fresh = function
+      [] -> List.rev fresh 
+    | id::rest ->
+ 	let id' = next_ident_away_from id fresh in drec (id'::fresh) rest
+  in drec []
+*)
+
+(*
+let filter_sign p sign x =
+  sign_it
+    (fun id ty (v,ids,sgn) ->
+      let (disc,v') = p v (id,ty) in
+      if disc then (v', id::ids, sgn) else (v', ids, add_sign (id,ty) sgn))
+    sign
+    (x,[],nil_sign)
+*)
+
+(* Expanding existential variables (pretyping.ml) *)
+(* 1- whd_ise fails if an existential is undefined *)
+
+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 ->
+	if Evd.is_defined sigma ev then
+          whd_ise sigma (existential_value sigma (ev,args))
+	else raise (Uninstantiated_evar ev)
+  | _ -> c
+
+
+(* Expand evars, possibly in the head of an application *)
+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 -> 
+	  whrec (existential_value sigma (ev,args), l)
+      | Cast (c,_) -> whrec (c, l)
+      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
+      | _ -> s
+  in 
+  whrec (c, [])
+
+let whd_castappevar sigma c = applist (whd_castappevar_stack sigma c)
+
+let nf_evar = Pretype_errors.nf_evar
+let j_nf_evar = Pretype_errors.j_nf_evar
+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 make_evar_instance env =
+  fold_named_context
+    (fun env (id, b, _) l -> (*if b=None then*) mkVar id :: l (*else l*))
+    env ~init:[]
+
+(* 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 new_Type_sort () = Type (new_univ ())
+
+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) }
+*)
+
+(* 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
+
+(* 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)
+
+(* 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 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 (_,(rsign,ncargs)) =
+    List.fold_left 
+      (fun (sign,(rs,na)) a ->
+	 (List.tl sign,
+	  if not(closed0 a) then 
+	    (rs,na)
+	  else 
+	    (add_named_decl (List.hd sign) rs, a::na)))
+      (hyps,([],[])) args 
+  in
+  let sign' = List.rev rsign in
+  let env' = reset_with_named_context sign' env in
+  let instance = make_evar_instance env' in
+  let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl instance 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)
+
+
+
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+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
+
+let make_evar_instance_with_rel env =
+  let n = rel_context_length (rel_context env) in
+  let vars = 
+    fold_named_context
+      (fun env (id,b,_) l -> (* if b=None then *) mkVar id :: l (*else l*))
+      env ~init:[] in
+  snd (fold_rel_context
+	 (fun env (_,b,_) (i,l) -> 
+	    (i-1, (*if b=None then *) mkRel i :: l (*else l*)))
+	 env ~init:(n,vars))
+
+let make_subst env args =
+  snd (fold_named_context
+    (fun env (id,b,c) (args,l as g) ->
+       match b, args with
+	 | (* None *) _ , a::rest -> (rest, (id,a)::l)
+(*	 | Some _, _ -> g*)
+	 | _ -> anomaly "Instance does not match its signature")
+    env ~init:(List.rev args,[]))
+
+(* [new_isevar] declares a new existential in an env env with type typ *)
+(* 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) =
+  Sign.fold_rel_context
+    (fun (na,c,t) (subst,avoid,sign) ->
+       let na = if na = Anonymous then Name(id_of_string"_") else na in
+       let id = next_name_away na avoid in
+       ((mkVar id)::subst,
+        id::avoid,
+	add_named_decl (id,option_app (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)
+
+let new_isevar isevars env src typ =
+  let subst,env' = 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
+
+(* [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)
+ * ?sp [ sp.hyps \ args ]  unifies to rhs
+ * ?sp must be a closed term, not referring to itself.
+ * Not so trivial because some terms of args may be terms that are not
+ * variables. In this case, the non-var-or-Rels arguments are replaced
+ * by <implicit>. [clean_rhs] will ignore this part of the subtitution. 
+ * This leads to incompleteness (we don't deal with pbs that require
+ * inference of dependent types), but it seems sensible.
+ *
+ * If after cleaning, some free vars still occur, the function [restrict_hyps]
+ * tries to narrow the env of the evars that depend on Rels.
+ *
+ * If after that free Rels still occur it means that the instantiation
+ * cannot be done, as in  [x:?1; y:nat; z:(le y y)] x=z
+ * ?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 =
+  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
+  (* 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]
+
+(*-------------------*)
+(* 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
+  with Uninstantiated_evar _ -> true
+
+let head_is_evar isevars = 
+  let rec hrec k = match kind_of_term k with
+    | Evar (n,_)   -> not (Evd.is_defined isevars.evars n)
+    | App (f,_) -> hrec f
+    | Cast (c,_) -> hrec c
+    | _ -> false
+  in 
+  hrec 
+
+let rec is_eliminator c = match kind_of_term c with
+  | App _    -> true
+  | Case _ -> true
+  | Cast (c,_) -> is_eliminator c
+  | _ -> false
+
+let head_is_embedded_evar isevars c =
+  (head_is_evar isevars c) & (is_eliminator c)
+
+let head_evar = 
+  let rec hrec c = match kind_of_term c with
+    | Evar (ev,_)       -> ev
+    | Case (_,_,c,_) -> hrec c
+    | App (c,_)        -> hrec c
+    | Cast (c,_)        -> hrec c
+    | _                   -> failwith "headconstant"
+  in 
+  hrec 
+
+(* 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
+ * the hopes that the new solution will aid in solving them.
+ *
+ * The kinds of problems it knows how to solve are those in which
+ * the usable arguments of an existential var are all themselves
+ * universal variables.
+ * The solution to this problem is to do renaming for the Var's,
+ * to make them match up with the Var's which are found in the
+ * hyps of the existential, to do a "pop" for each Rel which is
+ * not an argument of the existential, and a subst1 for each which
+ * is, again, with the corresponding variable. This is done by
+ * evar_define
+ *
+ * Thus, we take the arguments of the existential which we are about
+ * to assign, and zip them with the identifiers in the hypotheses.
+ * Then, we process all the Var's in the arguments, and sort the
+ * Rel's into ascending order.  Then, we just march up, doing
+ * subst1's and pop's.
+ *
+ * NOTE: We can do this more efficiently for the relative arguments,
+ * by building a long substituend by hand, but this is a pain in the
+ * ass.
+ *)
+
+let status_changed lev (pbty,t1,t2) =
+  try 
+    List.mem (head_evar t1) lev or List.mem (head_evar t2) lev
+  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) = 
+    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)
+	 else 
+	   (List.tl  sgn, rsgn))
+      (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]
+
+
+(* Tries to solve problem t1 = t2.
+ * Precondition: t1 is an uninstanciated 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
+
+(* Operations on value/type constraints *)
+
+type type_constraint = constr option
+type val_constraint = constr option
+
+(* Old comment...
+ * Basically, we have the following kind of constraints (in increasing
+ * strength order):
+ *   (false,(None,None)) -> no constraint at all
+ *   (true,(None,None))  -> we must build a judgement which _TYPE is a kind
+ *   (_,(None,Some ty))  -> we must build a judgement which _TYPE is ty
+ *   (_,(Some v,_))      -> we must build a judgement which _VAL is v
+ * Maybe a concrete datatype would be easier to understand.
+ * We differentiate (true,(None,None)) from (_,(None,Some Type))
+ * because otherwise Case(s) would be misled, as in
+ * (n:nat) Case n of bool [_]nat end  would infer the predicate Type instead
+ * of Set.
+ *)
+
+(* The empty type constraint *)
+let empty_tycon = None
+
+(* Builds a type constraint *)
+let mk_tycon ty = Some ty
+
+(* Constrains the value of a type *)
+let empty_valcon = None
+
+(* Builds a value constraint *)
+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)
+
+let define_evar_as_arrow isevars ev =
+  let (prod,_,_) = refine_evar_as_arrow isevars ev in
+  prod
+
+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
+
+
+(* 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
+      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)
+	| _ -> error_not_product_loc loc env sigma c
+
+let valcon_of_tycon x = x
+
+let lift_tycon = option_app (lift 1)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
new file mode 100644
index 00000000..011d2a92
--- /dev/null
+++ b/pretyping/evarutil.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: evarutil.mli,v 1.33.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Rawterm
+open Term
+open Sign
+open Evd
+open Environ
+open Reductionops
+(*i*)
+
+(*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 *)
+
+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
+
+(* Replacing all evars *)
+exception Uninstantiated_evar of existential_key
+val whd_ise :  evar_map -> constr -> constr
+val whd_castappevar :  evar_map -> constr -> constr
+
+(* Creating new existential variables *)
+val new_evar : unit -> evar
+val new_evar_in_sign : env -> constr
+
+val evar_env :  evar_info -> env
+
+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
+
+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
+
+val new_isevar_sign :
+ Environ.env -> Evd.evar_map -> Term.constr -> Term.constr list ->
+  Evd.evar_map * Term.constr
+
+val new_isevar :  evar_defs -> env -> loc * hole_kind -> constr -> constr
+
+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
+
+val define_evar_as_arrow : evar_defs -> existential -> types
+val define_evar_as_sort : evar_defs -> existential -> sorts
+
+(* 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 val_constraint = constr option
+
+val empty_tycon : type_constraint
+val mk_tycon : 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
+
+val valcon_of_tycon : type_constraint -> val_constraint
+
+val lift_tycon : type_constraint -> type_constraint
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
new file mode 100644
index 00000000..7a3e7c02
--- /dev/null
+++ b/pretyping/evd.ml
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: evd.ml,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Sign
+
+(* The type of mappings for existential variables *)
+
+type evar = existential_key
+
+type evar_body =
+  | Evar_empty 
+  | Evar_defined of constr
+
+type evar_info = {
+  evar_concl : constr;
+  evar_hyps : named_context;
+  evar_body : evar_body}
+
+module Evarmap = Intmap
+
+type evar_map = evar_info Evarmap.t
+
+let empty = Evarmap.empty
+
+let to_list evc = Evarmap.fold (fun ev x acc -> (ev,x)::acc) evc []
+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 add evd ev newinfo =  Evarmap.add ev newinfo evd
+
+let define evd ev body = 
+  let oldinfo = map evd ev in
+  let newinfo =
+    { evar_concl = oldinfo.evar_concl;
+      evar_hyps = oldinfo.evar_hyps;
+      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
+    
+let is_evar sigma ev = in_dom sigma ev
+
+let is_defined sigma ev =
+  let info = map sigma ev in 
+  not (info.evar_body = Evar_empty)
+
+let evar_body ev = ev.evar_body
+
+let string_of_existential ev = "?" ^ string_of_int ev
+
+let existential_of_int ev = ev
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
new file mode 100644
index 00000000..f66667aa
--- /dev/null
+++ b/pretyping/evd.mli
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: evd.mli,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+(*i*)
+
+(* The type of mappings for existential variables.
+   The keys are integers and the associated information is a record
+   containing the type of the evar ([evar_concl]), the context under which 
+   it was introduced ([evar_hyps]) and its definition ([evar_body]). 
+   [evar_info] is used to add any other kind of information. *)
+
+type evar = existential_key
+
+type evar_body =
+  | Evar_empty 
+  | Evar_defined of constr
+
+type evar_info = {
+  evar_concl : constr;
+  evar_hyps : named_context;
+  evar_body : evar_body}
+
+type evar_map
+
+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 to_list : evar_map -> (evar * evar_info) list
+
+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_body : evar_info -> evar_body
+
+val string_of_existential : evar -> string
+val existential_of_int : int -> evar
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
new file mode 100644
index 00000000..0b9283ae
--- /dev/null
+++ b/pretyping/indrec.ml
@@ -0,0 +1,553 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: indrec.ml,v 1.20.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Termops
+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
+
+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)
+
+(*******************************************)
+(* Building curryfied elimination          *)
+(*******************************************)
+
+(**********************************************************************)
+(* Building case analysis schemes *)
+(* Nouvelle version, plus concise mais plus coûteuse à cause de
+   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 dep = match depopt with 
+    | None -> mip.mind_sort <> (Prop Null)
+    | Some d -> d
+  in
+  if not (List.exists ((=) kind) mip.mind_kelim) then
+    raise
+      (InductiveError
+	 (NotAllowedCaseAnalysis
+	    (dep,(new_sort_in_family kind),ind)));
+
+  let nbargsprod = 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) *)
+  let env' = push_rel_context lnamespar env in
+
+  let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in
+  let constrs = get_constructors env indf in
+
+  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 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
+      it_mkLambda_or_LetIn_name env'
+       	(mkCase (ci, lift nbargsprod p,
+		     mkRel 1,
+		     rel_vect nbargsprod k))
+       	deparsign
+    else
+      let cs = lift_constructor (k+1) constrs.(k) in
+      let t = build_branch_type env dep (mkRel (k+1)) cs in
+      mkLambda_string "f" t
+	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
+  in
+  let typP = make_arity env' dep indf (new_sort_in_family kind) in
+  it_mkLambda_or_LetIn_name env 
+    (mkLambda_string "P" typP
+       (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
+    
+(* check if the type depends recursively on one of the inductive scheme *)
+
+(**********************************************************************)
+(* Building the recursive elimination *)
+
+(*
+ * t is the type of the constructor co and recargs is the information on 
+ * the recursive calls. (It is assumed to be in form given by the user).
+ * build the type of the corresponding branch of the recurrence principle
+ * assuming f has this type, branch_rec gives also the term 
+ *   [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of 
+ * the case operation
+ * FPvect gives for each inductive definition if we want an elimination 
+ * on it with which predicate and which recursive function. 
+ *)
+
+let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = 
+  let make_prod = make_prod_dep dep in
+  let nparams = List.length vargs in
+  let process_pos env depK pk =
+    let rec prec env i sign p =
+      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      match kind_of_term p' with
+	| Prod (n,t,c) ->
+	    let d = (n,None,t) in
+	    make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c)
+	| LetIn (n,b,t,c) ->
+	    let d = (n,Some b,t) in
+	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
+     	| Ind (_,_) ->
+	    let realargs = list_skipn nparams largs in
+	    let base = applist (lift i pk,realargs) in
+            if depK then 
+	      Reduction.beta_appvect
+                base [|applist (mkRel (i+1),extended_rel_list 0 sign)|]
+            else 
+	      base
+      	| _ -> assert false 
+    in
+    prec env 0 []
+  in
+  let rec process_constr env i c recargs nhyps li =
+    if nhyps > 0 then match kind_of_term c with 
+      | Prod (n,t,c_0) ->
+          let (optionpos,rest) = 
+	    match recargs with 
+	      | [] -> None,[]
+              | ra::rest ->
+                  (match dest_recarg ra with 
+	            | Mrec j when is_rec -> (depPvect.(j),rest)
+	            | Imbr _  -> 
+		        Options.if_verbose warning "Ignoring recursive call"; 
+		        (None,rest) 
+                    | _ -> (None, rest))
+	  in 
+          (match optionpos with 
+	     | None -> 
+		 make_prod env
+		   (n,t,
+		    process_constr (push_rel (n,None,t) env) (i+1) c_0 rest
+		      (nhyps-1) (i::li))
+             | Some(dep',p) -> 
+		 let nP = lift (i+1+decP) p in
+                 let env' = push_rel (n,None,t) env in
+		 let t_0 = process_pos env' dep' nP (lift 1 t) in 
+		 make_prod_dep (dep or dep') env
+                   (n,t,
+		    mkArrow t_0
+		      (process_constr
+			(push_rel (Anonymous,None,t_0) env')
+			 (i+2) (lift 1 c_0) rest (nhyps-1) (i::li))))
+      | LetIn (n,b,t,c_0) ->
+	  mkLetIn (n,b,t,
+		   process_constr
+		     (push_rel (n,Some b,t) env)
+		     (i+1) c_0 recargs (nhyps-1) li)
+      | _ -> assert false
+    else
+      if dep then
+	let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in
+        let params = List.map (lift i) vargs in
+        let co = applist (mkConstruct cs.cs_cstr,params@realargs) in
+	Reduction.beta_appvect c [|co|]
+      else c
+  in
+  let nhyps = List.length cs.cs_args in
+  let nP = match depPvect.(tyi) with 
+    | Some(_,p) -> lift (nhyps+decP) p
+    | _ -> assert false in
+  let base = appvect (nP,cs.cs_concl_realargs) in
+  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 process_pos env fk  =
+    let rec prec env i hyps p =
+      let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
+      match kind_of_term p' with
+	| Prod (n,t,c) ->
+	    let d = (n,None,t) in
+	    lambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c)
+	| LetIn (n,b,t,c) ->
+	    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
+            and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in 
+            applist(lift i fk,realargs@[arg])
+     	| _ -> assert false
+    in
+    prec env 0 []
+  in
+  (* ici, cstrprods est la liste des produits du constructeur instantié *)
+  let rec process_constr env i f = function
+    | (n,None,t as d)::cprest, recarg::rest -> 
+        let optionpos = 
+	  match dest_recarg recarg with 
+            | Norec   -> None
+            | Imbr _  -> None
+            | Mrec i  -> fvect.(i)
+	in 
+        (match optionpos with 
+           | None ->
+	       lambda_name env
+		 (n,t,process_constr (push_rel d env) (i+1)
+		    (whd_beta (applist (lift 1 f, [(mkRel 1)])))
+		    (cprest,rest))
+           | Some(_,f_0) -> 
+	       let nF = lift (i+1+decF) f_0 in
+               let env' = push_rel d env in
+	       let arg = process_pos env' nF (lift 1 t) in 
+               lambda_name env
+		 (n,t,process_constr env' (i+1)
+		    (whd_beta (applist (lift 1 f, [(mkRel 1); arg])))
+		    (cprest,rest)))
+    | (n,Some c,t as d)::cprest, rest ->
+	mkLetIn
+	  (n,c,t,
+	   process_constr (push_rel d env) (i+1) (lift 1 f)
+	     (cprest,rest))
+    | [],[] -> f
+    | _,[] | [],_ -> anomaly "process_constr"
+
+  in
+  process_constr env 0 f (List.rev cstr.cs_args, recargs)
+
+(* 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 nrec = List.length listdepkind in
+  let depPvec =
+    Array.create mib.mind_ntypes (None : (bool * constr) option) in 
+  let _ = 
+    let rec 
+      assign k = function 
+	| [] -> ()
+        | (indi,mibi,mipi,dep,_)::rest -> 
+            (Array.set depPvec (snd indi) (Some(dep,mkRel k));
+             assign (k-1) rest)
+    in 
+    assign nrec listdepkind in 
+  let recargsvec =
+    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+  let make_one_rec p =
+    let makefix nbconstruct =
+      let rec mrec i ln ltyp ldef = function
+	| (indi,mibi,mipi,dep,_)::rest ->
+	    let tyi = snd indi in
+	    let nctyi =
+              Array.length mipi.mind_consnames in (* nb constructeurs du type*)
+
+            (* 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 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 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
+	      let constrs = get_constructors env indf' in
+	      let vecfi = rel_vect (dect+1-i-nctyi) nctyi in
+	      array_map3
+		(make_rec_branch_arg env sigma (nparams,depPvec,nar+1))
+                vecfi constrs (dest_subterms recargsvec.(tyi)) in
+	    let j = (match depPvec.(tyi) with 
+		       | Some (_,c) when isRel c -> destRel c 
+		       | _ -> assert false) in
+	    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
+	      in
+	      it_mkLambda_or_LetIn_name env
+		(lambda_create env
+		  (depind,mkCase (ci, lift (nar+1) p, mkRel 1, branches)))
+		lnames'
+	    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
+        | [] -> 
+	    let fixn = Array.of_list (List.rev ln) in
+            let fixtyi = Array.of_list (List.rev ltyp) in
+            let fixdef = Array.of_list (List.rev ldef) in 
+            let names = Array.create nrec (Name(id_of_string "F")) in
+	    mkFix ((fixn,p),(names,fixtyi,fixdef))
+      in 
+      mrec 0 [] [] [] 
+    in 
+    let rec make_branch env i = function 
+      | (indi,mibi,mipi,dep,_)::rest ->
+          let tyi = snd indi in
+	  let nconstr = Array.length mipi.mind_consnames in
+	  let rec onerec env j = 
+	    if j = nconstr then 
+	      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 cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
+	      let p_0 =
+		type_rec_branch
+                  true dep env sigma (vargs,depPvec,i+j) tyi cs recarg
+	      in 
+	      mkLambda_string "f" p_0
+		(onerec (push_rel (Anonymous,None,p_0) env) (j+1))
+	  in onerec env 0
+      | [] -> 
+	  makefix i listdepkind
+    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 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 
+    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 
+  in 
+  list_tabulate make_one_rec nrec
+
+(**********************************************************************)
+(* This builds elimination predicate for Case tactic *)
+
+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
+
+let make_case_dep env   = make_case_com (Some true) env
+let make_case_nodep env = make_case_com (Some false) env 
+let make_case_gen env   = make_case_com None env
+
+
+(**********************************************************************)
+(* [instanciate_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 
+    | Prod (n,t,c) -> mkProd (n, 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 rec drec npar elim =
+    match kind_of_term elim with
+      | Lambda (n,t,c) -> 
+	  if npar = 0 then 
+	    mkLambda (n, change_sort_arity sort t, c)
+	  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"
+  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 rec drec np elim =
+    match kind_of_term elim with
+      | Prod (n,t,c) -> 
+	  if np = 0 then 
+            let t' = change_sort_arity sort t in
+            mkProd (n, t', c),
+            mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1)))
+	  else 
+            let c',term' = drec (np-1) c in
+	    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"
+  in
+  drec npars
+
+(**********************************************************************)
+(* Interface to build complex Scheme *)
+
+let check_arities listdepkind = 
+  List.iter 
+    (function (indi,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 build_mutual_indrec env sigma = function 
+  | (mind,mib,mip,dep,s)::lrecspec ->
+      let (sp,tyi) = mind in
+      let listdepkind = 
+    	(mind,mib,mip, dep,s)::
+    	(List.map
+	   (function (mind',mibi',mipi',dep',s') ->
+	      let (sp',_) = mind' in
+	      if sp=sp' then 
+                let (mibi',mipi') = lookup_mind_specif env mind' in
+		(mind',mibi',mipi',dep',s') 
+	      else 
+		raise (InductiveError NotMutualInScheme))
+	   lrecspec)
+      in
+      let _ = check_arities listdepkind in 
+      mis_make_indrec env sigma listdepkind (mind,mib,mip)
+  | _ -> 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 dep = kind <> InProp in
+  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip))
+
+(**********************************************************************)
+(* To handle old Case/Match syntax in Pretyping                       *)
+
+(*****************************************)
+(* To interpret Case and Match operators *)
+(* Expects a dependent predicate *)
+
+let type_rec_branches recursive env sigma indt p c = 
+  let IndType (indf,realargs) = 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 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
+      (type_rec_branch recursive true env sigma (params,depPvec,0) tyi)
+      constructors (dest_subterms recargs) in
+  (lft,Reduction.beta_appvect p (Array.of_list (realargs@[c])))
+(* Non recursive case. Pb: does not deal with unification
+    let (p,ra,_) = type_case_branches env (ind,params@realargs) pj c in
+    (p,ra)
+*)
+
+(*s Eliminations. *)
+
+let elimination_suffix = function
+  | InProp -> "_ind"
+  | InSet  -> "_rec"
+  | InType -> "_rect"
+
+let make_elimination_ident id s = add_suffix id (elimination_suffix s)
+
+(* Look up function for the default elimination constant *)
+
+let lookup_eliminator ind_sp s =
+  let kn,i = ind_sp in
+  let mp,dp,l = repr_kn kn in
+  let ind_id = (Global.lookup_mind kn).mind_packets.(i).mind_typename in
+  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
+  try 
+    let _ = sp_of_global ref in
+    constr_of_reference 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))
+  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 ++
+       str " is probably not allowed")
+
+
+(*  let env = Global.env() in
+  let path = sp_of_global None (IndRef ind_sp) in
+  let dir, base = repr_path path in
+  let id = add_suffix base (elimination_suffix s) in
+  (* Try first to get an eliminator defined in the same section as the *)
+  (* inductive type *)
+  try construct_absolute_reference (Names.make_path dir id)
+  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))
+    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 ++
+	   str " is probably not allowed")
+*)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
new file mode 100644
index 00000000..f6f76706
--- /dev/null
+++ b/pretyping/indrec.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: indrec.mli,v 1.6.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Declarations
+open Inductiveops
+open Environ
+open Evd
+(*i*)
+
+(* Eliminations. *)
+
+(* These functions build elimination predicate for Case tactic *)
+
+val make_case_dep : env -> evar_map -> inductive -> sorts_family -> constr
+val make_case_nodep : env -> evar_map -> inductive -> sorts_family -> constr
+val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr
+
+(* This builds an elimination scheme associated (using the own arity
+   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 ->
+  constr * types
+
+(* This builds complex [Scheme] *)
+
+val build_mutual_indrec : 
+  env -> evar_map ->
+    (inductive * mutual_inductive_body * one_inductive_body
+    * bool * sorts_family) list
+    -> constr list
+
+(* These are for old Case/Match typing *)
+
+val type_rec_branches : bool -> env -> evar_map -> inductive_type
+  -> constr -> constr -> constr array * constr
+val make_rec_branch_arg : 
+  env -> evar_map ->
+    int * ('b * constr) option array * int ->
+    constr -> constructor_summary -> wf_paths list -> constr
+
+(* *)
+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
new file mode 100644
index 00000000..24a8fbc7
--- /dev/null
+++ b/pretyping/inductiveops.ml
@@ -0,0 +1,352 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: inductiveops.ml,v 1.14.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Names
+open Univ
+open Term
+open Termops
+open Sign
+open Declarations
+open Environ
+open Reductionops
+
+(* [inductive_family] = [inductive_instance] applied to global parameters *)
+type inductive_family = inductive * constr list
+
+let make_ind_family (mis, params) = (mis,params)
+let dest_ind_family (mis,params) = (mis,params)
+
+let map_ind_family f (mis,params) = (mis, List.map f params)
+
+let liftn_inductive_family n d = map_ind_family (liftn n d)
+let lift_inductive_family n = liftn_inductive_family n 1
+
+let substnl_ind_family l n = map_ind_family (substnl l n)
+
+
+type inductive_type = IndType of inductive_family * constr list
+
+let make_ind_type (indf, realargs) = IndType (indf,realargs)
+let dest_ind_type (IndType (indf,realargs)) = (indf,realargs)
+
+let map_inductive_type f (IndType (indf, realargs)) =
+  IndType (map_ind_family f indf, List.map f realargs)
+
+let liftn_inductive_type n d = map_inductive_type (liftn n d)
+let lift_inductive_type n = liftn_inductive_type n 1
+
+let substnl_ind_type l n = map_inductive_type (substnl l n)
+
+let mkAppliedInd (IndType ((ind,params), realargs)) =
+  applist (mkInd ind,params@realargs)
+
+
+(* Does not consider imbricated or mutually recursive types *) 
+let mis_is_recursive_subset listind rarg = 
+  let rec one_is_rec rvec = 
+    List.exists
+      (fun ra ->
+        match dest_recarg ra with
+	  | Mrec i -> List.mem i listind 
+          | _ -> false) rvec
+  in 
+  array_exists one_is_rec (dest_subterms rarg)
+
+let mis_is_recursive (ind,mib,mip) =
+  mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1))
+    mip.mind_recargs
+
+let mis_nf_constructor_type (ind,mib,mip) j =
+  let specif = mip.mind_nf_lc
+  and ntypes = mib.mind_ntypes
+  and nconstr = Array.length mip.mind_consnames in
+  let make_Ik k = mkInd ((fst ind),ntypes-k-1) in 
+  if j > nconstr then error "Not enough constructors in the type";
+  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
+  Array.map List.length recargs
+
+let mis_constr_nargs_env env (kn,i) = 
+  let mib = Environ.lookup_mind kn env in
+  let mip = mib.mind_packets.(i) in 
+  let recargs = dest_subterms mip.mind_recargs in
+  Array.map List.length recargs
+
+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
+
+(* Annotation for cases *)
+let make_case_info env ind style pats_source =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let print_info =
+    { ind_nargs = mip.mind_nrealargs;
+      style     = style;
+      source    = pats_source } in
+  { ci_ind     = ind;
+    ci_npar    = mip.mind_nparams;
+    ci_pp_info = print_info }
+
+let make_default_case_info env style ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  make_case_info env ind style
+    (Array.map (fun _ -> RegularPat) mip.mind_consnames)
+
+(*s Useful functions *)
+
+type constructor_summary = {
+  cs_cstr : constructor;
+  cs_params : constr list;
+  cs_nargs : int;
+  cs_args : rel_context;
+  cs_concl_realargs : constr array
+}
+
+let lift_constructor n cs = {
+  cs_cstr = cs.cs_cstr;
+  cs_params = List.map (lift n) cs.cs_params;
+  cs_nargs = cs.cs_nargs;
+  cs_args = lift_rel_context n cs.cs_args;
+  cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
+}
+
+let instantiate_params t args sign =
+  let rec inst s t = function
+    | ((_,None,_)::ctxt,a::args) ->
+	(match kind_of_term t with
+	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
+	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
+    | ((_,(Some b),_)::ctxt,args) -> 
+	(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
+    | _ -> 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 (args,ccl) = decompose_prod_assum typi in
+  let (_,allargs) = decompose_app ccl in
+  let vargs = list_skipn mip.mind_nparams allargs in
+  { cs_cstr = ith_constructor_of_inductive ind j;
+    cs_params = params;
+    cs_nargs = rel_context_length args;
+    cs_args = args;
+    cs_concl_realargs = Array.of_list vargs }
+
+let get_constructors env (ind,params) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  Array.init (Array.length mip.mind_consnames)
+    (fun j -> get_constructor (ind,mib,mip,params) (j+1))
+
+let rec instantiate args c = match kind_of_term c, args with
+  | Prod (_,_,c), a::args -> instantiate args (subst1 a c)
+  | LetIn (_,b,_,c), args -> instantiate args (subst1 b c)
+  | _, [] -> c
+  | _ -> anomaly "too short arity"
+
+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)
+
+(* Functions to build standard types related to inductive *)
+let build_dependent_constructor cs =
+  applist
+    (mkConstruct cs.cs_cstr,
+     (List.map (lift cs.cs_nargs) cs.cs_params)
+      @(extended_rel_list 0 cs.cs_args))
+
+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
+  applist 
+    (mkInd ind,
+     (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
+
+(* builds the arity of an elimination predicate in sort [s] *)
+
+let make_arity_signature env dep indf =
+  let (arsign,_) = get_arity env indf in
+  if dep then
+    (* 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 *)
+  else
+    (* No need to enforce names *)
+    arsign
+
+let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s)
+
+(* [p] is the predicate and [cs] a constructor summary *)
+let build_branch_type env dep p cs =
+  let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in
+  if dep then
+    it_mkProd_or_LetIn_name env
+      (applist (base,[build_dependent_constructor cs]))
+      cs.cs_args
+  else
+    it_mkProd_or_LetIn base cs.cs_args
+
+(**************************************************)
+
+let extract_mrectype t =
+  let (t, l) = decompose_app t in
+  match kind_of_term t with
+    | Ind ind -> (ind, l)
+    | _ -> raise Not_found
+
+let find_mrectype env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind -> (ind, l)
+    | _ -> raise Not_found
+
+let find_rectype env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  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
+        IndType((ind, par),rargs)
+    | _ -> raise Not_found
+
+let find_inductive env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind
+        when (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        (ind, l)
+    | _ -> raise Not_found
+
+let find_coinductive env sigma c =
+  let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
+  match kind_of_term t with
+    | Ind ind
+        when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        (ind, l)
+    | _ -> raise Not_found
+
+
+(***********************************************)
+(* find appropriate names for pattern variables. Useful in the
+   Case tactic. *)
+
+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 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
+
+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 arities =
+    Array.map
+      (fun c ->
+        rel_context_length (fst (decompose_prod_assum c)) -
+        mip.mind_nparams)
+      mip.mind_nf_lc in
+  array_map2 (set_names env) arities brv
+
+
+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
+    (set_pattern_names env ind lbrty, conclty)
+  else (lbrty, conclty)
+
+(* Type of Case predicates *)
+let arity_of_case_predicate env (ind,params) dep k =
+  let arsign,_ = get_arity env (ind,params) in
+  let mind = build_dependent_inductive env (ind,params) in
+  let concl = if dep then mkArrow mind (mkSort k) else mkSort k in
+  it_mkProd_or_LetIn concl arsign
+
+(***********************************************)
+(* Guard condition *)
+
+(* A function which checks that a term well typed verifies both
+   syntactic conditions *)
+
+let control_only_guard env = 
+  let rec control_rec c = match kind_of_term c with
+    | Rel _ | Var _    -> ()
+    | Sort _ | Meta _ -> ()
+    | Ind _       -> ()
+    | Construct _ -> ()
+    | Const _        -> ()
+    | CoFix (_,(_,tys,bds) as cofix) ->
+	Inductive.check_cofix env cofix;
+	Array.iter control_rec tys;
+	Array.iter control_rec bds;
+    | Fix (_,(_,tys,bds) as fix) ->
+	Inductive.check_fix env fix; 
+	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
+    | App (_,cl)         -> Array.iter control_rec cl
+    | 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 
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
new file mode 100644
index 00000000..a8dcef29
--- /dev/null
+++ b/pretyping/inductiveops.mli
@@ -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        *)
+(************************************************************************)
+
+(* $Id: inductiveops.mli,v 1.10.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Evd
+
+(* An inductive type with its parameters *)
+type inductive_family
+val make_ind_family : inductive * constr list -> inductive_family
+val dest_ind_family : inductive_family -> inductive * constr list
+val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family
+val liftn_inductive_family : int -> int -> inductive_family -> inductive_family
+val lift_inductive_family  : int -> inductive_family -> inductive_family
+val substnl_ind_family :
+  constr list -> int -> inductive_family -> inductive_family
+
+(* An inductive type with its parameters and real arguments *)
+type inductive_type = IndType of inductive_family * constr list
+val make_ind_type : inductive_family * constr list -> inductive_type
+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 mkAppliedInd : inductive_type -> constr
+val mis_is_recursive_subset : int list -> wf_paths -> bool
+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
+
+val mis_constr_nargs_env : env -> inductive -> int array
+
+val mis_constructor_nargs_env : env -> constructor -> int
+
+type constructor_summary = {
+  cs_cstr : constructor;
+  cs_params : constr list;
+  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_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 : env -> bool -> inductive_family -> sorts -> types
+val build_branch_type : env -> bool -> constr -> constructor_summary -> types
+
+(* Raise Not_found if not given an valid inductive type *)
+val extract_mrectype : constr -> inductive * constr list
+val find_mrectype    : env -> evar_map -> constr -> inductive * constr list
+val find_rectype     : env -> evar_map -> constr -> inductive_type
+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 :
+  env -> inductive_family -> bool -> sorts -> types
+
+val type_case_branches_with_names :
+  env -> inductive * constr list -> unsafe_judgment -> constr ->
+    types array * types
+val make_case_info :
+  env -> inductive -> case_style -> pattern_source array -> case_info
+val make_default_case_info : env -> case_style -> inductive -> case_info
+
+(********************)
+val control_only_guard : env -> types -> unit
diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml
new file mode 100644
index 00000000..702cdfea
--- /dev/null
+++ b/pretyping/instantiate.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/instantiate.mli b/pretyping/instantiate.mli
new file mode 100644
index 00000000..44c4d579
--- /dev/null
+++ b/pretyping/instantiate.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: instantiate.mli,v 1.2.14.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Evd
+open Sign
+open Environ
+(*i*)
+
+(*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
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
new file mode 100644
index 00000000..bdab3b5b
--- /dev/null
+++ b/pretyping/matching.ml
@@ -0,0 +1,254 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: matching.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Libnames
+open Nameops
+open Termops
+open Reductionops
+open Term
+open Rawterm
+open Environ
+open Pattern
+(*i*)
+
+(* Given a term with second-order variables in it,
+   represented by Meta's, and possibly applied using [SOAPP] to
+   terms, this function will perform second-order, binding-preserving,
+   matching, in the case where the pattern is a pattern in the sense
+   of Dale Miller.
+
+   ALGORITHM:
+
+   Given a pattern, we decompose it, flattening Cast's and apply's,
+   recursing on all operators, and pushing the name of the binder each
+   time we descend a binder.
+
+   When we reach a first-order variable, we ask that the corresponding
+   term's free-rels all be higher than the depth of the current stack.
+
+   When we reach a second-order application, we ask that the
+   intersection of the free-rels of the term and the current stack be
+   contained in the arguments of the application, and in that case, we
+   construct a LAMBDA with the names on the stack.
+
+ *)
+
+exception PatternMatchingFailure
+
+let constrain (n,m) sigma =
+  if List.mem_assoc n sigma then
+    if eq_constr m (List.assoc n sigma) then sigma
+    else raise PatternMatchingFailure
+  else 
+    (n,m)::sigma
+    
+let build_lambda toabstract stk (m : constr) = 
+  let rec buildrec m p_0 p_1 = match p_0,p_1 with 
+    | (_, []) -> m
+    | (n, (na,t)::tl) -> 
+	if List.mem n toabstract then
+          buildrec (mkLambda (na,t,m)) (n+1) tl
+        else 
+	  buildrec (lift (-1) m) (n+1) tl
+  in 
+  buildrec m 1 stk
+
+let memb_metavars m n =
+  match (m,n) with
+    | (None, _)     -> true
+    | (Some mvs, n) -> List.mem n mvs
+
+let eq_context ctxt1 ctxt2 = array_for_all2 eq_constr ctxt1 ctxt2
+
+let matches_core convert allow_partial_app pat c = 
+  let rec sorec stk sigma p t =
+    let cT = strip_outer_cast t in
+    match p,kind_of_term cT with
+      | PSoApp (n,args),m ->
+	  let relargs =
+	    List.map
+	      (function
+		 | PRel n -> n
+		 | _ -> error "Only bound indices are currently allowed in second order pattern matching")
+	      args in
+	  let frels = Intset.elements (free_rels cT) in
+	  if list_subset frels relargs then
+	    constrain (n,build_lambda relargs stk cT) sigma
+	  else
+	    raise PatternMatchingFailure
+
+      | 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
+
+      | PMeta None, m -> sigma
+
+      | PRef (VarRef v1), Var v2 when v1 = v2 -> sigma
+
+      | PVar v1, Var v2 when v1 = v2 -> sigma
+
+      | PRef ref, _ when constr_of_reference ref = cT -> sigma
+
+      | PRel n1, Rel n2 when n1 = n2 -> sigma
+
+      | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> sigma
+
+      | PSort (RType _), Sort (Type _) -> sigma
+
+      | 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
+            let args21, args22 = array_chop p args2 in
+            let sigma =
+	      let depth = List.length stk in
+              let c = mkApp(c2,args21) in
+	      let frels = Intset.elements (free_rels c) in
+              if List.for_all (fun i -> i > depth) frels then
+	        constrain (n,lift (-depth) c) sigma
+              else
+	        raise PatternMatchingFailure in
+            array_fold_left2 (sorec stk) sigma args1 args22
+          else raise PatternMatchingFailure
+
+      | PApp (c1,arg1), App (c2,arg2) ->
+        (try array_fold_left2 (sorec stk) (sorec stk sigma c1 c2) arg1 arg2
+         with Invalid_argument _ -> raise PatternMatchingFailure)
+
+      | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
+	  sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2
+
+      | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
+	  sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2
+
+      | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
+	  sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2
+
+      | PRef (ConstRef _ as ref), _ when convert <> None ->
+	  let (env,evars) = out_some convert in
+	  let c = constr_of_reference 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
+          else
+            raise PatternMatchingFailure
+      (* À faire *)
+      |	PFix f0, Fix f1 when f0 = f1 -> sigma
+      |	PCoFix c0, CoFix c1 when c0 = c1 -> sigma
+      | _ -> raise PatternMatchingFailure
+
+  in 
+  Sort.list (fun (a,_) (b,_) -> a<b) (sorec [] [] pat c)
+
+let matches = matches_core None false
+
+let pmatches = matches_core None true
+
+(* To skip to the next occurrence *)
+exception NextOccurrence of int
+
+(* Tells if it is an authorized occurrence and if the instance is closed *)
+let authorized_occ nocc mres =
+  if not (List.for_all (fun (_,c) -> closed0 c) (fst mres)) then
+    raise PatternMatchingFailure;
+  if nocc = 0 then mres
+  else raise (NextOccurrence nocc)
+
+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) ->
+    (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))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in
+      (lm,mkCast (List.hd lc, 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
+      (lm,mkLambda (x,List.hd lc,List.nth lc 1))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in
+      (lm,mkLambda (x,List.hd lc,List.nth lc 1)))
+  | Prod (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
+      (lm,mkProd (x,List.hd lc,List.nth lc 1))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in
+      (lm,mkProd (x,List.hd lc,List.nth lc 1)))
+  | LetIn (x,c1,t2,c2) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in
+      (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2))
+    | NextOccurrence nocc ->
+      let (lm,lc) = try_sub_match (nocc - 1) pat [c1;t2;c2] in
+      (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2)))
+  | App (c1,lc) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,le) = try_sub_match nocc pat (c1::(Array.to_list lc)) in
+      (lm,mkApp (List.hd le, Array.of_list (List.tl le)))
+    | NextOccurrence nocc ->
+      let (lm,le) = try_sub_match (nocc - 1) pat (c1::(Array.to_list lc)) in
+      (lm,mkApp (List.hd le, Array.of_list (List.tl le))))
+  | Case (ci,hd,c1,lc) ->
+    (try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
+    | PatternMatchingFailure ->
+      let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in
+      (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le)))
+    | NextOccurrence nocc ->
+      let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in
+      (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))))
+  | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _
+  | Rel _|Meta _|Var _|Sort _ ->
+    (try authorized_occ nocc ((matches pat c),mkMeta special_meta) with
+    | PatternMatchingFailure -> raise (NextOccurrence nocc)
+    | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1)))
+
+(* Tries [sub_match] for all terms in the list *)
+and try_sub_match nocc pat lc =
+  let rec try_sub_match_rec nocc pat lacc = function
+    | [] -> raise (NextOccurrence nocc)
+    | c::tl ->
+      (try 
+         let (lm,ce) = sub_match nocc pat c in
+         (lm,lacc@(ce::tl))
+       with
+      | NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in
+  try_sub_match_rec nocc pat [] lc
+
+let is_matching pat n =
+  try let _ = matches pat n in true
+  with PatternMatchingFailure -> false
+
+let matches_conv env sigma = matches_core (Some (env,sigma)) false
+
+let is_matching_conv env sigma pat n =
+  try let _ = matches_conv env sigma pat n in true
+  with PatternMatchingFailure -> false
+
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
new file mode 100644
index 00000000..808c46a4
--- /dev/null
+++ b/pretyping/matching.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: matching.mli,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Pattern
+open Termops
+(*i*)
+
+(*s This modules implements pattern-matching on terms *)
+
+exception PatternMatchingFailure
+
+val special_meta : metavariable
+
+(* [matches pat c] matches [c] against [pat] and returns the resulting
+   assignment of metavariables; it raises [PatternMatchingFailure] if
+   not matchable; bindings are given in increasing order based on the
+   numbers given in the pattern *)
+val matches : constr_pattern -> constr -> patvar_map
+
+(* [is_matching pat c] just tells if [c] matches against [pat] *)
+
+val is_matching : constr_pattern -> constr -> bool
+
+(* [matches_conv env sigma] matches up to conversion in environment
+   [(env,sigma)] when constants in pattern are concerned; it raises
+   [PatternMatchingFailure] if not matchable; bindings are given in
+   increasing order based on the numbers given in the pattern *)
+
+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
+
+(* [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
+   up to conversion for constants in patterns *)
+
+val is_matching_conv :
+  env -> Evd.evar_map -> constr_pattern -> constr -> bool
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
new file mode 100644
index 00000000..80ab1b6e
--- /dev/null
+++ b/pretyping/pattern.ml
@@ -0,0 +1,287 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pattern.ml,v 1.24.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Rawterm
+open Environ
+open Nametab
+open Pp
+
+(* 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 =
+  | PRef of global_reference
+  | PVar of identifier
+  | PEvar of existential_key * constr_pattern array
+  | PRel of int
+  | PApp of constr_pattern * constr_pattern array
+  | PSoApp of patvar * constr_pattern list
+  | PLambda of name * constr_pattern * constr_pattern
+  | PProd of name * constr_pattern * 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
+  | PFix of fixpoint
+  | PCoFix of cofixpoint
+
+let rec occur_meta_pattern = function
+  | PApp (f,args) ->
+      (occur_meta_pattern f) or (array_exists occur_meta_pattern args)
+  | 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) ->
+      (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
+  | CstrNode of constructor
+  | VarNode of identifier
+
+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
+    | PCase (_,p,c,br) -> head_pattern_bound c
+    | PRef r         -> label_of_ref r
+    | PVar id        -> VarNode id
+    | PEvar _ | PRel _ | PMeta _ | PSoApp _  | PSort _ | PFix _
+	-> raise BoundPattern
+    (* Perhaps they were arguments, but we don't beta-reduce *)
+    | PLambda _ -> raise BoundPattern
+    | 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
+  | _ -> anomaly "Not a rigid reference"
+
+let rec pattern_of_constr t =
+  match kind_of_term t with
+    | Rel n  -> PRel n
+    | Meta n -> PMeta (Some (id_of_string (string_of_int n)))
+    | Var id -> PVar id
+    | Sort (Prop c) -> PSort (RProp c)
+    | Sort (Type _) -> PSort (RType None)
+    | 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)
+    | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a)
+    | Const sp         -> PRef (ConstRef sp)
+    | Ind sp        -> PRef (IndRef sp)
+    | 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,
+	       Array.map pattern_of_constr br)
+    | Fix f -> PFix f
+    | CoFix _ ->
+	error "pattern_of_constr: (co)fix currently not supported"
+
+(* 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)
+  (* Non recursive *)
+  | (PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _ as x) -> x 
+  (* Bound to terms *)
+  | (PFix _ | PCoFix _ as r) ->
+      error ("Not instantiable pattern")
+
+let instantiate_pattern = inst
+
+let rec pat_of_raw metas vars = function
+  | RVar (_,id) ->
+      (try PRel (list_index (Name id) vars)
+       with Not_found -> PVar id)
+  | RPatVar (_,(false,n)) ->
+      metas := n::!metas; PMeta (Some n)
+  | RRef (_,r) ->
+      PRef r
+  (* Hack pour ne pas réécrire une interprétation complète des patterns*)
+  | RApp (_, RPatVar (_,(true,n)), cl) ->
+      PSoApp (n, List.map (pat_of_raw metas vars) cl)
+  | RApp (_,c,cl) -> 
+      PApp (pat_of_raw metas vars c,
+	    Array.of_list (List.map (pat_of_raw metas vars) cl))
+  | RLambda (_,na,c1,c2) ->
+      PLambda (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RProd (_,na,c1,c2) ->
+      PProd (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RLetIn (_,na,c1,c2) ->
+      PLetIn (na, pat_of_raw metas vars c1,
+	       pat_of_raw metas (na::vars) c2)
+  | RSort (_,s) ->
+      PSort s
+  | RHole _ ->
+      PMeta None
+  | 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 =
+	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))
+  | r ->
+      let loc = loc_of_rawconstr r in
+      user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern")
+
+and pat_of_raw_branch loc metas vars ind brs i =
+  let bri = List.filter
+    (function
+        (_,_,[PatCstr(_,c,lv,_)],_) -> 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)] ->
+	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");
+        let lna =
+          List.map
+            (function PatVar(_,na) -> na
+              | PatCstr(loc,_,_,_) ->
+                  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)
+    | _ -> user_err_loc (loc,"pattern_of_rawconstr",
+                         str "No unique branch for " ++ int (i+1) ++
+                         str"-th constructor")
+
+let pattern_of_rawconstr c =
+  let metas = ref [] in
+  let p = pat_of_raw metas [] c in
+  (!metas,p)
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
new file mode 100644
index 00000000..cf0d4528
--- /dev/null
+++ b/pretyping/pattern.mli
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pattern.mli,v 1.17.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Sign
+open Term
+open Environ
+open Libnames
+open Nametab
+open Rawterm
+(*i*)
+
+(* Pattern variables *)
+
+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 =
+  | PRef of global_reference
+  | PVar of identifier
+  | PEvar of existential_key * constr_pattern array
+  | PRel of int
+  | PApp of constr_pattern * constr_pattern array
+  | PSoApp of patvar * constr_pattern list
+  | PLambda of name * constr_pattern * constr_pattern
+  | PProd of name * constr_pattern * 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
+  | PFix of fixpoint
+  | PCoFix of cofixpoint
+
+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
+
+(* [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
+
+(* [pattern_of_constr c] translates a term [c] with metavariables into
+   a pattern; currently, no destructor (Cases, Fix, Cofix) and no
+   existential variable are allowed in [c] *)
+
+val pattern_of_constr : constr -> constr_pattern
+
+(* [pattern_of_rawconstr l c] translates a term [c] with metavariables into
+   a pattern; variables bound in [l] are replaced by the pattern to which they
+    are bound *)
+
+val pattern_of_rawconstr : rawconstr -> 
+      patvar list * constr_pattern
+
+val instantiate_pattern :
+  (identifier * constr_pattern) list -> constr_pattern -> constr_pattern
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
new file mode 100644
index 00000000..fee1522f
--- /dev/null
+++ b/pretyping/pretype_errors.ml
@@ -0,0 +1,164 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pretype_errors.ml,v 1.25.2.2 2004/07/16 19:30:45 herbelin Exp $ *)
+
+open Util
+open Stdpp
+open Names
+open Sign
+open Term
+open Termops
+open Environ
+open Type_errors
+open Rawterm
+open Inductiveops
+
+type pretype_error =
+  (* Old Case *)
+  | CantFindCaseType of constr
+  (* Unification *)
+  | OccurCheck of existential_key * constr
+  | NotClean of existential_key * constr * hole_kind
+  | UnsolvableImplicit of hole_kind
+  (* Pretyping *)
+  | VarNotFound of identifier
+  | UnexpectedType of constr * constr
+  | NotProduct of constr
+
+exception PretypeError of env * pretype_error
+
+let nf_evar = Reductionops.nf_evar
+let j_nf_evar sigma j = 
+  { uj_val = nf_evar sigma j.uj_val;
+    uj_type = nf_evar sigma j.uj_type }
+let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
+let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
+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 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)
+        e)
+    ctxt
+    ~init:env0
+
+(* This simplify the typing context of Cases clauses *)
+(* hope it does not disturb other typing contexts *)
+let contract env lc =
+  let l = ref [] in
+  let contract_context (na,c,t) env =
+    match c with
+      | Some c' when isRel c' ->
+	  l := (substl !l c') :: !l;
+	  env
+      | _ -> 
+	  let t' = substl !l t in
+	  let c' = option_app (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
+  let env = process_rel_context contract_context env in
+  (env, List.map (substl !l) lc)
+
+let contract2 env a b = match contract env [a;b] with
+  | env, [a;b] -> env,a,b | _ -> assert false
+
+let contract3 env a b c = match contract env [a;b;c] with
+  | env, [a;b;c] -> env,a,b,c | _ -> assert false
+
+let raise_pretype_error (loc,ctx,sigma,te) =
+  Stdpp.raise_with_loc loc (PretypeError(env_ise sigma ctx,te))
+
+let raise_located_type_error (loc,ctx,sigma,te) =
+  Stdpp.raise_with_loc loc (TypeError(env_ise sigma ctx,te))
+
+
+let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty =
+  let env, c, actty, expty = contract3 env c actty expty in
+  let j = j_nf_evar sigma {uj_val=c;uj_type=actty} in
+  raise_located_type_error
+    (loc, env, sigma, ActualType (j, nf_evar sigma expty))
+
+let error_cant_apply_not_functional_loc loc env sigma rator randl =
+  let ja = Array.of_list (jl_nf_evar sigma randl) in
+  raise_located_type_error
+    (loc, env, sigma,
+    CantApplyNonFunctional (j_nf_evar sigma rator, ja))
+
+let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl =
+  let ja = Array.of_list (jl_nf_evar sigma randl) in
+  raise_located_type_error
+    (loc, env, sigma,
+     CantApplyBadType
+       ((n,nf_evar sigma c, nf_evar sigma t),
+        j_nf_evar sigma rator, ja))
+
+let error_ill_formed_branch_loc loc env sigma c i actty expty =
+  let simp t = Reduction.nf_betaiota (nf_evar sigma t) in
+  raise_located_type_error
+    (loc, env, sigma,
+     IllFormedBranch (nf_evar sigma c,i,simp actty, simp expty))
+
+let error_number_branches_loc loc env sigma cj expn =
+  raise_located_type_error
+    (loc, env, sigma,
+     NumberBranches (j_nf_evar sigma cj, expn))
+
+let error_case_not_inductive_loc loc env sigma cj =
+  raise_located_type_error
+    (loc, env, sigma, CaseNotInductive (j_nf_evar sigma cj))
+
+let error_ill_typed_rec_body_loc loc env sigma i na jl tys =
+  raise_located_type_error
+    (loc, env, sigma,
+     IllTypedRecBody (i,na,jv_nf_evar sigma jl,
+                      Array.map (nf_evar sigma) tys))
+
+(*s Implicit arguments synthesis errors. It is hard to find
+    a precise location. *)
+
+let error_occur_check env sigma ev c =
+  let c = nf_evar sigma c in
+  raise (PretypeError (env_ise sigma env, OccurCheck (ev,c)))
+
+let error_not_clean env sigma ev c (loc,k) =
+  let c = nf_evar sigma c in
+  raise_with_loc loc
+    (PretypeError (env_ise sigma env,  NotClean (ev,c,k)))
+
+let error_unsolvable_implicit loc env sigma e =
+  raise_with_loc loc (PretypeError (env_ise sigma env, UnsolvableImplicit e))
+
+(*s Ml Case errors *)
+
+let error_cant_find_case_type_loc loc env sigma expr =
+  raise_pretype_error
+    (loc, env, sigma, CantFindCaseType (nf_evar sigma expr))
+
+(*s Pretyping errors *)
+
+let error_unexpected_type_loc loc env sigma actty expty =
+  let env, actty, expty = contract2 env actty expty in
+  raise_pretype_error
+    (loc, env, sigma,
+     UnexpectedType (nf_evar sigma actty, nf_evar sigma expty))
+
+let error_not_product_loc loc env sigma c =
+  raise_pretype_error (loc, env, sigma, NotProduct (nf_evar sigma c))
+
+(*s Error in conversion from AST to rawterms *)
+
+let error_var_not_found_loc loc s =
+  raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s)
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
new file mode 100644
index 00000000..ebeff99d
--- /dev/null
+++ b/pretyping/pretype_errors.mli
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pretype_errors.mli,v 1.25.2.3 2004/07/16 19:30:45 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Rawterm
+open Inductiveops
+(*i*)
+
+(*s The type of errors raised by the pretyper *)
+
+type pretype_error =
+  (* Old Case *)
+  | CantFindCaseType of constr
+  (* Unification *)
+  | OccurCheck of existential_key * constr
+  | NotClean of existential_key * constr * hole_kind
+  | UnsolvableImplicit of hole_kind
+  (* Pretyping *)
+  | VarNotFound of identifier
+  | UnexpectedType of constr * constr
+  | NotProduct of constr
+
+exception PretypeError of env * pretype_error
+
+(* Presenting terms without solved evars *)
+val nf_evar :  Evd.evar_map -> constr -> constr
+val j_nf_evar :  Evd.evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar :
+   Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar :
+   Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar :
+   Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+
+(* Raising errors *)
+val error_actual_type_loc :
+  loc -> env ->  Evd.evar_map -> unsafe_judgment -> constr -> 'b
+
+val error_cant_apply_not_functional_loc : 
+  loc -> env ->  Evd.evar_map ->
+      unsafe_judgment -> unsafe_judgment list -> 'b
+
+val error_cant_apply_bad_type_loc : 
+  loc -> env ->  Evd.evar_map -> int * constr * constr -> 
+      unsafe_judgment -> unsafe_judgment list -> 'b
+
+val error_case_not_inductive_loc :
+  loc -> env ->  Evd.evar_map -> unsafe_judgment -> 'b
+
+val error_ill_formed_branch_loc : 
+  loc -> env ->  Evd.evar_map ->
+      constr -> int -> constr -> constr -> 'b
+
+val error_number_branches_loc : 
+  loc -> env ->  Evd.evar_map ->
+      unsafe_judgment -> int -> 'b
+
+val error_ill_typed_rec_body_loc :
+  loc -> env ->  Evd.evar_map ->
+      int -> name array -> unsafe_judgment array -> types array -> '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
+
+val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> hole_kind -> 'b
+
+(*s Ml Case errors *)
+
+val error_cant_find_case_type_loc :
+  loc -> env ->  Evd.evar_map -> constr -> 'b
+
+(*s Pretyping errors *)
+
+val error_unexpected_type_loc :
+  loc -> env ->  Evd.evar_map -> constr -> constr -> 'b
+
+val error_not_product_loc :
+  loc -> env ->  Evd.evar_map -> constr -> 'b
+
+(*s Error in conversion from AST to rawterms *)
+
+val error_var_not_found_loc : loc -> identifier -> 'b
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
new file mode 100644
index 00000000..36df9c8a
--- /dev/null
+++ b/pretyping/pretyping.ml
@@ -0,0 +1,1024 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pretyping.ml,v 1.123.2.3 2004/07/16 19:30:45 herbelin Exp $ *)
+
+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 Coercion
+open Pattern
+open Dyn
+
+
+(************************************************************************)
+(* 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)
+
+(************************************************************************)
+
+(* To embed constr in rawconstr *)
+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
+    List.assoc id lvar
+  with Not_found ->
+  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
+    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) ->
+      if !compter then nbimpl:=!nbimpl+1;
+      (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
+	      (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 ())
+	    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 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)
+	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
+      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 ->
+      if !compter then nbimpl:=!nbimpl+1;
+      (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 sigma env c =
+  snd (ise_infer_gen true sigma env ([],[]) None c)
+
+let understand_type_judgment sigma env c =
+  snd (ise_infer_type_gen true sigma env ([],[]) c)
+
+let understand sigma env c =
+  let _, c = ise_infer_gen true sigma env ([],[]) None c in
+  c.uj_val
+
+let understand_type sigma env c =
+  let _,c = ise_infer_type_gen true sigma env ([],[]) c in
+  c.utj_val
+
+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_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_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 interp_sort = function
+  | RProp c -> Prop c
+  | RType _ -> new_Type_sort ()
+
+let interp_elimination_sort = function
+  | RProp Null -> InProp
+  | RProp Pos  -> InSet
+  | RType _ -> InType
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
new file mode 100644
index 00000000..4357e504
--- /dev/null
+++ b/pretyping/pretyping.mli
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pretyping.mli,v 1.28.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Sign
+open Term
+open Environ
+open Evd
+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
+
+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
+
+(* Idem but the rawconstr is intended to be a type *)
+val understand_type : 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 returns the judgment of the understood type *)
+val understand_type_judgment : evar_map -> env -> rawconstr 
+  -> unsafe_type_judgment
+
+(* 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_elimination_sort : rawsort -> sorts_family
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
new file mode 100644
index 00000000..520f09e9
--- /dev/null
+++ b/pretyping/rawterm.ml
@@ -0,0 +1,365 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rawterm.ml,v 1.43.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+(*i*)
+open Util
+open Names
+open Sign
+open Term
+open Libnames
+open Nametab
+(*i*)
+
+(* Untyped intermediate terms, after ASTs and before constr. *)
+
+(* locs here refers to the ident's location, not whole pat *)
+(* the last argument of PatCstr is a possible alias ident for the pattern *)
+type cases_pattern =
+  | PatVar of loc * name
+  | PatCstr of loc * constructor * cases_pattern list * name
+
+let pattern_loc = function
+    PatVar(loc,_) -> loc
+  | PatCstr(loc,_,_,_) -> loc
+
+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
+
+type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
+
+type 'a bindings = 
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+type hole_kind =
+  | ImplicitArg of global_reference * int
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+
+type rawconstr = 
+  | RRef of (loc * global_reference)
+  | RVar of (loc * identifier)
+  | REvar of loc * existential_key * rawconstr list option
+  | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
+  | RApp of loc * rawconstr * rawconstr list
+  | 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
+  | 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
+  | RDynamic of loc * Dyn.t
+
+and rawdecl = name * rawconstr option * rawconstr
+
+let cases_predicate_names tml =
+  List.flatten (List.map (function
+    | (tm,{contents=(na,None)}) -> [na]
+    | (tm,{contents=(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
+   arities incrementally lifted 
+
+  [On pourrait plutot mettre les arités aves le type qu'elles auront
+   dans le contexte servant à typer les body ???]
+
+   - boolean in POldCase means it is recursive
+i*)
+let map_rawdecl f (na,obd,ty) = (na,option_app f obd,f ty)
+
+let map_rawconstr f = function
+  | RVar (loc,id) -> RVar (loc,id)
+  | RApp (loc,g,args) -> RApp (loc,f g, List.map f args)
+  | 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)),
+        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)
+  | RIf (loc,c,(na,po),b1,b2) ->
+      RIf (loc,f c,(na,option_app 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)
+  | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
+  
+
+(*
+let name_app f e = function
+  | Name id -> let (id, e) = f id e in (Name id, e)
+  | Anonymous -> Anonymous, e
+
+let fold_ident g idl e =
+  let (idl,e) =
+    Array.fold_right
+      (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e)
+  in (Array.of_list idl,e)
+
+let map_rawconstr_with_binders_loc loc g f e = function
+  | RVar (_,id) -> RVar (loc,id)
+  | RApp (_,a,args) -> RApp (loc,f e a, List.map (f e) args)
+  | RLambda (_,na,ty,c) ->
+      let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c)
+  | RProd (_,na,ty,c) ->
+      let na,e = name_app g e na in RProd (loc,na,f e ty,f e c)
+  | RLetIn (_,na,b,c) ->
+      let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c)
+  | RCases (_,tyopt,tml,pl) ->
+      (* We don't modify pattern variable since we don't traverse patterns *)
+      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)
+  | 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)
+  | RCast (_,c,t) -> RCast (loc,f e c,f e t)
+  | RSort (_,x) -> RSort (loc,x)
+  | RHole (_,x)  -> RHole (loc,x)
+  | RRef (_,x) -> RRef (loc,x)
+  | REvar (_,x,l) -> REvar (loc,x,l)
+  | RPatVar (_,x) -> RPatVar (loc,x)
+  | RDynamic (_,x) -> RDynamic (loc,x)
+*)
+
+let occur_rawconstr id =
+  let rec occur = function
+    | RVar (loc,id') -> id = id'
+    | RApp (loc,f,args) -> (occur f) or (List.exists occur args)
+    | 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)
+        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))
+    | RIf (loc,c,rtntyp,b1,b2) -> 
+	occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2)
+    | RRec (loc,fk,idl,bl,tyl,bv) ->
+        not (array_for_all4 (fun fid bl ty bd ->
+          let rec occur_fix = function
+              [] -> not (occur ty) && (fid=id or not(occur bd))
+            | (na,bbd,bty)::bl ->
+                not (occur bty) &&
+                (match bbd with
+                    Some bd -> not (occur bd)
+                  | _ -> true) &&
+                (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)
+    | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false
+
+  and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
+
+  and occur_option = function None -> false | Some p -> occur p
+
+  and occur_return_type (na,tyopt) id = na <> Name id & occur_option tyopt
+
+  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 loc_of_rawconstr = function
+  | RRef (loc,_) -> loc
+  | RVar (loc,_) -> loc
+  | REvar (loc,_,_) -> loc
+  | RPatVar (loc,_) -> loc
+  | RApp (loc,_,_) -> loc
+  | RLambda (loc,_,_,_) -> loc
+  | 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
+  | RDynamic (loc,_) -> loc
+
+type 'a raw_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+let all_flags =
+  {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
+
+type 'a occurrences = int list * 'a
+
+type ('a,'b) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'a occurrences option
+  | Cbv of 'b raw_red_flag
+  | Lazy of 'b raw_red_flag
+  | Unfold of 'b occurrences list
+  | Fold of 'a list
+  | Pattern of 'a occurrences list
+  | ExtraRedExpr of string * 'a
+
+type ('a,'b) may_eval =
+  | ConstrTerm of '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
new file mode 100644
index 00000000..d78d1866
--- /dev/null
+++ b/pretyping/rawterm.mli
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: rawterm.mli,v 1.47.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Sign
+open Term
+open Libnames
+open Nametab
+(*i*)
+
+(* Untyped intermediate terms, after ASTs and before constr. *)
+
+(* locs here refers to the ident's location, not whole pat *)
+(* the last argument of PatCstr is a possible alias ident for the pattern *)
+type cases_pattern =
+  | PatVar of loc * name
+  | PatCstr of loc * constructor * cases_pattern list * name
+
+val pattern_loc : cases_pattern -> loc
+
+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
+
+type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
+
+type 'a bindings = 
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+type hole_kind =
+  | ImplicitArg of global_reference * int
+  | BinderType of name
+  | QuestionMark
+  | CasesType
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+
+type rawconstr = 
+  | RRef of (loc * global_reference)
+  | RVar of (loc * identifier)
+  | REvar of loc * existential_key * rawconstr list option
+  | RPatVar of loc * (bool * patvar) (* Used for patterns only *)
+  | RApp of loc * rawconstr * rawconstr list
+  | 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
+  | 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
+  | 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
+
+(*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
+   arities incrementally lifted 
+
+  [On pourrait plutot mettre les arités aves le type qu'elles auront
+   dans le contexte servant à typer les body ???]
+
+   - boolean in POldCase means it is recursive
+   - option in PHole tell if the "?" was apparent or has been implicitely added
+i*)
+
+val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr
+
+(*
+val map_rawconstr_with_binders_loc : loc -> 
+  (identifier -> 'a -> identifier * 'a) ->
+  ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr
+*)
+
+val occur_rawconstr : identifier -> rawconstr -> bool
+
+val loc_of_rawconstr : rawconstr -> loc
+
+val subst_raw : Names.substitution -> rawconstr -> rawconstr
+
+type 'a raw_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+val all_flags : 'a raw_red_flag
+
+type 'a occurrences = int list * 'a
+
+type ('a,'b) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'a occurrences option
+  | Cbv of 'b raw_red_flag
+  | Lazy of 'b raw_red_flag
+  | Unfold of 'b occurrences list
+  | Fold of 'a list
+  | Pattern of 'a occurrences list
+  | ExtraRedExpr of string * 'a
+
+type ('a,'b) may_eval =
+  | ConstrTerm of '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
new file mode 100755
index 00000000..f34d5624
--- /dev/null
+++ b/pretyping/recordops.ml
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: recordops.ml,v 1.26.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Libnames
+open Nametab
+open Term
+open Termops
+open Typeops
+open Libobject
+open Library
+open Classops
+
+let nbimpl = ref 0
+let nbpathc = ref 0
+let nbcoer = ref 0
+let nbstruc = ref 0
+let nbimplstruc = ref 0
+
+let compter = ref false
+
+(*s Une structure S est un type inductif non récursif à un seul
+   constructeur (de nom par défaut 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 *)
+
+type struc_typ = {
+  s_CONST : identifier; 
+  s_PARAM : int;
+  s_PROJ : constant option list }
+
+let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
+let projection_table = ref KNmap.empty
+
+let option_fold_right f p e = match p with Some a -> f a e | None -> e
+
+let cache_structure (_,(ind,struc)) =
+  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
+
+let subst_structure (_,subst,((kn,i),struc as obj)) = 
+  let kn' = subst_kn subst kn in
+  let proj' = list_smartmap 
+		(option_smartmap (subst_kn subst)) 
+		struc.s_PROJ 
+  in
+    if proj' == struc.s_PROJ && kn' == kn then obj else
+      (kn',i),{struc with s_PROJ = proj'}
+
+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)  }
+
+let add_new_struc (s,c,n,l) = 
+  Lib.add_anonymous_leaf (inStruc (s,{s_CONST=c;s_PARAM=n;s_PROJ=l}))
+
+let find_structure indsp = Indmap.find indsp !structure_table
+
+let find_projection_nparams = function
+  | ConstRef cst -> (KNmap.find cst !projection_table).s_PARAM
+  | _ -> raise Not_found
+
+(*s Un "object" est une fonction construisant une instance d'une 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)
+
+  Pour tout ci, et Li, la ième projection de la structure R (si
+  définie), on déclare une "coercion"
+
+    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' }
+
+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 freeze () =
+  !structure_table, !projection_table, !object_table
+
+let unfreeze (s,p,o) = 
+  structure_table := s; projection_table := p; object_table := o
+
+let init () =
+  structure_table := Indmap.empty; projection_table := KNmap.empty;
+  object_table:=[]
+
+let _ = init()
+
+let _ = 
+  Summary.declare_summary "objdefs"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
new file mode 100755
index 00000000..66c1f34d
--- /dev/null
+++ b/pretyping/recordops.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: recordops.mli,v 1.15.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Nametab
+open Term
+open Libnames
+open Classops
+open Libobject
+open Library
+(*i*)
+
+val nbimpl : int ref
+val nbpathc : int ref
+val nbcoer : int ref
+val nbstruc : int ref
+val nbimplstruc : int ref
+val compter : bool ref
+
+type struc_typ = {
+  s_CONST : identifier; 
+  s_PARAM : int;
+  s_PROJ : constant option list }
+
+val add_new_struc : 
+  inductive * identifier * int * 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
+
+(* raise [Not_found] if not a projection *)
+val find_projection_nparams : global_reference -> int
+
+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 *)
+               
+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
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
new file mode 100644
index 00000000..a030dcf2
--- /dev/null
+++ b/pretyping/reductionops.ml
@@ -0,0 +1,717 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: reductionops.ml,v 1.6.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Univ
+open Evd
+open Declarations
+open Environ
+open Instantiate
+open Closure
+open Esubst
+open Reduction
+
+exception Elimconst
+
+(* The type of (machine) states (= lambda-bar-calculus' cuts) *) 
+type state = constr * constr stack
+
+type  contextual_reduction_function = env ->  evar_map -> constr -> constr
+type  reduction_function =  contextual_reduction_function
+type local_reduction_function = constr -> constr
+
+type  contextual_stack_reduction_function = 
+    env ->  evar_map -> constr -> constr * constr list
+type  stack_reduction_function =  contextual_stack_reduction_function
+type local_stack_reduction_function = constr -> constr * constr list
+
+type  contextual_state_reduction_function = 
+    env ->  evar_map -> state -> state
+type  state_reduction_function =  contextual_state_reduction_function
+type local_state_reduction_function = state -> state
+
+(*************************************)
+(*** Reduction Functions Operators ***)
+(*************************************)
+
+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)
+    | _             -> s
+
+let appterm_of_stack (f,s) = (f,list_of_stack s)
+
+let whd_stack x = appterm_of_stack (whd_state (x, empty_stack))
+let whd_castapp_stack = whd_stack
+
+let stack_reduction_of_reduction red_fun env sigma s =
+  let t = red_fun env sigma (app_stack s) in
+  whd_stack t
+
+let strong whdfun env sigma t = 
+  let rec strongrec env t =
+    map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in
+  strongrec env t
+
+let local_strong whdfun = 
+  let rec strongrec t = map_constr strongrec (whdfun t) in
+  strongrec
+
+let rec strong_prodspine redfun c = 
+  let x = redfun c in
+  match kind_of_term x with
+    | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun b)
+    | _ -> x
+
+(*************************************)
+(*** Reduction using bindingss ***)
+(*************************************)
+
+(* This signature is very similar to Closure.RedFlagsSig except there
+   is eta but no per-constant unfolding *)
+
+module type RedFlagsSig = sig
+  type flags
+  type flag
+  val fbeta : flag
+  val fevar : flag
+  val fdelta : flag
+  val feta : flag
+  val fiota : flag
+  val fzeta : flag
+  val mkflags : flag list -> flags
+  val red_beta : flags -> bool
+  val red_delta : flags -> bool
+  val red_evar : flags -> bool
+  val red_eta : flags -> bool
+  val red_iota : flags -> bool
+  val red_zeta : flags -> bool
+end
+
+(* Naive Implementation 
+module RedFlags = (struct
+  type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA
+  type flags = flag list
+  let fbeta = BETA 
+  let fdelta = DELTA
+  let fevar = EVAR
+  let fiota = IOTA
+  let fzeta = ZETA
+  let feta = ETA
+  let mkflags l = l
+  let red_beta = List.mem BETA
+  let red_delta = List.mem DELTA
+  let red_evar = List.mem EVAR
+  let red_eta = List.mem ETA
+  let red_iota = List.mem IOTA
+  let red_zeta = List.mem ZETA
+end : RedFlagsSig)
+*)
+
+(* Compact Implementation *)
+module RedFlags = (struct
+  type flag = int
+  type flags = int
+  let fbeta = 1
+  let fdelta = 2
+  let fevar = 4
+  let feta = 8 
+  let fiota = 16
+  let fzeta = 32
+  let mkflags = List.fold_left (lor) 0
+  let red_beta f = f land fbeta <> 0
+  let red_delta f = f land fdelta <> 0
+  let red_evar f = f land fevar <> 0
+  let red_eta f = f land feta <> 0
+  let red_iota f = f land fiota <> 0
+  let red_zeta f = f land fzeta <> 0
+end : RedFlagsSig)
+
+open RedFlags
+
+(* Local *)
+let beta = mkflags [fbeta]
+let evar = mkflags [fevar]
+let betaevar = mkflags [fevar; fbeta]
+let betaiota = mkflags [fiota; fbeta]
+let betaiotazeta = mkflags [fiota; fbeta;fzeta]
+
+(* Contextual *)
+let delta = mkflags [fdelta;fevar]
+let betadelta = mkflags [fbeta;fdelta;fzeta;fevar]
+let betadeltaeta = mkflags [fbeta;fdelta;fzeta;fevar;feta]
+let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fevar;fiota]
+let betadeltaiota_nolet = mkflags [fbeta;fdelta;fevar;fiota]
+let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fevar;fiota;feta]
+let betaiotaevar = mkflags [fbeta;fiota;fevar]
+let betaetalet = mkflags [fbeta;feta;fzeta]
+let betalet = mkflags [fbeta;fzeta]
+
+(* Beta Reduction tools *)
+
+let rec stacklam recfun env t stack =
+  match (decomp_stack stack,kind_of_term t) with
+    | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl
+    | _ -> recfun (substl env t, stack)
+
+let beta_applist (c,l) =
+  stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack)
+
+(* Iota reduction tools *)
+
+type 'a miota_args = {
+  mP      : constr;     (* the result type *)
+  mconstr : constr;     (* the constructor *)
+  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
+
+let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
+  let nbodies = Array.length bodies in
+  let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in
+  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+
+let reduce_mind_case mia =
+  match kind_of_term mia.mconstr with
+    | Construct (ind_sp,i as cstr_sp) ->
+(*	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)
+    | CoFix cofix ->
+	let cofix_def = contract_cofix cofix in
+	mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf)
+    | _ -> assert false
+
+(* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce
+   Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *)
+
+let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) =
+  let nbodies = Array.length recindices in
+  let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in
+  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+
+let fix_recarg ((recindices,bodynum),_) stack =
+  assert (0 <= bodynum & bodynum < Array.length recindices);
+  let recargnum = Array.get recindices bodynum in
+  try 
+    Some (recargnum, stack_nth stack recargnum)
+  with Not_found ->
+    None
+
+type fix_reduction_result = NotReducible | Reduced of state
+
+let reduce_fix whdfun fix stack =
+  match fix_recarg fix stack with
+    | None -> NotReducible
+    | Some (recargnum,recarg) ->
+        let (recarg'hd,_ as recarg') = whdfun (recarg, empty_stack) in
+        let stack' = stack_assign stack recargnum (app_stack recarg') in
+	(match kind_of_term recarg'hd with
+           | Construct _ -> Reduced (contract_fix fix, stack')
+	   | _ -> NotReducible)
+
+(* Generic reduction function *)
+
+(* Y avait un commentaire pour whd_betadeltaiota :
+
+   NB : Cette fonction alloue peu c'est l'appel 
+     ``let (c,cargs) = whfun (recarg, empty_stack)''
+                              -------------------
+   qui coute cher *)
+
+let rec whd_state_gen flags env sigma = 
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | Rel n when red_delta flags ->
+	  (match lookup_rel n env with
+	     | (_,Some body,_) -> whrec (lift n body, stack)
+	     | _ -> s)
+      | Var id when red_delta flags ->
+	  (match lookup_named id env with
+	     | (_,Some body,_) -> whrec (body, stack)
+	     | _ -> s)
+      | Evar ev when red_evar flags ->
+	  (match existential_opt_value sigma ev with
+	     | Some body -> whrec (body, stack)
+	     | None -> s)
+      | Const const when red_delta flags ->
+	  (match constant_opt_value env const with
+	     | Some  body -> whrec (body, stack)
+	     | None -> s)
+      | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] 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
+             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
+             | None when red_eta flags ->
+		 let env' = push_rel (na,None,t) env in
+		 let whrec' = whd_state_gen flags env' sigma in
+                 (match kind_of_term (app_stack (whrec' (c, empty_stack))) with
+                    | App (f,cl) ->
+			let napp = Array.length cl in
+			if napp > 0 then
+			  let x', l' = whrec' (array_last cl, empty_stack) in
+                          match kind_of_term x', decomp_stack l' with
+                            | Rel 1, None ->
+				let lc = Array.sub cl 0 (napp-1) in
+				let u = if napp=1 then f else appvect (f,lc) in
+				if noccurn 1 u then (pop u,empty_stack) else s
+                            | _ -> s
+			else s
+		    | _ -> s)
+	     | _ -> s)
+
+      | Case (ci,p,d,lf) when red_iota flags ->
+          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)
+            
+      | Fix fix when red_iota flags ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+
+      | x -> s
+  in 
+  whrec
+
+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)
+      | App (f,cl)  -> whrec (f, append_stack cl stack)
+      | Lambda (_,_,c) ->
+          (match decomp_stack stack with
+             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
+             | None when red_eta flags ->
+                 (match kind_of_term (app_stack (whrec (c, empty_stack))) with 
+                    | App (f,cl) ->
+			let napp = Array.length cl in
+			if napp > 0 then
+			  let x', l' = whrec (array_last cl, empty_stack) in
+                          match kind_of_term x', decomp_stack l' with
+                            | Rel 1, None ->
+				let lc = Array.sub cl 0 (napp-1) in
+				let u = if napp=1 then f else appvect (f,lc) in
+				if noccurn 1 u then (pop u,empty_stack) else s
+                            | _ -> s
+			else s
+		    | _ -> s)
+	     | _ -> s)
+
+      | Case (ci,p,d,lf) when red_iota flags ->
+          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)
+            
+      | Fix fix when red_iota flags ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+
+      | x -> s
+  in 
+  whrec
+
+(* 1. Beta Reduction Functions *)
+
+let whd_beta_state = local_whd_state_gen beta
+let whd_beta_stack x = appterm_of_stack (whd_beta_state (x, empty_stack))
+let whd_beta x = app_stack (whd_beta_state (x,empty_stack))
+
+(* Nouveau ! *)
+let whd_betaetalet_state = local_whd_state_gen betaetalet
+let whd_betaetalet_stack x =
+  appterm_of_stack (whd_betaetalet_state (x, empty_stack))
+let whd_betaetalet x = app_stack (whd_betaetalet_state (x,empty_stack))
+
+let whd_betalet_state = local_whd_state_gen betalet
+let whd_betalet_stack x = appterm_of_stack (whd_betalet_state (x, empty_stack))
+let whd_betalet x = app_stack (whd_betalet_state (x,empty_stack))
+
+(* 2. Delta Reduction Functions *)
+
+let whd_delta_state e = whd_state_gen delta e
+let whd_delta_stack env sigma x =
+  appterm_of_stack (whd_delta_state env sigma (x, empty_stack))
+let whd_delta env sigma c =
+  app_stack (whd_delta_state env sigma (c, empty_stack))
+
+let whd_betadelta_state e = whd_state_gen betadelta e
+let whd_betadelta_stack env sigma x =
+  appterm_of_stack (whd_betadelta_state env sigma (x, empty_stack))
+let whd_betadelta env sigma c =
+  app_stack (whd_betadelta_state env sigma (c, empty_stack))
+
+let whd_betaevar_state e = whd_state_gen betaevar e
+let whd_betaevar_stack env sigma c =
+  appterm_of_stack (whd_betaevar_state env sigma (c, empty_stack))
+let whd_betaevar env sigma c =
+  app_stack (whd_betaevar_state env sigma (c, empty_stack))
+
+
+let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e
+let whd_betadeltaeta_stack env sigma x =
+  appterm_of_stack (whd_betadeltaeta_state env sigma (x, empty_stack))
+let whd_betadeltaeta env sigma x = 
+  app_stack (whd_betadeltaeta_state env sigma (x, empty_stack))
+
+(* 3. Iota reduction Functions *)
+
+let whd_betaiota_state = local_whd_state_gen betaiota
+let whd_betaiota_stack x =
+  appterm_of_stack (whd_betaiota_state (x, empty_stack))
+let whd_betaiota x =
+  app_stack (whd_betaiota_state (x, empty_stack))
+
+let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
+let whd_betaiotazeta_stack x =
+  appterm_of_stack (whd_betaiotazeta_state (x, empty_stack))
+let whd_betaiotazeta x =
+  app_stack (whd_betaiotazeta_state (x, empty_stack))
+
+let whd_betaiotaevar_state e = whd_state_gen betaiotaevar e
+let whd_betaiotaevar_stack env sigma x =
+  appterm_of_stack (whd_betaiotaevar_state env sigma (x, empty_stack))
+let whd_betaiotaevar env sigma x = 
+  app_stack (whd_betaiotaevar_state env sigma (x, empty_stack))
+
+let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e
+let whd_betadeltaiota_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiota_state env sigma (x, empty_stack))
+let whd_betadeltaiota env sigma x = 
+  app_stack (whd_betadeltaiota_state env sigma (x, empty_stack))
+
+let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e
+let whd_betadeltaiotaeta_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack))
+let whd_betadeltaiotaeta env sigma x = 
+  app_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack))
+
+let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e
+let whd_betadeltaiota_nolet_stack env sigma x =
+  appterm_of_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack))
+let whd_betadeltaiota_nolet env sigma x = 
+  app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack))
+
+(****************************************************************************)
+(*                   Reduction Functions                                    *)
+(****************************************************************************)
+
+(* 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))
+    | _ -> collapse_appl c
+
+let nf_evar sigma =
+  local_strong (whd_evar sigma)
+
+(* lazy reduction functions. The infos must be created for each term *)
+let clos_norm_flags flgs env sigma t =
+  norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
+
+let nf_beta = clos_norm_flags Closure.beta empty_env Evd.empty
+let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty
+let nf_betadeltaiota env sigma =
+  clos_norm_flags Closure.betadeltaiota env sigma
+
+(* lazy weak head reduction functions *)
+let whd_flags flgs env sigma t =
+  whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
+
+(********************************************************************)
+(*                         Conversion                               *)
+(********************************************************************)
+(*
+let fkey = Profile.declare_profile "fhnf";;
+let fhnf info v = Profile.profile2 fkey fhnf info v;;
+
+let fakey = Profile.declare_profile "fhnf_apply";;
+let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
+*)
+
+(* Conversion utility functions *)
+
+type conversion_test = constraints -> constraints
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+let pb_is_equal pb = pb = CONV
+
+let pb_equal = function
+  | CUMUL -> CONV
+  | CONV -> CONV
+
+let sort_cmp pb s0 s1 cuniv =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible
+    | (Prop c1, Type u)  ->
+        (match pb with
+            CUMUL -> cuniv
+          | _ -> raise NotConvertible)
+    | (Type u1, Type u2) ->
+	(match pb with
+           | CONV -> enforce_eq u1 u2 cuniv
+	   | CUMUL -> enforce_geq u2 u1 cuniv)
+    | (_, _) -> raise NotConvertible
+
+let base_sort_cmp pb s0 s1 =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) -> c1 = c2
+    | (Prop c1, Type u)  -> pb = CUMUL
+    | (Type u1, Type u2) -> true
+    | (_, _) -> false
+
+
+let test_conversion f env sigma x y =
+  try let _ = f env (nf_evar sigma x) (nf_evar sigma y) in true
+  with NotConvertible -> false
+
+let is_conv env sigma = test_conversion Reduction.conv env sigma
+let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
+let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
+
+(********************************************************************)
+(*             Special-Purpose Reduction                            *)
+(********************************************************************)
+
+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 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 ->
+	(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)
+
+
+(* pseudo-reduction rule:
+ * [hnf_prod_app env s (Prod(_,B)) N --> B[N]
+ * with an HNF on the first argument to produce a product.
+ * if this does not work, then we use the string S as part of our
+ * error message. *)
+
+let hnf_prod_app env sigma t n =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_prod_app: Need a product"
+
+let hnf_prod_appvect env sigma t nl = 
+  Array.fold_left (hnf_prod_app env sigma) t nl
+
+let hnf_prod_applist env sigma t nl = 
+  List.fold_left (hnf_prod_app env sigma) t nl
+				    
+let hnf_lam_app env sigma t n =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Lambda (_,_,b) -> subst1 n b
+    | _ -> anomaly "hnf_lam_app: Need an abstraction"
+
+let hnf_lam_appvect env sigma t nl = 
+  Array.fold_left (hnf_lam_app env sigma) t nl
+
+let hnf_lam_applist env sigma t nl = 
+  List.fold_left (hnf_lam_app env sigma) t nl
+
+let splay_prod env sigma = 
+  let rec decrec env m c =
+    let t = whd_betadeltaiota env sigma c in
+    match kind_of_term t with
+      | Prod (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
+    | 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
+    | _               -> l,t
+  in
+  prodec_rec env Sign.empty_rel_context
+
+let splay_arity env sigma c =
+  let l, c = splay_prod env sigma c in
+  match kind_of_term c with
+    | Sort s -> l,s
+    | _ -> 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
+      | Prod (n,a,c0) ->
+	  decrec (push_rel (n,None,a) env)
+	    (m-1) (Sign.add_rel_decl (n,None,a) ln) c0
+      | _                      -> error "decomp_n_prod: Not enough products"
+  in 
+  decrec env n Sign.empty_rel_context
+
+(* One step of approximation *)
+
+let rec apprec env sigma s =
+  let (t, stack as s) = whd_betaiota_state s in
+  match kind_of_term t with
+    | Case (ci,p,d,lf) ->
+        let (cr,crargs) = whd_betadeltaiota_stack env sigma d in
+        let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
+        if reducible_mind_case cr then 
+	  apprec env sigma (rslt, stack)
+        else 
+	  s
+    | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with
+             | Reduced s -> 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.
+ * Added by JCF, 29/1/98. *)
+
+let whd_programs_stack env sigma = 
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | App (f,cl) ->
+	  let n = Array.length cl - 1 in
+	  let c = cl.(n) in
+	  if occur_existential c then 
+	    s 
+	  else 
+	    whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack)
+      | LetIn (_,b,_,c) ->
+	  if occur_existential b then
+	    s
+	  else
+	    stacklam whrec [b] c stack
+      | Lambda (_,_,c) ->
+          (match decomp_stack stack with
+             | None -> s
+             | Some (a,m) -> stacklam whrec [a] c m)
+      | Case (ci,p,d,lf) ->
+	  if occur_existential d then
+	    s
+	  else
+            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)
+      | Fix fix ->
+	  (match reduce_fix whrec fix stack with
+             | Reduced s' -> whrec s'
+	     | NotReducible -> s)
+      | _ -> s
+  in 
+  whrec
+
+let whd_programs env sigma x =
+  app_stack (whd_programs_stack env sigma (x, empty_stack))
+
+exception IsType
+
+let find_conclusion env sigma =
+  let rec decrec env c =
+    let t = whd_betadeltaiota env sigma c in
+    match kind_of_term t with
+      | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0
+      | t -> t
+  in 
+  decrec env
+
+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)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
new file mode 100644
index 00000000..65cdd5cd
--- /dev/null
+++ b/pretyping/reductionops.mli
@@ -0,0 +1,190 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: reductionops.mli,v 1.8.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Univ
+open Evd
+open Environ
+open Closure
+(*i*)
+
+(* Reduction Functions. *)
+
+exception Elimconst
+
+type state = constr * constr stack
+
+type contextual_reduction_function = env -> evar_map -> constr -> constr
+type reduction_function = contextual_reduction_function
+type local_reduction_function = constr -> constr
+
+type contextual_stack_reduction_function = 
+    env -> evar_map -> constr -> constr * constr list
+type stack_reduction_function = contextual_stack_reduction_function
+type local_stack_reduction_function = constr -> constr * constr list
+
+type contextual_state_reduction_function = 
+    env -> evar_map -> state -> state
+type state_reduction_function = contextual_state_reduction_function
+type local_state_reduction_function = state -> state
+
+(* Removes cast and put into applicative form *)
+val whd_stack : local_stack_reduction_function
+
+(* For compatibility: alias for whd\_stack *)
+val whd_castapp_stack : local_stack_reduction_function
+
+(*s Reduction Function Operators *)
+
+val strong : reduction_function -> reduction_function
+val local_strong : local_reduction_function -> local_reduction_function
+val strong_prodspine : local_reduction_function -> local_reduction_function
+(*i
+val stack_reduction_of_reduction : 
+  'a reduction_function -> 'a state_reduction_function
+i*)
+val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a 
+
+(*s Generic Optimized Reduction Function using Closures *)
+
+val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
+(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) 
+val nf_beta : local_reduction_function
+val nf_betaiota : local_reduction_function
+val nf_betadeltaiota : reduction_function
+val nf_evar : evar_map -> constr -> constr
+
+(* Lazy strategy, weak head reduction *)
+val whd_evar :  evar_map -> constr -> constr
+val whd_beta : local_reduction_function
+val whd_betaiota : local_reduction_function
+val whd_betaiotazeta : local_reduction_function
+val whd_betadeltaiota :  contextual_reduction_function
+val whd_betadeltaiota_nolet :  contextual_reduction_function
+val whd_betaetalet : local_reduction_function
+val whd_betalet : local_reduction_function
+
+val whd_beta_stack : local_stack_reduction_function
+val whd_betaiota_stack : local_stack_reduction_function
+val whd_betaiotazeta_stack : local_stack_reduction_function
+val whd_betadeltaiota_stack :  contextual_stack_reduction_function
+val whd_betadeltaiota_nolet_stack :  contextual_stack_reduction_function
+val whd_betaetalet_stack : local_stack_reduction_function
+val whd_betalet_stack : local_stack_reduction_function
+
+val whd_state : local_state_reduction_function
+val whd_beta_state : local_state_reduction_function
+val whd_betaiota_state : local_state_reduction_function
+val whd_betaiotazeta_state : local_state_reduction_function
+val whd_betadeltaiota_state :  contextual_state_reduction_function
+val whd_betadeltaiota_nolet_state :  contextual_state_reduction_function
+val whd_betaetalet_state : local_state_reduction_function
+val whd_betalet_state : local_state_reduction_function
+
+(*s Head normal forms *)
+
+val whd_delta_stack :  stack_reduction_function
+val whd_delta_state :  state_reduction_function
+val whd_delta :  reduction_function
+val whd_betadelta_stack :  stack_reduction_function
+val whd_betadelta_state :  state_reduction_function
+val whd_betadelta :  reduction_function
+val whd_betaevar_stack :  stack_reduction_function
+val whd_betaevar_state :  state_reduction_function
+val whd_betaevar :  reduction_function
+val whd_betaiotaevar_stack :  stack_reduction_function
+val whd_betaiotaevar_state :  state_reduction_function
+val whd_betaiotaevar :  reduction_function
+val whd_betadeltaeta_stack :  stack_reduction_function
+val whd_betadeltaeta_state :  state_reduction_function
+val whd_betadeltaeta :  reduction_function
+val whd_betadeltaiotaeta_stack :  stack_reduction_function
+val whd_betadeltaiotaeta_state :  state_reduction_function
+val whd_betadeltaiotaeta :  reduction_function
+
+val beta_applist : constr * constr list -> constr
+
+val hnf_prod_app     : env ->  evar_map -> constr -> constr -> constr
+val hnf_prod_appvect : env ->  evar_map -> constr -> constr array -> constr
+val hnf_prod_applist : env ->  evar_map -> constr -> constr list -> constr
+val hnf_lam_app      : env ->  evar_map -> constr -> constr -> constr
+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_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
+
+type 'a miota_args = {
+  mP      : constr;     (* the result type *)
+  mconstr : constr;     (* the constructor *)
+  mci     : case_info;  (* special info to re-build pattern *)
+  mcargs  : 'a list;    (* the constructor's arguments *)
+  mlf     : 'a array }  (* the branch code vector *)
+
+val reducible_mind_case : constr -> bool
+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
+
+(* [reduce_fix] contracts a fix redex if it is actually reducible *)
+
+type fix_reduction_result = NotReducible | Reduced of state
+
+val fix_recarg : fixpoint -> constr stack -> (int * constr) option
+val reduce_fix : local_state_reduction_function -> fixpoint
+   -> constr stack -> fix_reduction_result
+
+(*s Conversion Functions (uses closures, lazy strategy) *)
+
+type conversion_test = constraints -> constraints
+
+type conv_pb = 
+  | CONV 
+  | CUMUL
+
+val pb_is_equal : conv_pb -> bool
+val pb_equal : conv_pb -> conv_pb
+
+val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test
+val base_sort_cmp : conv_pb -> sorts -> sorts -> bool
+
+val is_conv : env ->  evar_map -> constr -> constr -> bool
+val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
+val is_fconv : conv_pb -> env ->  evar_map -> constr -> constr -> bool
+
+(*s Special-Purpose Reduction Functions *)
+
+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 *)
+
+(*i
+val hnf : env -> 'a evar_map -> constr -> constr * constr list
+i*)
+val apprec :  state_reduction_function
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
new file mode 100644
index 00000000..061382f7
--- /dev/null
+++ b/pretyping/retyping.ml
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: retyping.ml,v 1.43.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Term
+open Inductive
+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"
+
+let rec subst_type env sigma typ = function
+  | [] -> typ
+  | h::rest ->
+      match kind_of_term (whd_betadeltaiota env sigma typ) with
+        | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
+        | _ -> anomaly "Non-functional construction"
+
+(* Si ft est le type d'un terme f, lequel est appliqué à args, *)
+(* [sort_of_atomic_ty] calcule ft[args] qui doit être une sorte *)
+(* On suit une méthode paresseuse, en espèrant que ft est une arité *)
+(* et sinon on substitue *)
+
+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))
+  in concl_of_arity env ft
+
+let typeur sigma metamap =
+  let rec type_of env cstr=
+    match kind_of_term cstr with
+    | Meta n ->
+          (try strip_outer_cast (List.assoc n metamap)
+           with Not_found -> anomaly "type_of: this is not a well-typed term")
+    | 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)
+    | Case (_,p,c,lf) ->
+        let Inductiveops.IndType(_,realargs) =
+          try Inductiveops.find_rectype env sigma (type_of env c)
+          with Not_found -> anomaly "type_of: Bad recursive type" in
+        let t = whd_beta (applist (p, realargs)) in
+        (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
+          | Prod _ -> whd_beta (applist (t, [c]))
+          | _ -> t)
+    | Lambda (name,c1,c2) ->
+          mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2)
+    | LetIn (name,b,c1,c2) ->
+         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)->
+        strip_outer_cast
+          (subst_type env sigma (type_of env f) (Array.to_list args))
+    | 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
+    | Sort (Prop c) -> type_0
+    | Sort (Type u) -> Type (Univ.super u)
+    | Prod (name,t,c2) ->
+        (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
+	  | _, (Prop Null as s) -> s
+          | 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*))
+    | 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)
+
+  and sort_family_of env t =
+    match kind_of_term t with
+    | 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
+    | App(f,args) -> 
+       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))
+
+  in type_of, sort_of, sort_family_of
+
+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_with_meta env sigma metamap = 
+  let f,_,_ = typeur sigma metamap in f env
+
+(* Makes an assumption from a constr *)
+let get_assumption_of env evc c = c
+
+(* Makes an unsafe judgment from a constr *)
+let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
+
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
new file mode 100644
index 00000000..f29ac8d8
--- /dev/null
+++ b/pretyping/retyping.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: retyping.mli,v 1.16.2.1 2004/07/16 19:30:46 herbelin Exp $ 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
+   well-typable. It does not type-check, just recompute the type
+   without any costly verifications. On non well-typable terms, it
+   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_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
+
+(* 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
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
new file mode 100644
index 00000000..7e79a4fe
--- /dev/null
+++ b/pretyping/tacred.ml
@@ -0,0 +1,953 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tacred.ml,v 1.75.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Libnames
+open Termops
+open Declarations
+open Inductive
+open Environ
+open Reductionops
+open Closure
+open Instantiate
+open Cbv
+open Rawterm
+
+exception Elimconst
+exception Redelimination
+
+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
+
+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 }
+
+let is_evaluable env ref =
+  match ref with
+      EvalConstRef kn ->
+        let (ids,kns) = Conv_oracle.freeze() in
+        KNpred.mem kn kns &
+        let cb = Environ.lookup_constant kn env in
+        cb.const_body <> None & not cb.const_opaque
+    | EvalVarRef id ->
+        let (ids,sps) = Conv_oracle.freeze() in
+        Idpred.mem id ids &
+        let (_,value,_) = Environ.lookup_named id env in
+        value <> None
+
+type evaluable_reference =
+  | EvalConst of constant
+  | EvalVar of identifier
+  | EvalRel of int
+  | EvalEvar of existential
+
+let mkEvalRef = function
+  | EvalConst cst -> mkConst cst
+  | EvalVar id -> mkVar id
+  | EvalRel n -> mkRel n
+  | EvalEvar ev -> mkEvar ev
+
+let isEvalRef env c = match kind_of_term c with
+  | Const sp -> is_evaluable env (EvalConstRef sp)
+  | Var id -> is_evaluable env (EvalVarRef id)
+  | Rel _ | Evar _ -> true
+  | _ -> false
+
+let destEvalRef c = match kind_of_term c with
+  | Const cst ->  EvalConst cst
+  | Var id  -> EvalVar id
+  | Rel n -> EvalRel n
+  | Evar ev -> EvalEvar ev
+  | _ -> anomaly "Not an evaluable reference"
+
+let reference_opt_value sigma env = function
+  | EvalConst cst -> constant_opt_value env cst
+  | EvalVar id ->
+      let (_,v,_) = lookup_named id env in
+      v
+  | EvalRel n ->
+      let (_,v,_) = lookup_rel n env in
+      option_app (lift n) v
+  | EvalEvar ev -> existential_opt_value sigma ev
+
+exception NotEvaluable
+let reference_value sigma env c =
+  match reference_opt_value sigma env c with
+    | None -> raise NotEvaluable
+    | Some d -> d
+
+(************************************************************************)
+(* Reduction of constant hiding fixpoints (e.g. for Simpl). The trick   *)
+(* is to reuse the name of the function after reduction of the fixpoint *)
+
+type constant_evaluation = 
+  | EliminationFix of int * (int * (int * constr) list * int)
+  | EliminationMutualFix of
+      int * evaluable_reference *
+      (evaluable_reference option array * (int * (int * constr) list * int))
+  | EliminationCases of int
+  | NotAnElimination
+
+(* We use a cache registered as a global table *)
+
+
+module CstOrdered =
+  struct
+    type t = constant
+    let compare = Pervasives.compare
+  end
+module Cstmap = Map.Make(CstOrdered)
+
+let eval_table = ref Cstmap.empty
+
+type frozen = (int * constant_evaluation) Cstmap.t
+
+let init () =
+  eval_table := Cstmap.empty
+
+let freeze () =
+  !eval_table
+
+let unfreeze ct =
+  eval_table := ct
+
+let _ = 
+  Summary.declare_summary "evaluation"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      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] *)
+
+let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
+  let n = List.length labs in
+  let nargs = List.length args in
+  if nargs > n then raise Elimconst;
+  let nbfix = Array.length bds in
+  let li =
+    List.map
+      (function d -> match kind_of_term d with
+         | Rel k ->
+             if
+	       array_for_all (noccurn k) tys
+	       && array_for_all (noccurn (k+nbfix)) bds
+	     then 
+	       (k, List.nth labs (k-1)) 
+	     else 
+	       raise Elimconst
+         | _ -> 
+	     raise Elimconst) args
+  in
+  if list_distinct (List.map fst li) then 
+    let k = lv.(i) in
+    if k < nargs then
+(*  Such an optimisation would need eta-expansion 
+      let p = destRel (List.nth args k) in 
+      EliminationFix (n-p+1,(nbfix,li,n))
+*)
+      EliminationFix (n,(nbfix,li,n))
+    else
+      EliminationFix (n-nargs+lv.(i)+1,(nbfix,li,n))
+  else 
+    raise Elimconst
+
+(* Heuristic to look if global names are associated to other
+   components of a mutual fixpoint *)
+
+let invert_name labs l na0 env sigma ref = function
+  | Name id -> 
+      if na0 <> Name id then
+	let refi = match ref with
+	  | 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
+	match refi with
+	  | None -> None
+	  | Some ref ->
+	      match reference_opt_value sigma env ref with
+		| None -> None
+		| Some c -> 
+		    let labs',ccl = decompose_lam c in
+		    let _, l' = whd_betalet_stack ccl in
+		    let labs' = List.map snd labs' in
+		    if labs' = labs & l = l' then Some ref else None
+      else Some ref
+  | Anonymous -> None (* Actually, should not occur *)
+
+(* [compute_consteval_direct] expand all constant in a whole, but
+   [compute_consteval_mutual_fix] only one by one, until finding the
+   last one before the Fix if the latter is mutually defined *)
+
+let compute_consteval_direct sigma env ref =
+  let rec srec env n labs c =
+    let c',l = whd_betadelta_stack env sigma c in
+    match kind_of_term c' with
+      | Lambda (id,t,g) when l=[] ->
+	  srec (push_rel (id,None,t) env) (n+1) (t::labs) g
+      | Fix fix ->
+	  (try check_fix_reversibility labs l fix 
+	  with Elimconst -> NotAnElimination)
+      | Case (_,_,d,_) when isRel d -> EliminationCases n
+      | _ -> NotAnElimination
+  in 
+  match reference_opt_value sigma env ref with
+    | None -> NotAnElimination
+    | Some c -> srec env 0 [] c
+
+let compute_consteval_mutual_fix sigma env ref =
+  let rec srec env minarg labs ref c =
+    let c',l = whd_betalet_stack c in
+    let nargs = List.length l in
+    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) ->
+	  (* 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!*)
+		 NotAnElimination
+	     | EliminationFix (minarg',infos) ->
+		 let refs =
+		   Array.map
+		     (invert_name labs l names.(i) env sigma ref) names in
+		 let new_minarg = max (minarg'+minarg-nargs) minarg' in
+		 EliminationMutualFix (new_minarg,ref,(refs,infos))
+	     | _ -> assert false)
+      | _ when isEvalRef env c' ->
+	  (* Forget all \'s and args and do as if we had started with c' *)
+	  let ref = destEvalRef c' in
+	  (match reference_opt_value sigma env ref with
+	    | None -> anomaly "Should have been trapped by compute_direct"
+	    | Some c -> srec env (minarg-nargs) [] ref c)
+      | _ -> (* Should not occur *) NotAnElimination
+  in 
+  match reference_opt_value sigma env ref with
+    | None -> (* Should not occur *) NotAnElimination
+    | Some c -> srec env 0 [] ref c
+
+let compute_consteval sigma env ref =
+  match compute_consteval_direct sigma env ref with
+    | EliminationFix (_,(nbfix,_,_)) when nbfix <> 1 ->
+	compute_consteval_mutual_fix sigma env ref
+    | elim -> elim
+	
+let reference_eval sigma env = function
+  | EvalConst cst as ref -> 
+      (try
+	 Cstmap.find cst !eval_table
+       with Not_found -> begin
+	 let v = compute_consteval sigma env ref in
+	 eval_table := Cstmap.add cst v !eval_table;
+	 v
+       end)
+  | ref -> compute_consteval sigma env ref
+
+let rev_firstn_liftn fn ln = 
+  let rec rfprec p res l = 
+    if p = 0 then 
+      res 
+    else
+      match l with
+        | [] -> invalid_arg "Reduction.rev_firstn_liftn"
+        | a::rest -> rfprec (p-1) ((lift ln a)::res) rest
+  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 ... *)
+
+let make_elim_fun (names,(nbfix,lv,n)) largs =
+  let labs = 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) 
+  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))
+	0 (applistc (mkEvalRef ref) la') lv)
+
+(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make 
+   the reduction using this extra information *)
+
+let contract_fix_use_function f
+  ((recindices,bodynum),(types,names,bodies as typedbodies)) =
+  let nbodies = Array.length recindices in
+  let make_Fi j = match f j with
+    | None -> mkFix((recindices,j),typedbodies)
+    | Some c -> c in
+(*    match List.nth names j with Name id -> f id | _ -> assert false in*)
+  let lbodies = list_tabulate make_Fi nbodies in
+  substl (List.rev lbodies) bodies.(bodynum)
+
+let reduce_fix_use_function f whfun fix stack =
+  match fix_recarg fix stack with
+    | None -> NotReducible
+    | Some (recargnum,recarg) ->
+        let (recarg'hd,_ as recarg') =
+	  if isRel recarg then
+	    (* The recarg cannot be a local def, no worry about the right env *)
+	    (recarg, empty_stack) 
+	  else
+	    whfun (recarg, empty_stack) in
+        let stack' = stack_assign stack recargnum (app_stack recarg') in
+	(match kind_of_term recarg'hd with
+           | Construct _ ->
+	       Reduced (contract_fix_use_function f fix,stack')
+	   | _ -> NotReducible)
+
+let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) =
+  let nbodies = Array.length bodies in
+  let make_Fi j = match f j with
+    | None -> mkCoFix(j,typedbodies)
+    | Some c -> c in
+(*    match List.nth names j with Name id -> f id | _ -> assert false in*)
+  let subbodies = list_tabulate make_Fi nbodies in
+  substl subbodies bodies.(bodynum)
+
+let reduce_mind_case_use_function func env mia =
+  match kind_of_term mia.mconstr with 
+    | Construct(ind_sp,i as cstr_sp) ->
+	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
+	applist (mia.mlf.(i-1), real_cargs)
+    | CoFix (_,(names,_,_) as cofix) ->
+	let build_fix_name i =
+	  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
+		  (match constant_opt_value env kn with
+		    | None -> None
+		    | Some _ -> Some (mkConst kn))
+                else None
+	    | Anonymous -> None in 
+	let cofix_def = contract_cofix_use_function build_fix_name cofix in
+	mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf)
+    | _ -> assert false
+
+let special_red_case sigma env whfun (ci, p, c, lf)  =
+  let rec redrec s = 
+    let (constr, cargs) = whfun s in 
+    if isEvalRef env constr then
+      let ref = destEvalRef constr in
+      match reference_opt_value sigma env ref with
+        | None -> raise Redelimination
+        | Some gvalue ->
+	    if reducible_mind_case gvalue then
+	      reduce_mind_case_use_function constr env
+	        {mP=p; mconstr=gvalue; mcargs=list_of_stack cargs;
+                mci=ci; mlf=lf}
+	    else
+	      redrec (gvalue, cargs)
+    else
+      if reducible_mind_case constr then
+        reduce_mind_case
+	  {mP=p; mconstr=constr; mcargs=list_of_stack cargs;
+	  mci=ci; mlf=lf}
+      else 
+	raise Redelimination
+  in 
+  redrec (c, empty_stack)
+
+
+let rec red_elim_const env sigma ref largs =
+  match reference_eval sigma env ref with
+    | EliminationCases n when stack_args_size largs >= n ->
+	let c = reference_value sigma env ref in
+	let c', lrest = whd_betadelta_state env sigma (c,largs) in
+        (special_red_case sigma env (construct_const env sigma) (destCase c'),
+	 lrest)
+    | EliminationFix (min,infos) when stack_args_size largs >=min ->
+	let c = reference_value sigma env ref in
+	let d, lrest = whd_betadelta_state env sigma (c,largs) in
+	let f = make_elim_fun ([|Some ref|],infos) largs in
+	let co = construct_const env sigma in
+	(match reduce_fix_use_function f co (destFix d) lrest with
+	   | NotReducible -> raise Redelimination
+	   | Reduced (c,rest) -> (nf_beta c, rest))
+    | EliminationMutualFix (min,refgoal,refinfos)
+	when stack_args_size largs >= min ->
+	let rec descend ref args =
+	  let c = reference_value sigma env ref in
+	  if ref = refgoal then
+	    (c,args)
+	  else
+	    let c', lrest = whd_betalet_state (c,args) in
+	    descend (destEvalRef c') lrest in
+	let (_, midargs as s) = descend ref largs in
+	let d, lrest = whd_betadelta_state env sigma s in
+	let f = make_elim_fun refinfos midargs in
+	let co = construct_const env sigma in
+	(match reduce_fix_use_function f co (destFix d) lrest with
+	   | NotReducible -> raise Redelimination
+	   | Reduced (c,rest) -> (nf_beta c, rest))
+    | _ -> raise Redelimination
+
+and construct_const env sigma = 
+  let rec hnfstack (x, stack as s) =
+    match kind_of_term x with
+      | Cast (c,_) -> hnfstack (c, stack)
+      | App (f,cl) -> hnfstack (f, append_stack cl stack)
+      | Lambda (id,t,c) ->
+          (match decomp_stack stack with 
+             | None -> assert false
+             | Some (c',rest) -> 
+		   stacklam hnfstack [c'] c rest)
+      | LetIn (n,b,t,c) -> stacklam hnfstack [b] c stack
+      | Case (ci,p,c,lf) ->
+          hnfstack 
+	    (special_red_case sigma env
+              (construct_const env sigma) (ci,p,c,lf), stack)
+      | Construct _ -> s
+      | CoFix _ -> s
+      | Fix fix -> 
+	  (match reduce_fix hnfstack fix stack with
+             | Reduced s' -> hnfstack s'
+	     | NotReducible -> raise Redelimination)
+      | _ when isEvalRef env x ->
+	  let ref = destEvalRef x in
+          (try
+	    hnfstack (red_elim_const env sigma ref stack)
+           with Redelimination ->
+	     (match reference_opt_value sigma env ref with
+		| Some cval ->
+		    (match kind_of_term cval with
+                       | CoFix _ -> s
+                       | _ -> hnfstack (cval, stack))
+		| None ->
+		    raise Redelimination))
+      | _ -> raise Redelimination
+  in 
+  hnfstack 
+
+(************************************************************************)
+(*            Special Purpose Reduction Strategies                     *)
+
+(* Red reduction tactic: reduction to a product *)
+
+let internal_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
+      | App (f,l) -> 
+          (match kind_of_term f with
+             | Fix fix ->
+                 let stack = append_stack l empty_stack in
+                 (match fix_recarg fix stack with
+                    | None -> raise Redelimination
+                    | Some (recargnum,recarg) ->
+                        let recarg' = redrec env recarg in
+                        let stack' = stack_assign stack recargnum recarg' in
+                        simpfun (app_stack (f,stack')))
+             | _ -> simpfun (appvect (redrec env f, l)))
+      | 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))
+      | _ when isEvalRef env x -> 
+          (* TO DO: re-fold fixpoints after expansion *)
+          (* to get true one-step reductions *)
+          let ref = destEvalRef x in
+	  (match reference_opt_value sigma env ref with
+	     | None -> raise Redelimination
+	     | Some c -> c)
+      | _ -> raise Redelimination
+  in redrec env c
+
+let red_product env sigma c = 
+  try internal_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
+      | Lambda (n,t,c) ->
+          (match decomp_stack largs with
+             | None      -> app_stack s
+             | Some (a,rest) -> 
+		 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)
+      | Case (ci,p,c,lf) ->
+          (try
+             redrec 
+	       (special_red_case sigma env (whd_betadeltaiota_state env sigma) 
+		  (ci, p, c, lf), largs)
+           with Redelimination -> 
+	     app_stack s)
+      | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
+             | Reduced s' -> redrec s'
+	     | NotReducible -> app_stack s)
+      | _ when isEvalRef env x ->
+	  let ref = destEvalRef x in
+          (try
+            let (c',lrest) = red_elim_const env sigma ref largs in 
+	    redrec (c', lrest)
+           with Redelimination ->
+             match reference_opt_value sigma env ref with
+	       | Some c ->
+		   (match kind_of_term (snd (decompose_lam c)) with 
+                      | CoFix _ | Fix _ -> app_stack (x,largs)
+		      | _ -> redrec (c, largs))
+	       | None -> app_stack s)
+      | _ -> app_stack s
+  in 
+  redrec (c, empty_stack)
+
+(* Simpl reduction tactic: same as simplify, but also reduces
+   elimination constants *)
+
+let whd_nf env sigma c = 
+  let rec nf_app (c, stack as s) =
+    match kind_of_term c with
+      | Lambda (name,c1,c2)    ->
+          (match decomp_stack stack with
+             | None -> (c,empty_stack)
+             | Some (a1,rest) -> 
+		 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)
+      | Case (ci,p,d,lf) ->
+          (try
+             nf_app (special_red_case sigma env nf_app (ci,p,d,lf), stack)
+           with Redelimination -> 
+	     s)
+      | Fix fix ->
+	  (match reduce_fix nf_app fix stack with
+             | Reduced s' -> nf_app s'
+	     | NotReducible -> s)
+      | _ when isEvalRef env c ->
+          (try
+	     nf_app (red_elim_const env sigma (destEvalRef c) stack)
+           with Redelimination -> 
+	     s)
+      | _ -> s
+  in 
+  app_stack (nf_app (c, empty_stack))
+
+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
+    | _ -> false
+
+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"
+  else
+   let rec traverse (env,c as envc) t =
+    if locs <> [] & (not except) & (!pos > maxocc) then t
+    else
+    if (not byhead & eq_constr c t) or (byhead & is_head c t) then
+      let ok = 
+	if except then not (List.mem (- !pos) locs)
+	else (locs = [] or List.mem !pos locs) in
+      incr pos;
+      if ok then
+	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
+	mkApp (f, array_map_left (traverse envc) l)
+      else
+	t
+    else
+      map_constr_with_binders_left_to_right
+	(fun d (env,c) -> (push_rel d env,lift 1 c))
+        traverse envc 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");
+  t'
+
+(* linear bindings (following pretty-printer) of the value of name in c.
+ * n is the number of the next occurence of name.
+ * ol is the occurence list to find. *)
+let rec substlin env name n ol c =
+  match kind_of_term c with
+    | Const kn when EvalConstRef kn = name ->
+        if List.hd ol = n then
+          try 
+	    (n+1, List.tl ol, constant_value env kn)
+          with
+	      NotEvaluableConst _ ->
+		errorlabstrm "substlin"
+		  (pr_kn kn ++ str " is not a defined constant")
+        else 
+	  ((n+1), ol, c)
+
+    | Var id when EvalVarRef id = name ->
+        if List.hd ol = n then
+          match lookup_named id env with
+	    | (_,Some c,_) -> (n+1, List.tl ol, c)
+	    | _ -> 
+		errorlabstrm "substlin"
+		  (pr_id id ++ str " is not a defined constant")
+        else 
+	  ((n+1), ol, c)
+
+    (* INEFFICIENT: OPTIMIZE *)
+    | App (c1,cl) ->
+        Array.fold_left 
+	  (fun (n1,ol1,c1') c2 ->
+	     (match ol1 with 
+                | [] -> (n1,[],applist(c1',[c2]))
+                | _  ->
+                    let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+                    (n2,ol2,applist(c1',[c2']))))
+          (substlin env name n ol c1) cl
+
+    | Lambda (na,c1,c2) ->
+        let (n1,ol1,c1') = substlin env name n ol c1 in
+        (match ol1 with 
+           | [] -> (n1,[],mkLambda (na,c1',c2))
+           | _  ->
+               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+               (n2,ol2,mkLambda (na,c1',c2')))
+
+    | LetIn (na,c1,t,c2) ->
+        let (n1,ol1,c1') = substlin env name n ol c1 in
+        (match ol1 with 
+           | [] -> (n1,[],mkLetIn (na,c1',t,c2))
+           | _  ->
+               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+               (n2,ol2,mkLetIn (na,c1',t,c2')))
+
+    | Prod (na,c1,c2) ->
+        let (n1,ol1,c1') = substlin env name n ol c1 in
+        (match ol1 with 
+           | [] -> (n1,[],mkProd (na,c1',c2))
+           | _  ->
+               let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+               (n2,ol2,mkProd (na,c1',c2')))
+	
+    | Case (ci,p,d,llf) -> 
+        let rec substlist nn oll = function
+          | []     -> (nn,oll,[])
+          | f::lfe ->
+              let (nn1,oll1,f') = substlin env name nn oll f in
+              (match oll1 with
+                 | [] -> (nn1,[],f'::lfe)
+                 | _  ->
+                     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))
+           | _  ->
+               let (n2,ol2,d') = substlin env name n1 ol1 d 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)   ->
+        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')))
+
+    | Fix _ -> 
+        (warning "do not consider occurrences inside fixpoints"; (n,ol,c))
+	
+    | CoFix _ -> 
+        (warning "do not consider occurrences inside cofixpoints"; (n,ol,c))
+
+    | (Rel _|Meta _|Var _|Sort _
+      |Evar _|Const _|Ind _|Construct _) -> (n,ol,c)
+
+let string_of_evaluable_ref env = function
+  | EvalVarRef id -> string_of_id id
+  | EvalConstRef kn ->
+      string_of_qualid 
+        (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn))
+
+let unfold env sigma name =
+  if is_evaluable env name then
+    clos_norm_flags (unfold_red name) env sigma
+  else
+    error (string_of_evaluable_ref env name^" is opaque")
+
+(* [unfoldoccs : (readable_constraints -> (int list * section_path) -> constr -> constr)]
+ * Unfolds the constant name in a term c following a list of occurrences occl.
+ * at the occurrences of occ_list. If occ_list is empty, unfold all occurences.
+ * Performs a betaiota reduction after unfolding. *)
+let unfoldoccs env sigma (occl,name) c =
+  match occl with
+    | []  -> unfold env sigma name c
+    | l -> 
+        match substlin env name 1 (Sort.list (<) l) c with
+          | (_,[],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))
+
+(* Unfold reduction tactic: *)
+let unfoldn loccname env sigma c = 
+  List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname
+
+(* Re-folding constants tactics: refold com in term c *)
+let fold_one_com com env sigma c =
+  let rcom =
+    try red_product env sigma com
+    with Redelimination -> error "Not reducible" in
+  subst1 com (subst_term rcom c)
+
+let fold_commands cl env sigma c =
+  List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c
+
+
+(* call by value reduction functions *)
+let cbv_norm_flags flags env sigma t =
+  cbv_norm (create_cbv_infos flags env) (nf_evar sigma t)
+
+let cbv_beta = cbv_norm_flags beta empty_env Evd.empty
+let cbv_betaiota = cbv_norm_flags betaiota empty_env Evd.empty
+let cbv_betadeltaiota env sigma =  cbv_norm_flags betadeltaiota env sigma
+
+let compute = cbv_betadeltaiota
+
+(* Pattern *)
+
+(* 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 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)
+  else 
+    mkLambda (na, ta,subst_term_occ locc a t)
+
+
+let pattern_occs loccs_trm env sigma c =
+  let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c 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,c) ->
+      (try Stringmap.find s !red_expr_tab
+      with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+(* Used in several tactics. *)
+
+exception NotStepReducible
+
+let one_step_reduce env sigma c = 
+  let rec redrec (x, largs as s) =
+    match kind_of_term x with
+      | Lambda (n,t,c)  ->
+          (match decomp_stack largs with
+             | None      -> raise NotStepReducible
+             | Some (a,rest) -> (subst1 a c, rest))
+      | App (f,cl) -> redrec (f, append_stack cl largs)
+      | LetIn (_,f,_,cl) -> (subst1 f cl,largs)
+      | Case (ci,p,c,lf) ->
+          (try
+	     (special_red_case sigma env (whd_betadeltaiota_state env sigma)
+	       (ci,p,c,lf), largs)
+           with Redelimination -> raise NotStepReducible)
+      | Fix fix ->
+	  (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
+             | Reduced s' -> s'
+	     | NotReducible -> raise NotStepReducible)
+      | Cast (c,_) -> redrec (c,largs)
+      | _ when isEvalRef env x ->
+	  let ref =
+            try destEvalRef x
+            with Redelimination -> raise NotStepReducible in
+          (try
+            red_elim_const env sigma ref largs
+           with Redelimination ->
+	     match reference_opt_value sigma env ref with
+	       | Some d -> d, largs
+	       | None -> raise NotStepReducible)
+
+      | _ -> raise NotStepReducible
+  in 
+  app_stack (redrec (c, empty_stack))
+
+(* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name
+   return name, B and t' *)
+
+let reduce_to_ind_gen allow_product env sigma t = 
+  let rec elimrec env t l = 
+    let c, _ = Reductionops.whd_stack t in
+    match kind_of_term c with
+      | Ind (mind,args) -> ((mind,args),it_mkProd_or_LetIn t l)
+      | Prod (n,ty,t') ->
+	  if allow_product then
+	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+	  else
+	     errorlabstrm "tactics__reduce_to_mind"
+	       (str"Not an inductive definition")
+      | _ ->
+          (try 
+	     let t' = nf_betaiota (one_step_reduce env sigma t) in 
+	     elimrec env t' l
+           with NotStepReducible ->
+	     errorlabstrm "tactics__reduce_to_mind"
+               (str"Not an inductive product"))
+  in
+  elimrec env t []
+
+let reduce_to_quantified_ind x = reduce_to_ind_gen true x
+let reduce_to_atomic_ind x = reduce_to_ind_gen false x
+
+let reduce_to_ref_gen allow_product env sigma ref t = 
+  let rec elimrec env t l = 
+    let c, _ = Reductionops.whd_stack t in
+    match kind_of_term c with
+      | Prod (n,ty,t') ->
+	  if allow_product then
+	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
+	  else 
+	     errorlabstrm "Tactics.reduce_to_ref_gen"
+	       (str"Not an induction object of atomic type")
+      | _ ->
+	  try 
+	    if reference_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 -> raise Not_found
+  in
+  elimrec env t []
+
+let reduce_to_quantified_ref = reduce_to_ref_gen true
+let reduce_to_atomic_ref = reduce_to_ref_gen false
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
new file mode 100644
index 00000000..162275d5
--- /dev/null
+++ b/pretyping/tacred.mli
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tacred.mli,v 1.21.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Evd
+open Reductionops
+open Closure
+open Rawterm
+(*i*)
+
+(*s Reduction functions associated to tactics. \label{tacred} *)
+
+val is_evaluable : env -> evaluable_global_reference -> bool
+
+exception Redelimination
+
+(* Red (raise Redelimination if nothing reducible) *)
+val red_product : reduction_function
+
+(* Hnf *)
+val hnf_constr :  reduction_function
+
+(* Simpl *)
+val nf :  reduction_function
+
+(* Unfold *)
+val unfoldn : 
+  (int list * evaluable_global_reference) list ->  reduction_function
+
+(* Fold *)
+val fold_commands : constr list ->  reduction_function
+
+(* Pattern *)
+val pattern_occs : (int list * constr) list ->  reduction_function
+(* Rem: Lazy strategies are defined in Reduction *)
+
+(* Call by value strategy (uses Closures) *)
+val cbv_norm_flags : Closure.RedFlags.reds ->  reduction_function
+  val cbv_beta : local_reduction_function
+  val cbv_betaiota : local_reduction_function
+  val cbv_betadeltaiota :  reduction_function
+  val compute :  reduction_function  (* = [cbv_betadeltaiota] *)
+
+(* [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)]
+   with [I] an inductive definition;
+   returns [I] and [t'] or fails with a user error *)
+val reduce_to_atomic_ind : env ->  evar_map -> types -> inductive * types
+
+(* [reduce_to_quantified_ind env sigma t] puts [t] in the form
+   [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition;
+   returns [I] and [t'] or fails with a user error *)
+val reduce_to_quantified_ind : env ->  evar_map -> types -> inductive * types
+
+(* [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
+   [t'=(x1:A1)..(xn:An)(ref args)] and raise Not_found if not possible *)
+val reduce_to_quantified_ref :
+  env ->  evar_map -> Libnames.global_reference -> types -> types
+
+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
+  -> 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
new file mode 100644
index 00000000..8f12ca62
--- /dev/null
+++ b/pretyping/termops.ml
@@ -0,0 +1,938 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: termops.ml,v 1.29.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Sign
+open Environ
+open Libnames
+open Nametab
+
+(* Sorts and sort family *)
+
+let print_sort = function
+  | Prop Pos -> (str "Set")
+  | Prop Null -> (str "Prop")
+  | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")")
+
+let print_sort_family = function
+  | InSet -> (str "Set")
+  | InProp -> (str "Prop")
+  | InType -> (str "Type")
+
+let pr_name = function
+  | Name id -> pr_id id
+  | Anonymous -> str "_"
+
+let pr_sp sp = str(string_of_kn sp)
+
+let rec print_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")")
+  | Prod (Name(id),t,c) -> hov 1
+      (str"forall " ++ pr_id id ++ str":" ++ print_constr t ++ str"," ++
+       spc() ++ print_constr c)
+  | Prod (Anonymous,t,c) -> hov 0
+      (str"(" ++ print_constr t ++ str " ->" ++ spc() ++
+       print_constr c ++ str")")
+  | Lambda (na,t,c) -> hov 1
+      (str"fun " ++ pr_name na ++ str":" ++
+       print_constr t ++ str" =>" ++ spc() ++ print_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)
+  | App (c,l) ->  hov 1
+      (str"(" ++ print_constr c ++ spc() ++
+       prlist_with_sep spc print_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")"
+  | 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) ++
+      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)) ++
+         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)) ++
+         str"}")
+
+(*let current_module = ref empty_dirpath
+
+let set_module m = current_module := m*)
+
+let new_univ = 
+  let univ_gen = ref 0 in
+  (fun sp ->
+    incr univ_gen; 
+    Univ.make_univ (Lib.library_dp(),!univ_gen))
+
+let new_sort_in_family = function 
+  | InProp -> mk_Prop
+  | InSet -> mk_Set
+  | InType -> Type (new_univ ())
+
+
+
+(* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *)
+let prod_it ~init = List.fold_left (fun c (n,t)  -> mkProd (n, t, c)) init
+
+(* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *)
+let lam_it ~init = List.fold_left (fun c (n,t)  -> mkLambda (n, t, c)) init
+
+(* [Rel (n+m);...;Rel(n+1)] *)
+let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
+
+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
+
+(* Same as [rel_list] but takes a context as argument and skips let-ins *)
+let extended_rel_list n hyps =
+  let rec reln l p = function
+    | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
+    | (_,Some _,_) :: hyps -> reln l (p+1) hyps
+    | [] -> l
+  in 
+  reln [] 1 hyps
+
+let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps)
+
+
+
+let push_rel_assum (x,t) env = push_rel (x,None,t) env
+
+let push_rels_assum assums =
+  push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums)
+
+let push_named_rec_types (lna,typarray,_) env =
+  let ctxt =
+    array_map2_i
+      (fun i na t ->
+	 match na with
+	   | Name id -> (id, None, type_app (lift i) t)
+	   | Anonymous -> anomaly "Fix declarations must be named")
+      lna typarray in
+  Array.fold_left
+    (fun e assum -> push_named assum e) env ctxt
+
+let rec lookup_rel_id id sign = 
+  let rec lookrec = function
+    | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l)
+    | (n, (Name id',_,t)::l)  -> if id' = id then (n,t) else lookrec (n+1,l)
+    | (_, [])                 -> raise Not_found
+  in 
+  lookrec (1,sign)
+
+(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+let mkProd_or_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na, t, c)
+    | Some b -> mkLetIn (na, b, t, c)
+
+(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
+let mkProd_wo_LetIn (na,body,t) c =
+  match body with
+    | None -> mkProd (na,  t, c)
+    | Some b -> subst1 b c
+
+let it_mkProd_wo_LetIn ~init = 
+  List.fold_left (fun c d -> mkProd_wo_LetIn d c) init
+
+let it_mkProd_or_LetIn ~init = 
+  List.fold_left (fun c d -> mkProd_or_LetIn d c) init
+
+let it_mkLambda_or_LetIn ~init =
+  List.fold_left (fun c d -> mkLambda_or_LetIn d c) init
+
+let it_named_context_quantifier f ~init = 
+  List.fold_left (fun c d -> f d c) 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
+
+(* *)
+
+(* strips head casts and flattens head applications *)
+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)
+      in 
+      collapse_rec f cl
+  | Cast (c,t) -> strip_head_cast c
+  | _ -> c
+
+(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
+   subterms of [c]; it carries an extra data [l] (typically a name
+   list) which is processed by [g na] (which typically cons [na] to
+   [l]) at each binder traversal (with name [na]); it is not recursive
+   and the order with which subterms are processed is not specified *)
+
+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)
+  | 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)
+  | App (c,al) -> mkApp (f l c, Array.map (f l) al)
+  | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
+  | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
+  | Fix (ln,(lna,tl,bl)) ->
+      let l' = Array.fold_left (fun l na -> g na l) l lna in
+      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let l' = Array.fold_left (fun l na -> g na l) l lna in
+      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
+
+(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the
+   immediate subterms of [c]; it carries an extra data [n] (typically
+   a lift index) which is processed by [g] (which typically add 1 to
+   [n]) at each binder traversal; the subterms are processed from left
+   to right according to the usual representation of the constructions
+   (this may matter if [f] does a side-effect); it is not recursive;
+   in fact, the usual representation of the constructions is at the
+   time being almost those of the ML representation (except for
+   (co-)fixpoint) *)
+
+let fold_rec_types g (lna,typarray,_) e =
+  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 -> g assum e) e ctxt
+
+
+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)
+  | Prod (na,t,c) ->
+      let t' = f l t in
+      mkProd (na, t', f (g (na,None,t) l) c)
+  | Lambda (na,t,c) ->
+      let t' = f l t in
+      mkLambda (na, t', f (g (na,None,t) l) c)
+  | LetIn (na,b,t,c) ->
+      let b' = f l b in
+      let t' = f l t in
+      let c' = f (g (na,Some b,t) l) c in
+      mkLetIn (na, b', t', c')
+  | App (c,[||]) -> assert false
+  | App (c,al) ->
+      (*Special treatment to be able to recognize partially applied subterms*)
+      let a = al.(Array.length al - 1) in
+      let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in
+      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
+      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
+      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
+      mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl as fx)) ->
+      let l' = fold_rec_types g fx l in
+      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
+      mkCoFix (ln,(lna,tl',bl'))
+
+(* strong *)
+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) -> 
+      let c' = f l c in
+      let t' = f l t in
+      if c==c' && t==t' then cstr else mkCast (c', t')
+  | Prod (na,t,c) ->
+      let t' = f l t in
+      let c' = f (g (na,None,t) l) c in
+      if t==t' && c==c' then cstr else mkProd (na, t', c')
+  | Lambda (na,t,c) ->
+      let t' = f l t in
+      let c' = f (g (na,None,t) l) c in
+      if t==t' && c==c' then cstr else  mkLambda (na, t', c')
+  | LetIn (na,b,t,c) ->
+      let b' = f l b in
+      let t' = f l t in
+      let c' = f (g (na,Some b,t) l) c in
+      if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c')
+  | App (c,al) ->
+      let c' = f l c in
+      let al' = Array.map (f l) al in
+      if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al')
+  | Evar (e,al) ->
+      let al' = Array.map (f l) al in
+      if array_for_all2 (==) al al' then cstr else mkEvar (e, al')
+  | Case (ci,p,c,bl) ->
+      let p' = f l p in
+      let c' = f l c in
+      let bl' = Array.map (f l) bl in
+      if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else
+        mkCase (ci, p', c', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let tl' = Array.map (f l) tl in
+      let l' =
+        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let bl' = Array.map (f l') bl in
+      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      then cstr
+      else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let tl' = Array.map (f l) tl in
+      let l' =
+        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let bl' = Array.map (f l') bl in
+      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      then cstr
+      else mkCoFix (ln,(lna,tl',bl'))
+
+(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
+   subterms of [c] starting from [acc] and proceeding from left to
+   right according to the usual representation of the constructions as
+   [fold_constr] but it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive *)
+
+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
+  | 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
+  | App (c,l) -> Array.fold_left (f n) (f n acc c) l
+  | Evar (_,l) -> Array.fold_left (f n) acc l
+  | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
+  | Fix (_,(lna,tl,bl)) -> 
+      let n' = iterate g (Array.length tl) n in
+      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd
+  | CoFix (_,(lna,tl,bl)) ->
+      let n' = iterate g (Array.length tl) n in
+      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd
+
+(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate
+   subterms of [c]; it carries an extra data [acc] which is processed by [g] at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+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
+  | 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
+  | App (c,args) -> f l c; Array.iter (f l) args
+  | Evar (_,args) -> Array.iter (f l) args
+  | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl
+  | Fix (_,(lna,tl,bl)) -> 
+      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      Array.iter (f l) tl;
+      Array.iter (f l') bl
+  | CoFix (_,(lna,tl,bl)) ->
+      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      Array.iter (f l) tl;
+      Array.iter (f l') bl
+
+(***************************)
+(* occurs check functions  *)                         
+(***************************)
+
+exception Occur
+
+let occur_meta c =
+  let rec occrec c = match kind_of_term c with
+    | Meta _ -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur -> true
+
+let occur_existential c = 
+  let rec occrec c = match kind_of_term c with
+    | Evar _ -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur -> true
+
+let occur_const s c = 
+  let rec occur_rec c = match kind_of_term c with
+    | Const sp when sp=s -> raise Occur
+    | _ -> iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_evar n c = 
+  let rec occur_rec c = match kind_of_term c with
+    | Evar (sp,_) when sp=n -> raise Occur
+    | _ -> iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_in_global env id constr =
+  let vars = vars_of_global env constr in
+  if List.mem id vars then raise Occur
+
+let occur_var env s c = 
+  let rec occur_rec c =
+    occur_in_global env s c;
+    iter_constr occur_rec c
+  in 
+  try occur_rec c; false with Occur -> true
+
+let occur_var_in_decl env hyp (_,c,typ) =
+  match c with
+    | None -> occur_var env hyp typ
+    | Some body ->
+        occur_var env hyp typ ||
+        occur_var env hyp body
+
+(* Tests that t is a subterm of c *)
+let occur_term t c = 
+  let eq_constr_fail c = if eq_constr t c then raise Occur
+  in let rec occur_rec c = eq_constr_fail c; iter_constr occur_rec c
+  in try occur_rec c; false with Occur -> true
+
+(* returns the list of free debruijn indices in a term *)
+
+let free_rels m = 
+  let rec frec depth acc c = match kind_of_term c with
+    | Rel n       -> if n >= depth then Intset.add (n-depth+1) acc else acc
+    | _ -> fold_constr_with_binders succ frec depth acc c
+  in 
+  frec 1 Intset.empty m
+
+
+(* (dependent M N) is true iff M is eq_term with a subterm of N 
+   M is appropriately lifted through abstractions of N *)
+
+let dependent m t =
+  let rec deprec m t =
+    if eq_constr m t then
+      raise Occur
+    else
+      match kind_of_term m, kind_of_term t with
+	| App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
+	    deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
+	    Array.iter (deprec m)
+	      (Array.sub lt 
+		(Array.length lm) ((Array.length lt) - (Array.length lm)))
+	| _ -> iter_constr_with_binders (lift 1) deprec m t
+  in 
+  try deprec m t; false with Occur -> true
+
+let pop t = lift (-1) t
+
+(***************************)
+(*  bindings functions *)                         
+(***************************)
+
+type metamap = (metavariable * constr) list 
+
+let rec subst_meta bl c = 
+  match kind_of_term c with
+    | Meta i -> (try List.assoc i bl with Not_found -> c)
+    | _ -> map_constr (subst_meta bl) c
+
+(* First utilities for avoiding telescope computation for subst_term *)
+
+let prefix_application eq_fun (k,c) (t : constr) = 
+  let c' = collapse_appl c and t' = collapse_appl t in
+  match kind_of_term c', kind_of_term t' with
+    | App (f1,cl1), App (f2,cl2) ->
+	let l1 = Array.length cl1
+	and l2 = Array.length cl2 in
+	if l1 <= l2
+	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
+	  Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1)))
+	else 
+	  None
+    | _ -> None
+
+let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = 
+  let c' = collapse_appl c and t' = collapse_appl t in
+  match kind_of_term c', kind_of_term t' with
+    | App (f1,cl1), App (f2,cl2) ->
+	let l1 = Array.length cl1
+	and l2 = Array.length cl2 in
+	if l1 <= l2
+	   && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then
+	  Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1)))
+	else 
+	  None
+    | _ -> None
+
+(* Recognizing occurrences of a given (closed) subterm in a term for Pattern :
+   [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed)
+   term [c] in a term [t] *)
+(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*)
+
+let subst_term_gen eq_fun c t = 
+  let rec substrec (k,c as kc) t =
+    match prefix_application eq_fun kc t with
+      | Some x -> x
+      | None ->
+    if eq_fun c t then mkRel k
+    else
+      map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t
+  in 
+  substrec (1,c) t
+
+(* Recognizing occurrences of a given (closed) subterm in a term :
+   [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed)
+   term [c1] in a term [t] *)
+(*i Meme remarque : a priori [c] n'est pas forcement clos i*)
+
+let replace_term_gen eq_fun c by_c in_t = 
+  let rec substrec (k,c as kc) t =
+    match my_prefix_application eq_fun kc by_c t with
+      | Some x -> x
+      | None ->
+    (if eq_fun c t then (lift k by_c) else
+      map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c))
+	substrec kc t)
+  in 
+  substrec (0,c) in_t
+
+let subst_term = subst_term_gen eq_constr
+
+let replace_term = replace_term_gen eq_constr
+
+(* Substitute only a list of locations locs, the empty list is
+   interpreted as substitute all, if 0 is in the list then no
+   bindings is done. The list may contain only negative occurrences
+   that will not be substituted. *)
+
+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"
+  else
+   let rec substrec (k,c as kc) t =
+    if (not except) & (!pos > maxocc) then t
+    else
+    if eq_constr c t then
+      let r = 
+	if except then 
+	  if List.mem (- !pos) locs then t else (mkRel k)
+	else 
+	  if List.mem !pos locs then (mkRel k) else t
+      in incr pos; r
+    else
+      map_constr_with_binders_left_to_right
+	(fun d (k,c) -> (k+1,lift 1 c))
+        substrec kc t
+  in
+  let t' = substrec (1,c) t in
+  (!pos, t')
+
+let subst_term_occ locs c t = 
+  if locs = [] then subst_term c t
+  else if List.mem 0 locs then 
+    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");
+    t'
+
+let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
+  match bodyopt with
+    | None -> (id,None,subst_term_occ locs c typ)
+    | Some body -> 
+	if locs = [] then
+	  (id,Some (subst_term c body),type_app (subst_term c) typ)
+	else if List.mem 0 locs then 
+	  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");
+	  (id,Some body',t')
+
+
+(* First character of a constr *)
+
+let first_char id =
+  let id = string_of_id id in
+  assert (id <> "");
+  String.make 1 id.[0]
+
+let lowercase_first_char id = String.lowercase (first_char id)
+
+let vars_of_env env =
+  let s = 
+    Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s)
+      (named_context env) ~init:Idset.empty in
+  Sign.fold_rel_context
+    (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s)
+    (rel_context env) ~init:s
+
+let add_vname vars = function
+    Name id -> Idset.add id vars
+  | _ -> vars
+
+let id_of_global = Nametab.id_of_global
+
+let sort_hdchar = function
+  | Prop(_) -> "P"
+  | Type(_) -> "T"
+
+let hdchar env c = 
+  let rec hdrec k c =
+    match kind_of_term c with
+    | Prod (_,_,c)       -> hdrec (k+1) c
+    | Lambda (_,_,c)     -> hdrec (k+1) c
+    | LetIn (_,_,_,c)    -> hdrec (k+1) 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
+	if c = "?" then "y" else c
+    | Ind ((kn,i) as x) ->
+	if i=0 then 
+	  lowercase_first_char (id_of_label (label kn))
+	else 
+	  lowercase_first_char (id_of_global (IndRef x))
+    | Construct ((sp,i) as x) ->
+	lowercase_first_char (id_of_global (ConstructRef x))
+    | Var id  -> lowercase_first_char id
+    | Sort s -> sort_hdchar s
+    | Rel n ->
+	(if n<=k then "p" (* the initial term is flexible product/function *)
+	 else
+	   try match Environ.lookup_rel (n-k) env with
+	     | (Name id,_,_)   -> lowercase_first_char id
+	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
+	   with Not_found -> "y")
+    | Fix ((_,i),(lna,_,_)) -> 
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | CoFix (i,(lna,_,_)) -> 
+	let id = match lna.(i) with Name id -> id | _ -> assert false in
+	lowercase_first_char id
+    | Meta _|Evar _|Case (_, _, _, _) -> "y"
+  in 
+  hdrec 0 c
+
+let id_of_name_using_hdchar env a = function
+  | Anonymous -> id_of_string (hdchar env a) 
+  | Name id   -> id
+
+let named_hd env a = function
+  | Anonymous -> Name (id_of_string (hdchar env a)) 
+  | x         -> x
+
+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 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)
+
+let name_assumption env (na,c,t) =
+  match c with
+    | None      -> (named_hd_type env t na, None, t)
+    | Some body -> (named_hd env body na, c, t)
+
+let name_context env hyps =
+  snd
+    (List.fold_left
+       (fun (env,hyps) d -> 
+	  let d' = name_assumption env d in (push_rel d' env, d' :: hyps))
+       (env,[]) (List.rev hyps))
+
+let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b 
+let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b
+
+let it_mkProd_or_LetIn_name env b hyps =
+  it_mkProd_or_LetIn b (name_context env hyps)
+let it_mkLambda_or_LetIn_name env b hyps =
+  it_mkLambda_or_LetIn b (name_context env hyps)
+
+(*************************)
+(*   Names environments  *)
+(*************************)
+type names_context = name list
+let add_name n nl = n::nl
+let lookup_name_of_rel p names =
+  try List.nth names (p-1)
+  with Invalid_argument _ | Failure _ -> raise Not_found
+let rec lookup_rel_of_name id names = 
+  let rec lookrec n = function
+    | Anonymous :: l  -> lookrec (n+1) l
+    | (Name id') :: l -> if id' = id then n else lookrec (n+1) l
+    | []            -> raise Not_found
+  in 
+  lookrec 1 names
+let empty_names_context = []
+
+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:[]
+
+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)
+
+(**** Globality of identifiers *)
+
+(* TODO temporary hack!!! *)
+let rec is_imported_modpath = function
+  | MPfile dp -> dp <> (Lib.library_dp ())
+(*  | MPdot (mp,_) -> is_imported_modpath mp *)
+  | _ -> false
+
+let is_imported_ref = function
+  | VarRef _ -> false
+  | ConstRef kn 
+  | IndRef (kn,_)
+  | ConstructRef ((kn,_),_) 
+(*  | ModTypeRef ln  *) -> 
+      let (mp,_,_) = repr_kn kn in is_imported_modpath mp
+(*  | ModRef mp ->
+      is_imported_modpath mp
+*)
+
+let is_global id =
+  try 
+    let ref = locate (make_short_qualid id) in
+    not (is_imported_ref ref)
+  with Not_found -> 
+    false
+
+let is_section_variable id =
+  try let _ = Sign.lookup_named id (Global.named_context()) in true
+  with Not_found -> false
+
+let next_global_ident_from allow_secvar id avoid = 
+  let rec next_rec id =
+    let id = next_ident_away_from id avoid in
+    if (allow_secvar && is_section_variable id) || not (is_global id) then
+      id
+    else  
+      next_rec (lift_ident id)
+  in 
+  next_rec id
+
+let next_global_ident_away allow_secvar id avoid =
+  let id  = next_ident_away id avoid in
+  if (allow_secvar && is_section_variable id) || not (is_global id) then
+    id
+  else  
+    next_global_ident_from allow_secvar (lift_ident id) avoid
+
+(* 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
+      des noms à éviter 
+    - Règle 2 : c'est la dépendance qui décide si on affiche ou pas
+
+    Exemple : 
+    si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors
+    il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b)
+    mais f et f0 contribue à la liste des variables à éviter (en supposant 
+    que les noms f et f0 ne sont pas déjà pris)
+    Intérêt : noms homogènes dans un but avant et après Intro
+*)
+
+type used_idents = identifier list
+
+let occur_rel p env id = 
+  try lookup_name_of_rel p env = Name id
+  with Not_found -> false (* Unbound indice : may happen in debug *)
+
+let occur_id nenv id0 c =
+  let rec occur n c = match kind_of_term c with
+    | Var id when  id=id0 -> raise Occur
+    | Const kn when id_of_global (ConstRef kn) = id0 -> raise Occur
+    | Ind ind_sp
+	when id_of_global (IndRef ind_sp) = id0 ->
+        raise Occur
+    | Construct cstr_sp
+	when id_of_global (ConstructRef cstr_sp) = id0 ->
+        raise Occur
+    | Rel p when p>n & occur_rel (p-n) nenv id0 -> raise Occur
+    | _ -> iter_constr_with_binders succ occur n c
+  in 
+  try occur 1 c; false
+  with Occur -> true
+    | Not_found -> false (* Case when a global is not in the env *)
+
+let next_name_not_occuring is_goal_ccl name l env_names t =
+  let rec next id =
+    if List.mem id l or occur_id env_names id t or 
+      (* To be consistent with intro mechanism *)
+      (is_goal_ccl & is_global id & not (is_section_variable id))
+    then next (lift_ident id)
+    else id
+  in 
+  match name with
+    | Name id   -> next id
+    | Anonymous -> 
+        (* 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"
+
+(* 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) *)
+(* Remplace 2 versions précédentes buggées                  *)
+
+let rec eta_reduce_head c =
+  match kind_of_term c with
+    | Lambda (_,c1,c') ->
+	(match kind_of_term (eta_reduce_head c') with
+           | App (f,cl) ->
+               let lastn = (Array.length cl) - 1 in 
+               if lastn < 1 then anomaly "application without arguments"
+               else
+                 (match kind_of_term cl.(lastn) with
+                    | Rel 1 ->
+			let c' =
+                          if lastn = 1 then f
+			  else mkApp (f, Array.sub cl 0 lastn)
+			in
+			if noccurn 1 c'
+                        then lift (-1) c'
+                        else c
+                    | _   -> c)
+           | _ -> c)
+    | _ -> c
+
+(* alpha-eta conversion : ignore print names and casts *)
+let eta_eq_constr =
+  let rec aux t1 t2 =
+    let t1 = eta_reduce_head (strip_head_cast t1)
+    and t2 = eta_reduce_head (strip_head_cast t2) in
+    t1=t2 or compare_constr aux t1 t2
+  in aux
+
+
+(* iterator on rel context *)
+let process_rel_context f env =
+  let sign = named_context 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
+
+let assums_of_rel_context sign =
+  Sign.fold_rel_context
+    (fun (na,c,t) l ->
+      match c with
+          Some _ -> l
+        | None -> (na, t)::l)
+    sign ~init:[]
+
+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)
+	::(liftrec (k-1) sign)
+    | [] -> []
+  in
+  liftrec (rel_context_length sign) sign
+
+let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init
+
+let rec mem_named_context id = function
+  | (id',_,_) :: _ when id=id' -> true
+  | _ :: sign -> mem_named_context id sign
+  | [] -> false
+
+let make_all_name_different env =
+  let avoid = ref (ids_of_named_context (named_context env)) in
+  process_rel_context
+    (fun (na,c,t) newenv -> 
+       let id = next_name_away na !avoid in
+       avoid := id::!avoid;
+       push_rel (Name id,c,t) newenv)
+    env
+
+let global_vars env ids = Idset.elements (global_vars_set env ids)
+
+let global_vars_set_of_decl env = function
+  | (_,None,t) -> global_vars_set env t
+  | (_,Some c,t) ->
+      Idset.union (global_vars_set env t)
+        (global_vars_set env c)
+
+(* Remark: Anonymous var may be dependent in Evar's contexts *)
+let concrete_name is_goal_ccl l env_names n c =
+  if n = Anonymous & noccurn 1 c then
+    (Anonymous,l)
+  else
+    let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in
+    let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
+    (idopt, fresh_id::l)
+
+let concrete_let_name is_goal_ccl l env_names n c =
+  let fresh_id = next_name_not_occuring is_goal_ccl n l env_names c in
+  (Name fresh_id, fresh_id::l)
+
+let rec rename_bound_var env l c =
+  match kind_of_term c with
+  | Prod (Name s,c1,c2)  ->
+      if noccurn 1 c2 then
+        let env' = push_rel (Name s,None,c1) env in
+	mkProd (Name s, c1, rename_bound_var env' l c2)
+      else 
+        let s' = next_ident_away s (global_vars env c2@l) in
+        let env' = push_rel (Name s',None,c1) env in
+        mkProd (Name s', c1, rename_bound_var env' (s'::l) c2)
+  | 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)
+  | x -> c
+
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
new file mode 100644
index 00000000..dd9742ea
--- /dev/null
+++ b/pretyping/termops.mli
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: termops.mli,v 1.21.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Term
+open Sign
+open Environ
+
+(* Universes *)
+(*val set_module : Names.dir_path -> unit*)
+val new_univ : unit -> Univ.universe
+val new_sort_in_family : sorts_family -> sorts
+
+(* iterators on terms *)
+val print_sort : sorts -> std_ppcmds
+val print_sort_family : sorts_family -> std_ppcmds
+val print_constr : constr -> std_ppcmds
+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
+val rel_list : int -> int -> constr list
+val extended_rel_list : int -> rel_context -> constr list
+val extended_rel_vect : int -> rel_context -> constr array
+val push_rel_assum : name * types -> env -> env
+val push_rels_assum : (name * types) list -> env -> env
+val push_named_rec_types : name array * types array * 'a -> env -> env
+val lookup_rel_id : identifier -> rel_context -> int * types
+val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkProd_wo_LetIn : rel_declaration -> types -> types
+val it_mkProd_wo_LetIn : init:types -> rel_context -> types
+val it_mkProd_or_LetIn   : init:types -> rel_context -> types
+val it_mkLambda_or_LetIn : init:constr -> rel_context -> constr
+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
+
+(**********************************************************************)
+(* Generic iterators on constr                                        *)
+
+val map_constr_with_named_binders :
+  (name -> 'a -> 'a) ->
+  ('a -> constr -> constr) -> 'a -> constr -> constr
+val map_constr_with_binders_left_to_right :
+  (rel_declaration -> 'a -> 'a) -> 
+  ('a -> constr -> constr) ->
+    'a -> constr -> constr
+val map_constr_with_full_binders :
+  (rel_declaration -> 'a -> 'a) ->
+  ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
+   subterms of [c] starting from [acc] and proceeding from left to
+   right according to the usual representation of the constructions as
+   [fold_constr] but it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive *)
+
+val fold_constr_with_binders :
+  ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b
+
+val iter_constr_with_full_binders :
+  (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> 
+    constr -> unit
+
+(**********************************************************************)
+
+val strip_head_cast : constr -> constr
+
+(* occur checks *)
+exception Occur
+val occur_meta : types -> bool
+val occur_existential : types -> bool
+val occur_const : constant -> types -> bool
+val occur_evar : existential_key -> types -> bool
+val occur_in_global : env -> identifier -> constr -> unit
+val occur_var : env -> identifier -> types -> bool
+val occur_var_in_decl :
+  env ->
+  identifier -> 'a * types option * types -> bool
+val occur_term : constr -> constr -> bool
+val free_rels : constr -> Intset.t
+
+(* Substitution of metavariables *)
+type metamap = (metavariable * constr) list 
+val subst_meta : metamap -> constr -> constr
+
+(* [pop c] lifts by -1 the positive indexes in [c] *)
+val pop : constr -> constr
+
+(* bindings of an arbitrary large term. Uses equality modulo
+   reduction of let *)
+val dependent : constr -> constr -> bool
+val subst_term_gen :
+  (constr -> constr -> bool) -> constr -> constr -> constr
+val replace_term_gen :
+  (constr -> constr -> bool) ->
+    constr -> constr -> constr -> constr
+val subst_term : constr -> constr -> constr
+val replace_term : constr -> constr -> constr -> constr
+val subst_term_occ_gen :
+  int list -> int -> constr -> types -> int * types
+val subst_term_occ : int list -> constr -> types -> types
+val subst_term_occ_decl :
+  int list -> constr -> named_declaration -> named_declaration
+
+(* Alternative term equalities *)
+val eta_reduce_head : constr -> constr
+val eta_eq_constr : constr -> constr -> bool
+
+(* finding "intuitive" names to hypotheses *)
+val first_char : identifier -> string
+val lowercase_first_char : identifier -> string
+val sort_hdchar : sorts -> string
+val hdchar : env -> types -> string
+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 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
+val name_context : env -> rel_context -> rel_context
+
+val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types
+val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr
+val it_mkProd_or_LetIn_name   : env -> types -> rel_context -> types
+val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
+
+(* name contexts *)
+type names_context = name list
+val add_name : name -> names_context -> names_context
+val lookup_name_of_rel : int -> names_context -> name
+val lookup_rel_of_name : identifier -> names_context -> int
+val empty_names_context : names_context
+val ids_of_rel_context : rel_context -> identifier list
+val ids_of_named_context : named_context -> identifier list
+val ids_of_context : env -> identifier list
+val names_of_rel_context : env -> names_context
+
+(* Set of local names *)
+val vars_of_env: env -> Idset.t
+val add_vname : Idset.t -> name -> Idset.t
+
+(* sets of free identifiers *)
+type used_idents = identifier list
+val occur_rel : int -> name list -> identifier -> bool
+val occur_id : name list -> identifier -> constr -> bool
+
+val next_global_ident_away : 
+  (*allow section vars:*) bool -> identifier -> identifier list -> identifier
+val next_name_not_occuring :
+  bool -> name -> identifier list -> name list -> constr -> identifier
+val concrete_name :
+  bool -> identifier list -> name list -> name -> constr -> 
+    name * identifier list
+val concrete_let_name :
+  bool -> identifier list -> name list -> name -> constr -> name * identifier list
+val rename_bound_var : env -> identifier list -> types -> types
+
+(* other signature iterators *)
+val process_rel_context : (rel_declaration -> env -> env) -> env -> env
+val assums_of_rel_context : rel_context -> (name * constr) list
+val lift_rel_context : int -> rel_context -> rel_context
+val fold_named_context_both_sides :
+  ('a -> named_declaration -> named_declaration list -> 'a) ->
+    named_context -> init:'a -> 'a
+val mem_named_context : identifier -> named_context -> bool
+val make_all_name_different : env -> env
+
+val global_vars : env -> constr -> identifier list
+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
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
new file mode 100644
index 00000000..a84cd612
--- /dev/null
+++ b/pretyping/typing.ml
@@ -0,0 +1,174 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: typing.ml,v 1.32.6.2 2004/07/16 19:30:46 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Environ
+open Reductionops
+open Type_errors
+open Pretype_errors
+open Inductive
+open Typeops
+
+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 }
+
+(* 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 =
+  match kind_of_term cstr with
+    | Meta n ->
+	error "execute: found a non-instanciated goal"
+
+    | 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
+	{ uj_val = cstr; uj_type = jty }
+	
+    | Rel n -> 
+	judge_of_relative env n
+
+    | Var id -> 
+        judge_of_variable env id
+	  
+    | Const c ->
+        make_judge cstr (constant_type env c)
+	  
+    | Ind ind ->
+	make_judge cstr (type_of_inductive env ind)
+	  
+    | Construct cstruct -> 
+	make_judge cstr (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 (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 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 cofix = (i,recdef') in
+        check_cofix env cofix;
+	make_judge (mkCoFix cofix) tys.(i)
+	  
+    | Sort (Prop c) -> 
+	judge_of_prop_contents c
+
+    | Sort (Type u) ->
+	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
+	    
+    | Lambda (name,c1,c2) -> 
+        let j = execute mf env sigma c1 in
+	let var = type_judgment env sigma j in
+	let env1 = push_rel (name,None,var.utj_val) env in
+        let j' = execute mf env1 sigma 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 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
+	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 env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+        let j3 = execute mf env1 sigma 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
+	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
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let vdefj = execute_array mf env1 sigma 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
+
+
+let safe_machine env sigma constr = 
+  let mf = { fix = false; nocheck = false } in
+  execute mf env sigma constr
+
+let unsafe_machine env sigma constr =
+  let mf = { fix = false; nocheck = true } in
+  execute mf env sigma constr
+
+(* Type of a constr *)
+
+let type_of env sigma c = 
+  let j = safe_machine env sigma c in 
+  (* No normalization: it breaks Pattern! *)
+  (*nf_betaiota*) (body_of_type j.uj_type)
+
+(* The typed type of a judgment. *)
+
+let execute_type env sigma constr = 
+  let j = execute { fix=false; nocheck=true } env sigma constr in
+  assumption_of_judgment env sigma j
+
+let execute_rec_type env sigma constr = 
+  let j = execute { fix=false; nocheck=false } env sigma constr in
+  assumption_of_judgment env sigma j
+
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
new file mode 100644
index 00000000..4ea74dcd
--- /dev/null
+++ b/pretyping/typing.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: typing.mli,v 1.7.14.1 2004/07/16 19:30:47 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Environ
+open Evd
+(*i*)
+
+(* 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
+
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
new file mode 100644
index 00000000..423350d7
--- /dev/null
+++ b/proofs/clenv.ml
@@ -0,0 +1,1175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3 2004/07/16 19:30:48 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;
+    mkMeta n 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
new file mode 100644
index 00000000..10e0004e
--- /dev/null
+++ b/proofs/clenv.mli
@@ -0,0 +1,142 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.1 2004/07/16 19:30:49 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
+(*
+val clenv_constrain_dep_args : constr list -> wc clausenv -> wc clausenv
+*)
+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/doc.tex b/proofs/doc.tex
new file mode 100644
index 00000000..431027ef
--- /dev/null
+++ b/proofs/doc.tex
@@ -0,0 +1,14 @@
+
+\newpage
+\section*{The Proof Engine}
+
+\ocwsection \label{proofs}
+This chapter describes the \Coq\ proof engine, which is also called
+the ``refiner'', since it provides a way to build terms by successive
+refining steps. Those steps are either primitive rules or higher-level
+tactics.
+The modules of the proof engine are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=proofs.dep.ps,width=\linewidth}\end{center}
+
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
new file mode 100644
index 00000000..d59ff835
--- /dev/null
+++ b/proofs/evar_refiner.ml
@@ -0,0 +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        *)
+(************************************************************************)
+
+(* $Id: evar_refiner.ml,v 1.36.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+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 *)
+
+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 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 *)
+
+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) = 
+    try
+      List.nth (Evd.non_instantiated sigma) (n-1) 
+    with Failure _ -> 
+      error "not so many uninstantiated existential variables"
+  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
+
+
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
new file mode 100644
index 00000000..d7f393b3
--- /dev/null
+++ b/proofs/evar_refiner.mli
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: evar_refiner.mli,v 1.28.2.1 2004/07/16 19:30:49 herbelin Exp $ 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_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 : int -> constr -> identifier Tacexpr.gsimple_clause -> tactic
+(*
+val instantiate_tac : tactic_arg list -> tactic
+*)
+val instantiate_pf_com : int -> Topconstr.constr_expr -> pftreestate -> pftreestate
diff --git a/proofs/logic.ml b/proofs/logic.ml
new file mode 100644
index 00000000..3cc44a0f
--- /dev/null
+++ b/proofs/logic.ml
@@ -0,0 +1,786 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: logic.ml,v 1.80.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Evd
+open Term
+open Termops
+open Sign
+open Environ
+open Reductionops
+open Inductive
+open Inductiveops
+open Typing
+open Proof_trees
+open Proof_type
+open Typeops
+open Type_errors
+open Coqast
+open Retyping
+open Evarutil
+ 
+type refiner_error =
+
+  (* Errors raised by the refiner *)
+  | BadType of constr * constr * constr
+  | OccurMeta of constr
+  | OccurMetaGoal of constr
+  | CannotApply of constr * constr
+  | NotWellTyped of constr
+  | 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 _))) -> 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;
+  let r = tac gl in
+  check := c;
+  r
+
+let with_check tac gl =
+  let c = !check in
+  check := true;
+  let r = tac gl in
+  check := c;
+  r
+   
+(************************************************************************)
+(************************************************************************)
+(* 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
+
+(* The ClearBody tactic *)
+
+(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and
+   returns [tail::(f head (id,_,_) 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"
+
+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"
+
+let check_typability env sigma c =
+  if !check then let _ = type_of env sigma c in () 
+
+let recheck_typability (what,id) env sigma t =
+  try check_typability env sigma t
+  with _ ->
+    let s = match what with
+      | None -> "the conclusion"
+      | Some id -> "hypothesis "^(string_of_id id) in
+    error
+      ("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')
+
+
+(* Auxiliary functions for primitive MOVE tactic
+ *
+ * [move_after with_dep toleft (left,(hfrom,typfrom),right) hto] moves
+ * hyp [hfrom] just after the hyp [hto] which belongs to the hyps on the 
+ * left side [left] of the full signature if [toleft=true] or to the hyps 
+ * on the right side [right] if [toleft=false].
+ * If [with_dep] then dependent hypotheses are moved accordingly. *)
+
+let split_sign hfrom hto l =
+  let rec splitrec left toleft = function
+    | [] -> error ("No such hypothesis : " ^ (string_of_id hfrom))
+    | (hyp,c,typ) as d :: right ->
+      	if hyp = hfrom then 
+	  (left,right,d,toleft) 
+      	else 
+	  splitrec (d::left) (toleft or (hyp = hto)) right
+  in 
+  splitrec [] false l
+
+let move_after with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
+  let env = Global.env() in
+  let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) =
+    if toleft
+    then occur_var_in_decl env hyp2 d
+    else occur_var_in_decl env hyp d2
+  in
+  let rec moverec first middle = function
+    | [] -> error ("No such hypothesis : " ^ (string_of_id hto))
+    | (hyp,_,_) as d :: right ->
+	let (first',middle') =
+      	  if List.exists (test_dep d) middle then 
+	    if with_dep & (hyp <> hto) then 
+	      (first, d::middle)
+            else 
+	      error 
+		("Cannot move "^(string_of_id idfrom)^" after "
+		 ^(string_of_id hto)
+		 ^(if toleft then ": it occurs in " else ": it depends on ")
+		 ^(string_of_id hyp))
+          else 
+	    (d::first, middle)
+	in
+      	if hyp = hto then 
+	  (List.rev first')@(List.rev middle')@right
+      	else 
+	  moverec first' middle' right
+  in
+  if toleft then 
+    List.rev_append (moverec [] [declfrom] left) right
+  else 
+    List.rev_append left (moverec [] [declfrom] right)
+
+let check_backward_dependencies sign d =
+  if not (Idset.for_all
+	    (fun id -> mem_named_context id sign)
+	    (global_vars_set_of_decl (Global.env()) d))
+  then
+    error "Can't introduce at that location: free variable conflict"
+
+
+let check_forward_dependencies id tail =
+  let env = Global.env() in
+  List.iter
+    (function (id',_,_ as decl) ->
+       if occur_var_in_decl env id decl then
+	 error ((string_of_id id) ^ " is used in hypothesis " 
+		^ (string_of_id id')))
+    tail
+
+
+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]))
+
+let replace_hyp sign id d =
+  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)
+
+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))
+
+(************************************************************************)
+(************************************************************************)
+(* Implementation of the logical rules *)
+
+(* Will only be used on terms given to the Refine rule which have meta 
+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
+    | (App _| Case _) -> fold_constr collrec acc c
+    | _ -> acc
+  in 
+  List.rev(collrec [] c)
+
+let check_conv_leq_goal env sigma arg ty conclty =
+  if !check & not (is_conv_leq env sigma ty conclty) then 
+    raise (RefinerError (BadType (arg,ty,conclty)))
+
+let goal_type_of env sigma c =
+  (if !check then type_of else Retyping.get_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
+(*
+   if  not (occur_meta trm) then
+    let t'ty = (unsafe_machine env sigma trm).uj_type in 	
+    let _ = conv_leq_goal env sigma trm t'ty conclty in
+      (goalacc,t'ty)
+  else
+*)
+  match kind_of_term trm with
+    | Meta _ ->
+	if occur_meta conclty then
+          raise (RefinerError (OccurMetaGoal conclty));
+	(mk_goal hyps (nf_betaiota conclty))::goalacc, conclty
+
+    | 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'',conclty') =
+	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
+	check_conv_leq_goal env sigma trm conclty' conclty;
+        (acc'',conclty')
+
+    | Case (_,p,c,lf) ->
+	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
+	check_conv_leq_goal env sigma trm conclty' conclty;
+	let acc'' = 
+	  array_fold_left2
+            (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
+            acc' lbrty lf 
+	in
+	(acc'',conclty')
+
+    | _ -> 
+	if occur_meta trm then raise (RefinerError (OccurMeta trm));
+      	let t'ty = goal_type_of env sigma trm in
+	check_conv_leq_goal env sigma trm t'ty conclty;
+        (goalacc,t'ty)
+
+(* Same as mkREFGOALS but without knowing te type of the term. Therefore,
+ * Metas should be casted. *)
+
+and mk_hdgoals sigma goal goalacc trm =
+  let env = evar_env goal in
+  let hyps = goal.evar_hyps in
+  match kind_of_term trm with
+    | Cast (c,ty) when isMeta c ->
+	check_typability env sigma ty;
+	(mk_goal hyps (nf_betaiota ty))::goalacc,ty
+
+    | App (f,l) ->
+	let (acc',hdty) = mk_hdgoals sigma goal goalacc f in
+	mk_arggoals sigma goal acc' hdty (Array.to_list l)
+
+    | Case (_,p,c,lf) ->
+	let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in
+	let acc'' = 
+	  array_fold_left2
+            (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi))
+            acc' lbrty lf 
+	in
+	(acc'',conclty')
+
+    | _ -> goalacc, goal_type_of env sigma trm
+
+and mk_arggoals sigma goal goalacc funty = function
+  | [] -> goalacc,funty
+  | harg::tlargs as allargs ->
+      let t = whd_betadeltaiota (evar_env goal) sigma funty in
+      match kind_of_term t with
+	| Prod (_,c1,b) ->
+	    let (acc',hargty) = mk_refgoals sigma goal goalacc c1 harg in
+	    mk_arggoals sigma goal acc' (subst1 harg b) tlargs
+	| LetIn (_,c1,_,b) ->
+	    mk_arggoals sigma goal goalacc (subst1 c1 b) allargs
+	| _ -> raise (RefinerError (CannotApply (t,harg)))
+
+and mk_casegoals sigma goal goalacc p c =
+  let env = evar_env goal in
+  let (acc',ct) = mk_hdgoals sigma goal goalacc c in 
+  let (acc'',pt) = mk_hdgoals sigma goal acc' p in
+  let pj = {uj_val=p; uj_type=pt} in 
+  let indspec =
+    try find_mrectype env sigma ct
+    with Not_found -> anomaly "mk_casegoals" in
+  let (lbrty,conclty) =
+    type_case_branches_with_names env indspec pj c in
+  (acc'',lbrty,conclty)
+
+
+let error_use_instantiate () =
+  errorlabstrm "Logic.prim_refiner"
+    (str"cannot intro when there are open metavars in the domain type" ++
+       spc () ++ str"- use Instantiate")
+
+let convert_hyp sign sigma (id,b,bt as d) =
+  apply_to_hyp sign id
+    (fun sign (_,c,ct) _ ->
+       let env = Global.env_of_context sign in
+       if !check && not (is_conv env sigma bt ct) &&
+         not (option_compare (is_conv env sigma) b c) then
+	   error "convert-hyp rule passed non-converting term";
+       add_named_decl d sign)
+
+
+(************************************************************************)
+(************************************************************************)
+(* Primitive tactics are handled here *)
+
+let prim_refiner r sigma goal =
+  let env = evar_env goal in
+  let sign = goal.evar_hyps in
+  let cl = goal.evar_concl in
+  match r with
+    (* Logical rules *)
+    | Intro id ->
+    	if !check && mem_named_context id 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)
+			  (subst1 (mkVar id) b) in
+	       [sg]
+	   | 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)
+		   (subst1 (mkVar id) b) in
+	       [sg]
+	   | _ ->
+	       raise (RefinerError IntroNeedsProduct))
+	
+    | Intro_replacing id ->
+	(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 sg = mk_goal sign' (subst1 (mkVar id) b) in
+	       [sg]
+           | LetIn (_,c1,t1,b) ->
+	       if occur_meta c1 then error_use_instantiate();
+	       let sign' = replace_hyp sign id (id,Some c1,t1) in
+	       let sg = mk_goal sign' (subst1 (mkVar id) b) in
+	       [sg]
+	   | _ ->
+	       raise (RefinerError IntroNeedsProduct))
+	
+    | Cut (b,id,t) ->
+    	if !check && mem_named_context id 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]  
+
+    | FixRule (f,n,rest) ->
+     	let rec check_ind env k cl = 
+          match kind_of_term (strip_outer_cast cl) with 
+            | Prod (na,c1,b) -> 
+            	if k = 1 then 
+		  try 
+		    fst (find_inductive env sigma c1)
+		  with Not_found -> 
+		    error "cannot do a fixpoint on a non inductive type"
+            	else 
+		  check_ind (push_rel (na,None,c1) env) (k-1) b
+            | _ -> error "not enough products"
+	in
+	let (sp,_) = check_ind env n cl in
+	let all = (f,n,cl)::rest in
+     	let rec mk_sign sign = function 
+	  | (f,n,ar)::oth ->
+	      let (sp',_)  = check_ind env n ar in 
+	      if not (sp=sp') then 
+		error ("fixpoints should be on the same " ^ 
+		       "mutual inductive declaration");
+	      if !check && mem_named_context f sign then 
+		error "name already used in the environment";
+	      mk_sign (add_named_decl (f,None,ar) sign) oth
+	  | [] -> 
+	      List.map (fun (_,_,c) -> mk_goal sign c) all
+	in 
+	mk_sign sign all
+	
+    | Cofix (f,others) ->
+     	let rec check_is_coind env cl = 
+	  let b = whd_betadeltaiota env sigma cl in
+          match kind_of_term b with
+            | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b
+            | _ -> 
+		try 
+		  let _ = find_coinductive env sigma b in ()
+                with Not_found -> 
+		  error ("All methods must construct elements " ^
+			  "in coinductive 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
+                error "name already used in the environment")
+              with
+              |	Not_found ->
+                  mk_sign (add_named_decl (f,None,ar) sign) oth)
+	  | [] -> List.map (fun (_,c) -> mk_goal sign c) all
+     	in 
+	mk_sign sign all
+
+    | 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
+
+    (* Conversion rules *)
+    | 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]
+	else 
+	  error "convert-concl rule passed non-converting term"
+
+    | Convert_hyp (id,copt,ty) ->
+	[mk_goal (convert_hyp sign sigma (id,copt,ty)) cl]
+
+    (* And now the structural rules *)
+    | Thin ids -> 
+	[clear_hyps ids goal]
+
+    | 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'
+	in
+	let sign' = named_context (List.fold_left clear_aux env ids) in
+     	let sg = mk_goal sign' cl in
+     	[sg]
+
+    | Move (withdep, hfrom, hto) ->
+  	let (left,right,declfrom,toleft) = split_sign hfrom hto sign in
+  	let hyps' = 
+	  move_after withdep toleft (left,declfrom,right) hto in
+  	[mk_goal hyps' cl]
+
+    | Rename (id1,id2) ->
+        if !check & id1 <> id2 & List.mem id2 (ids_of_named_context 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']
+
+(************************************************************************)
+(************************************************************************)
+(* Extracting a proof term from the proof tree *)
+
+(* Util *)
+let rec rebind id1 id2 = function
+  | [] -> []
+  | id::l -> 
+      if id = id1 then id2::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
+
+    | Some (Prim (Rename (id1,id2)),[pf]) ->
+	subfun (rebind id1 id2 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
new file mode 100644
index 00000000..7eef22bd
--- /dev/null
+++ b/proofs/logic.mli
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.mli,v 1.27.6.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Evd
+open Environ
+open Proof_type
+(*i*)
+
+(* 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:\\
+  [Intro]: no check that the name does not exist\\
+  [Intro_after]: no check that the name does not exist and that variables in
+     its type does not escape their scope\\
+  [Intro_replacing]: no check that the name does not exist and that 
+     variables in its type does not escape their scope\\
+  [Convert_hyp]: 
+  no check that the name exist and that its type is convertible\\
+*)
+
+(* The primitive refiner. *)
+
+val prim_refiner : prim_rule -> evar_map -> goal -> goal list
+
+val prim_extractor :
+  (identifier list -> proof_tree -> constr)
+  -> identifier list -> proof_tree -> constr
+
+(*s Refiner errors. *)
+
+type refiner_error =
+
+  (*i Errors raised by the refiner i*)
+  | BadType of constr * constr * constr
+  | OccurMeta of constr
+  | OccurMetaGoal of constr
+  | CannotApply of constr * constr
+  | NotWellTyped of constr
+  | 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
new file mode 100644
index 00000000..f53ea870
--- /dev/null
+++ b/proofs/pfedit.ml
@@ -0,0 +1,333 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pfedit.ml,v 1.47.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Declarations
+open Entries
+open Environ
+open Evd
+open Typing
+open Tacmach
+open Proof_trees
+open Tacexpr
+open Proof_type
+open Lib
+open Safe_typing
+
+(*********************************************************************)
+(* Managing the proofs state                                         *)
+(* Mainly contributed by C. Murthy                                   *)
+(*********************************************************************)
+
+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 }
+
+let proof_edits =
+  (Edit.empty() : (identifier,pftreestate,proof_topstate) Edit.t)
+
+let get_all_proof_names () = Edit.dom proof_edits
+
+let msg_proofs use_resume =
+  match Edit.dom proof_edits with
+    | [] -> (spc () ++ str"(No proof-editing in progress).")
+    | l ->  (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++
+               (prlist_with_sep pr_spc pr_id (get_all_proof_names ())) ++
+	       str"." ++
+               (if use_resume then (fnl () ++ str"Use \"Resume\" first.")
+              	else (mt ()))
+)
+
+let undo_default = 50
+let undo_limit = ref undo_default
+
+(*********************************************************************)
+(*    Functions for decomposing and modifying the proof state        *)
+(*********************************************************************)
+
+let get_state () =
+  match Edit.read proof_edits with
+    | None -> errorlabstrm "Pfedit.get_state"
+          (str"No focused proof" ++ msg_proofs true)
+    | Some(_,pfs,ts) -> (pfs,ts)
+
+let get_topstate ()    = snd(get_state())
+let get_pftreestate () = fst(get_state())
+
+let get_end_tac () = let ts = get_topstate () in ts.top_end_tac
+
+let get_goal_context n =
+  let pftree = get_pftreestate () in
+  let goal = nth_goal_of_pftreestate n pftree in
+  (project goal, pf_env goal)
+
+let get_current_goal_context () = get_goal_context 1
+
+let set_current_proof = Edit.focus proof_edits
+
+let resume_proof (loc,id) = 
+  try 
+    Edit.focus proof_edits id
+  with Invalid_argument "Edit.focus" ->
+    user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false)
+
+let suspend_proof () =
+  try 
+    Edit.unfocus proof_edits
+  with Invalid_argument "Edit.unfocus" ->
+    errorlabstrm "Pfedit.suspend_current_proof"
+      (str"No active proof" ++ (msg_proofs true))
+      
+let resume_last_proof () =
+  match (Edit.last_focused proof_edits) with
+    | None ->
+        errorlabstrm "resume_last" (str"No proof-editing in progress.")
+    | Some p -> 
+	Edit.focus proof_edits p
+	  
+let get_current_proof_name () =
+  match Edit.read proof_edits with
+    | None ->
+        errorlabstrm "Pfedit.get_proof"
+          (str"No focused proof" ++ msg_proofs true)
+    | Some(na,_,_) -> na
+
+let add_proof (na,pfs,ts) =
+  Edit.create proof_edits (na,pfs,ts,!undo_limit+1)
+
+let delete_proof_gen = Edit.delete proof_edits
+
+let delete_proof (loc,id) =
+  try 
+    delete_proof_gen id
+  with (UserError ("Edit.delete",_)) ->
+    user_err_loc
+      (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false)
+      
+let init_proofs () = Edit.clear proof_edits
+		       
+let mutate f =
+  try 
+    Edit.mutate proof_edits (fun _ pfs -> f pfs)
+  with Invalid_argument "Edit.mutate" ->
+    errorlabstrm "Pfedit.mutate"
+      (str"No focused proof" ++ msg_proofs true)
+
+let start (na,ts) =
+  let pfs = mk_pftreestate ts.top_goal in 
+  add_proof(na,pfs,ts)
+    
+let restart_proof () =
+  match Edit.read proof_edits with
+    | None -> 
+	errorlabstrm "Pfedit.restart"
+          (str"No focused proof to restart" ++ msg_proofs true)
+    | Some(na,_,ts) -> 
+	delete_proof_gen na;
+        start (na,ts);
+        set_current_proof na
+
+let proof_term () =
+  extract_pftreestate (get_pftreestate())
+    
+(* Detect is one has completed a subtree of the initial goal *)
+let subtree_solved () = 
+  let pts = get_pftreestate () in
+  is_complete_proof (proof_of_pftreestate pts) & 
+  not (is_top_pftreestate pts)
+
+(*********************************************************************)
+(*                 Undo functions                                    *)
+(*********************************************************************)
+
+let set_undo = function
+  | None -> undo_limit := undo_default
+  | Some n -> 
+      if n>=0 then 
+	undo_limit := n
+      else 
+	error "Cannot set a negative undo limit"
+
+let get_undo () = Some !undo_limit
+
+let undo n =
+  try 
+    Edit.undo proof_edits n; 
+       (* needed because the resolution of a subtree is done in 2 steps 
+       then a sequence of undo can lead to a focus on a completely solved 
+       subtree - this solution only works properly if undoing one step *)
+    if subtree_solved() then  Edit.undo proof_edits 1
+  with (Invalid_argument "Edit.undo") ->
+    errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true)
+
+(*********************************************************************)
+(*                  Proof cooking                                    *)
+(*********************************************************************)
+
+let xml_cook_proof = ref (fun _ -> ())
+let set_xml_cook_proof f = xml_cook_proof := f
+
+let cook_proof () =
+  let (pfs,ts) = get_state() 
+  and ident = get_current_proof_name () in
+  let {evar_concl=concl} = ts.top_goal 
+  and strength = ts.top_strength in
+  let pfterm = extract_pftreestate pfs in
+  !xml_cook_proof (strength,pfs);
+  (ident,
+   ({ const_entry_body = pfterm;
+      const_entry_type = Some concl;
+      const_entry_opaque = true },
+    strength, ts.top_hook))
+
+let current_proof_statement () = 
+  let ts = get_topstate() in
+  (get_current_proof_name (), ts.top_strength, 
+   ts.top_goal.evar_concl, ts.top_hook)
+
+(*********************************************************************)
+(*              Abort   functions                                    *)
+(*********************************************************************)
+ 
+let refining () = [] <> (Edit.dom proof_edits)
+
+let check_no_pending_proofs () =
+  if refining () then 
+    errorlabstrm "check_no_pending_proofs"
+      (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++
+         str"Use \"Abort All\" first or complete proof(s).")
+
+let delete_current_proof () = delete_proof_gen (get_current_proof_name ())
+
+let delete_all_proofs = init_proofs
+
+(*********************************************************************)
+(*   Modifying the end tactic of the current profftree               *)
+(*********************************************************************)
+let set_end_tac tac =
+  let top = get_topstate () in
+  top.top_end_tac <- Some tac
+
+(*********************************************************************)
+(*              Modifying the current prooftree                      *)
+(*********************************************************************)
+
+let start_proof na str sign concl hook =
+  let top_goal = mk_goal sign concl in
+  let ts = { 
+    top_end_tac = None;
+    top_hyps = (sign,empty_named_context);
+    top_goal = top_goal;
+    top_strength = str;
+    top_hook = hook}
+  in
+  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
+    mutate (solve_nth_pftreestate k tac)
+  else 
+    error "cannot apply a tactic when we are descended behind a tactic-node"
+
+let by tac = mutate (solve_pftreestate tac)
+
+let instantiate_nth_evar_com n c =
+  mutate (Evar_refiner.instantiate_pf_com n c)
+
+let traverse n = mutate (traverse n)
+ 
+(* [traverse_to path]
+
+   Traverses the current proof to get to the location specified by
+   [path].
+
+   ALGORITHM: The algorithm works on reversed paths. One just has to remove
+   the common part on the reversed paths.
+
+*)
+
+let common_ancestor l1 l2 =
+  let rec common_aux l1 l2 =
+    match l1, l2 with
+      | a1::l1', a2::l2' when a1 = a2 -> common_aux l1' l2'
+      | _, _ -> List.rev l1, List.length l2
+  in
+  common_aux (List.rev l1) (List.rev l2)
+      
+let rec traverse_up = function
+  | 0 -> (function pf -> pf)
+  | n -> (function pf -> Tacmach.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))
+
+let traverse_to path =
+  let up_and_down path pfs =
+    let cursor = cursor_of_pftreestate pfs in
+    let down_list, up_count = common_ancestor path cursor in
+    traverse_down down_list (traverse_up up_count pfs)
+  in
+  mutate (up_and_down path)
+
+(* traverse the proof tree until it reach the nth subgoal *)
+let traverse_nth_goal n = mutate (nth_unproven n)
+
+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
+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))
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
new file mode 100644
index 00000000..e95881ba
--- /dev/null
+++ b/proofs/pfedit.mli
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pfedit.mli,v 1.35.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Pp
+open Names
+open Term
+open Sign
+open Environ
+open Decl_kinds
+open Tacmach
+open Tacexpr
+(*i*)
+
+(*s Several proofs can be opened simultaneously but at most one is
+   focused at some time. The following functions work by side-effect
+   on current set of open proofs. In this module, ``proofs'' means an
+   open proof (something started by vernacular command [Goal], [Lemma]
+   or [Theorem]), and ``goal'' means a subgoal of the current focused
+   proof *)
+
+(*s [refining ()] tells if there is some proof in progress, even if a not
+   focused one *)
+
+val refining : unit -> bool
+
+(* [check_no_pending_proofs ()] fails if there is still some proof in
+   progress *)
+
+val check_no_pending_proofs : unit -> unit
+
+(*s [delete_proof name] deletes proof of name [name] or fails if no proof
+    has this name *)
+
+val delete_proof : identifier located -> unit
+
+(* [delete_current_proof ()] deletes current focused proof or fails if
+    no proof is focused *)
+
+val delete_current_proof : unit -> unit
+
+(* [delete_all_proofs ()] deletes all open proofs if any *)
+
+val delete_all_proofs : unit -> unit
+
+(*s [undo n] undoes the effect of the last [n] tactics applied to the
+    current proof; it fails if no proof is focused or if the ``undo''
+    stack is exhausted *)
+
+val undo : int -> unit
+
+(* [set_undo (Some n)] sets the size of the ``undo'' stack; [set_undo None]
+   sets the size to the default value (12) *)
+
+val set_undo : int option -> unit
+val get_undo : unit -> int option
+
+(*s [start_proof s str env t hook] starts a proof of name [s] and conclusion
+    [t]; [hook] is optionally a function to be applied at proof end (e.g. to
+    declare the built constructions as a coercion or a setoid morphism) *)
+
+val start_proof : 
+  identifier -> goal_kind -> named_context -> constr
+    -> declaration_hook -> unit
+
+(* [restart_proof ()] restarts the current focused proof from the beginning
+   or fails if no proof is focused *)
+
+val restart_proof : unit -> unit
+
+(*s [resume_last_proof ()] focus on the last unfocused proof or fails
+   if there is no suspended proofs *)
+
+val resume_last_proof : unit -> unit
+
+(* [resume_proof name] focuses on the proof of name [name] or
+   raises [UserError] if no proof has name [name] *)
+
+val resume_proof : identifier located -> unit
+
+(* [suspend_proof ()] unfocuses the current focused proof or
+   failed with [UserError] if no proof is currently focused *)
+
+val suspend_proof : unit -> unit
+
+(*s [cook_proof opacity] turns the current proof (assumed completed) into
+    a constant with its name, kind and possible hook (see [start_proof]);
+    it fails if there is no current proof of if it is not completed *)
+
+val cook_proof : unit -> 
+  identifier * (Entries.definition_entry * goal_kind * declaration_hook)
+
+(* To export completed proofs to xml *)
+val set_xml_cook_proof : (goal_kind * pftreestate -> unit) -> unit
+
+(*s [get_pftreestate ()] returns the current focused pending proof or
+   raises [UserError "no focused proof"] *)
+
+val get_pftreestate : unit -> pftreestate
+
+(* [get_end_tac ()] returns the current tactic to apply to all new subgoal *)
+
+val get_end_tac : unit -> tactic option
+
+(* [get_goal_context n] returns the context of the [n]th subgoal of
+   the current focused proof or raises a [UserError] if there is no
+   focused proof or if there is no more subgoals *)
+
+val get_goal_context : int -> Evd.evar_map * env
+
+(* [get_current_goal_context ()] works as [get_goal_context 1] *)
+
+val get_current_goal_context : unit -> Evd.evar_map * env
+
+(* [current_proof_statement] *)
+
+val current_proof_statement :
+  unit -> identifier * goal_kind * types * declaration_hook
+
+(*s [get_current_proof_name ()] return the name of the current focused
+    proof or failed if no proof is focused *)
+
+val get_current_proof_name : unit -> identifier
+
+(* [get_all_proof_names ()] returns the list of all pending proof names *)
+
+val get_all_proof_names : unit -> identifier list
+
+(*s [set_end_tac tac] applies tactic [tac] to all subgoal generate
+    by [solve_nth] *)
+
+val set_end_tac : tactic -> unit
+
+(*s [solve_nth n tac] applies tactic [tac] to the [n]th subgoal of the
+   current focused proof or raises a UserError if no proof is focused or
+   if there is no [n]th subgoal *)
+
+val solve_nth : int -> tactic -> unit
+
+(* [by tac] applies tactic [tac] to the 1st subgoal of the current
+   focused proof or raises a UserError if there is no focused proof or
+   if there is no more subgoals *)
+
+val by : tactic -> unit
+
+(* [instantiate_nth_evar_com n c] instantiate the [n]th undefined
+   existential variable of the current focused proof by [c] or raises a
+   UserError if no proof is focused or if there is no such [n]th
+   existential variable *)
+
+val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit
+
+(*s To deal with subgoal focus *)
+
+val make_focus : int -> unit
+val focus : unit -> int
+val focused_goal : unit -> int
+val subtree_solved : unit -> bool
+
+val reset_top_of_tree : unit -> unit
+val traverse : int -> unit
+val traverse_nth_goal : int -> unit
+val traverse_next_unproven : unit -> unit
+val traverse_prev_unproven : unit -> unit
+
+
+(* These two functions make it possible to implement more elaborate
+   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
new file mode 100644
index 00000000..aaf54a36
--- /dev/null
+++ b/proofs/proof_trees.ml
@@ -0,0 +1,253 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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_trees.ml,v 1.53.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+open Closure
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Evd
+open Environ
+open Evarutil
+open Proof_type
+open Tacred
+open Typing
+open Libnames
+open Nametab
+
+(*
+let is_bind = function
+  | Tacexpr.Cbindings _ -> true
+  | _ -> false
+*)
+
+(* Functions on goals *)
+
+let mk_goal hyps cl = 
+  { evar_hyps = hyps; evar_concl = cl; 
+    evar_body = Evar_empty}
+
+(* Functions on proof trees *)
+
+let ref_of_proof pf =
+  match pf.ref with
+    | None -> failwith "rule_of_proof"
+    | Some r -> r
+
+let rule_of_proof pf =
+  let (r,_) = ref_of_proof pf in r
+
+let children_of_proof pf = 
+  let (_,cl) = ref_of_proof pf in cl
+				    
+let goal_of_proof pf = pf.goal
+
+let subproof_of_proof pf = match pf.ref with
+  | Some (Tactic (_,pf), _) -> pf
+  | _ -> failwith "subproof_of_proof"
+
+let status_of_proof pf = pf.open_subgoals
+
+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
+  | _ -> false
+
+
+(*******************************************************************)
+(*            Constraints for existential variables                *)
+(*******************************************************************)
+
+(* A readable constraint is a global constraint plus a focus set
+   of existential variables and a signature. *)
+
+(* Functions on readable constraints *)
+			     
+let mt_evcty gc = 
+  { it = empty_named_context; sigma = gc }
+
+let rc_of_gc evds gl = 
+  { it = gl.evar_hyps; sigma = evds }
+
+let rc_add evc (k,v) = 
+  { it  = evc.it;
+    sigma = Evd.add evc.sigma k v }
+
+let get_hyps  evc = evc.it
+let get_env   evc = Global.env_of_context evc.it
+let get_gc    evc = evc.sigma
+
+let pf_lookup_name_as_renamed env ccl s =
+  Detyping.lookup_name_as_renamed env ccl s
+
+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 env = evar_env g in
+  let penv = pr_context_of env in
+  let pc = prterm_env_at_top 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
new file mode 100644
index 00000000..c31d5207
--- /dev/null
+++ b/proofs/proof_trees.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: proof_trees.mli,v 1.27.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Evd
+open Environ
+open Proof_type
+(*i*)
+
+(* This module declares readable constraints, and a few utilities on
+   constraints and proof trees *)
+
+val mk_goal : named_context -> constr -> goal
+
+val rule_of_proof     : proof_tree -> rule
+val ref_of_proof      : proof_tree -> (rule * proof_tree list)
+val children_of_proof : proof_tree -> proof_tree list
+val goal_of_proof     : proof_tree -> goal
+val subproof_of_proof : proof_tree -> proof_tree
+val status_of_proof   : proof_tree -> int
+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
+
+
+(*s Pretty printing functions. *)
+
+(*i*)
+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
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
new file mode 100644
index 00000000..cbed5e27
--- /dev/null
+++ b/proofs/proof_type.ml
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: proof_type.ml,v 1.29.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+(*i*)
+open Environ
+open Evd
+open Names
+open Libnames
+open Term
+open Util
+open Tacexpr
+open Rawterm
+open Genarg
+open Nametab
+open Pattern
+(*i*)
+
+(* This module defines the structure of proof tree and the tactic type. So, it
+   is used by Proof_tree and Refiner *)
+
+type prim_rule =
+  | Intro of identifier
+  | Intro_replacing of identifier
+  | Cut of bool * identifier * types
+  | FixRule of identifier * int * (identifier * int * constr) list
+  | Cofix of identifier * (identifier * constr) list
+  | Refine of constr
+  | Convert_concl of types
+  | Convert_hyp of named_declaration
+  | Thin of identifier list
+  | ThinBody of identifier list
+  | Move of bool * identifier * identifier
+  | Rename of identifier * identifier
+
+
+(* 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;
+  ref : (rule * proof_tree list) option }
+
+and rule =
+  | Prim of prim_rule
+  | Tactic of tactic_expr * proof_tree
+  | Change_evars
+
+and goal = evar_info
+
+and tactic = goal sigma -> (goal list sigma * validation)
+
+and validation = (proof_tree list -> proof_tree)
+
+and tactic_expr =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_tactic_expr
+
+and atomic_tactic_expr =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_atomic_tactic_expr
+
+and tactic_arg =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_tactic_arg
+
+type hyp_location = identifier Tacexpr.raw_hyp_location
+
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
new file mode 100644
index 00000000..42606552
--- /dev/null
+++ b/proofs/proof_type.mli
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: proof_type.mli,v 1.33.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+
+(*i*)
+open Environ
+open Evd
+open Names
+open Libnames
+open Term
+open Util
+open Tacexpr
+open Rawterm
+open Genarg
+open Nametab
+open Pattern
+(*i*)
+
+(* This module defines the structure of proof tree and the tactic type. So, it
+   is used by [Proof_tree] and [Refiner] *)
+
+type prim_rule =
+  | Intro of identifier
+  | Intro_replacing of identifier
+  | Cut of bool * identifier * types
+  | FixRule of identifier * int * (identifier * int * constr) list
+  | Cofix of identifier * (identifier * constr) list
+  | Refine of constr
+  | Convert_concl of types
+  | Convert_hyp of named_declaration
+  | Thin of identifier list
+  | ThinBody of identifier list
+  | Move of bool * identifier * identifier
+  | Rename of identifier * identifier
+
+(* The type [goal sigma] is the type of subgoal. It has the following form
+\begin{verbatim}
+   it    = { evar_concl = [the conclusion of the subgoal]
+             evar_hyps = [the hypotheses of the subgoal]
+             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]
+             ed : [A set of existential variables depending in the subgoal]
+               number of first evar,
+               it = { evar_concl = [the type of first evar]
+                      evar_hyps = [the context of the evar]
+                      evar_body = [the body of the Evar if any]
+                      evar_info = { pgm    : [Useless ??]
+                                    lc     : [Set of evars occurring
+                                              in the type of evar] } };
+               ...
+               number of last evar, 
+               it = { evar_concl = [the type of evar]
+                      evar_hyps = [the context of the evar]
+                      evar_body = [the body of the Evar if any]
+                      evar_info = { pgm    : [Useless ??]
+                                    lc     : [Set of evars occurring
+                                              in the type of evar] } } }
+   }
+\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 
+  that the goal can be proven if the goals in [l] are solved. *)
+type proof_tree = {
+  open_subgoals : int;
+  goal : goal;
+  ref : (rule * proof_tree list) option }
+
+and rule =
+  | Prim of prim_rule
+  | Tactic of tactic_expr * proof_tree
+  | Change_evars
+
+and goal = evar_info
+
+and tactic = goal sigma -> (goal list sigma * validation)
+
+and validation = (proof_tree list -> proof_tree)
+
+and tactic_expr =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_tactic_expr
+
+and atomic_tactic_expr =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_atomic_tactic_expr
+
+and tactic_arg =
+  (constr,
+   constr_pattern,
+   evaluable_global_reference,
+   inductive,
+   ltac_constant,
+   identifier,
+   glob_tactic_expr)
+     Tacexpr.gen_tactic_arg
+
+type hyp_location = identifier Tacexpr.raw_hyp_location
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
new file mode 100644
index 00000000..55f11d52
--- /dev/null
+++ b/proofs/refiner.ml
@@ -0,0 +1,1030 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: refiner.ml,v 1.67.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Term
+open Termops
+open Sign
+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)
+
+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 pf_status pf = pf.open_subgoals
+
+let is_complete pf = (0 = (pf_status pf))
+
+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
+
+
+(* [mapshape [ l1 ; ... ; lk ] [ v1 ; ... ; vk ] [ p_1 ; .... ; p_(l1+...+lk) ]]
+   gives
+   [ (v1 [p_1 ... p_l1]) ; (v2 [ p_(l1+1) ... p_(l1+l2) ]) ; ... ;
+   (vk [ p_(l1+...+l(k-1)+1) ... p_(l1+...lk) ]) ]
+ *)
+
+let rec mapshape nl (fl : (proof_tree list -> proof_tree) list) 
+                    (l : proof_tree list) =
+  match nl with
+    | [] -> []
+    | h::t ->
+	let m,l = list_chop h l in 
+	(List.hd fl m) :: (mapshape t (List.tl fl) l)
+
+(* [frontier : proof_tree -> goal list * validation]
+   given a proof [p], [frontier p] gives [(l,v)] where [l] is the list of goals
+   to be solved to complete the proof, and [v] is the corresponding 
+   validation *)
+   
+let rec frontier p =
+  match p.ref with
+    | None -> 
+	([p.goal],
+	 (fun lp' -> 
+	    let p' = List.hd lp' in
+            if p'.goal = p.goal then 
+	      p'
+            else 
+	      errorlabstrm "Refiner.frontier"
+                (str"frontier was handed back a ill-formed proof.")))
+    | Some(r,pfl) ->
+    	let gll,vl = List.split(List.map frontier pfl) in
+    	(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')}))
+
+
+let rec frontier_map_rec f n p =
+  if n < 1 || n > p.open_subgoals then p else
+  match p.ref with
+    | None -> 
+        let p' = f p in
+        if p'.goal == p.goal || p'.goal = p.goal then p'
+        else 
+	  errorlabstrm "Refiner.frontier_map"
+            (str"frontier_map was handed back a ill-formed proof.")
+    | Some(r,pfl) ->
+        let (_,rpfl') =
+          List.fold_left
+            (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')}
+
+let frontier_map f n p =
+  let nmax = p.open_subgoals in
+  let n = if n < 0 then nmax + n + 1 else n in
+  if n < 1 || n > nmax then
+    errorlabstrm "Refiner.frontier_map" (str "No such subgoal"); 
+  frontier_map_rec f n p
+
+let rec frontier_mapi_rec f i p =
+  if p.open_subgoals = 0 then p else
+  match p.ref with
+    | None -> 
+        let p' = f i p in
+        if p'.goal == p.goal || p'.goal = p.goal then p'
+        else 
+	  errorlabstrm "Refiner.frontier_mapi"
+            (str"frontier_mapi was handed back a ill-formed proof.")
+    | Some(r,pfl) ->
+        let (_,rpfl') =
+          List.fold_left
+            (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')}
+
+let frontier_mapi f p = frontier_mapi_rec f 1 p
+
+(* [list_pf p] is the lists of goals to be solved in order to complete the
+   proof [p] *)
+
+let list_pf p = fst (frontier p)
+
+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 }
+
+(* Tactics table. *)
+
+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")
+
+
+(* refiner r is a tactic applying the rule r *)
+
+let bad_subproof () =
+  anomalylabstrm "Refiner.refiner" (str"Bad subproof in validation.")
+
+let check_subproof_connection gl spfl =
+  if not (list_for_all2eq (fun g pf -> g=pf.goal) gl spfl)
+  then (bad_subproof (); false) else true
+
+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 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"
+      
+   (* [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
+
+(*
+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))
+
+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
+
+(* [rc_of_pfsigma : proof sigma -> readable_constraints] *)
+let rc_of_pfsigma sigma = rc_of_gc sigma.sigma sigma.it.goal
+
+(* [rc_of_glsigma : proof sigma -> readable_constraints] *)
+let rc_of_glsigma sigma = rc_of_gc sigma.sigma sigma.it
+
+(* [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 *)
+
+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 ()
+      else !meta_cnt
+    in f
+  in
+  let open_obligations = ref [] in
+  let rec proof_extractor vl = function
+    | {ref=Some(Prim _,_)} as pf -> prim_extractor proof_extractor vl pf
+	  
+    | {ref=Some(Tactic (_,hidden_proof),spfl)} ->
+	let sgl,v = frontier hidden_proof in
+	let flat_proof = v spfl in
+	proof_extractor vl flat_proof
+	  
+    | {ref=Some(Change_evars,[pf])} -> (proof_extractor vl) pf
+	  
+    | {ref=None;goal=goal} ->
+	let visible_rels =
+          map_succeed
+            (fun id ->
+               try let n = list_index id vl in (n,id)
+	       with Not_found -> failwith "caught")
+            (ids_of_named_context 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))
+            sorted_rels in
+	let abs_concl =
+          List.fold_right (fun (_,decl) c -> mkNamedProd_or_LetIn decl c)
+            sorted_env goal.evar_concl	in
+        let inst = List.filter (fun (_,(_,b,_)) -> b = None) sorted_env in
+        let meta = next_meta () in
+	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"
+  in
+  let pfterm = proof_extractor [] pf in
+  (pfterm, List.rev !open_obligations)
+  
+(*********************)
+(*   Tacticals       *)
+(*********************)
+
+(* unTAC : tactic -> goal sigma -> proof sigma *)
+
+let unTAC tac g =
+  let (gl_sigma,v) = tac g in 
+  { it = v (List.map leaf gl_sigma.it); sigma = gl_sigma.sigma }
+
+let unpackage glsig = (ref (glsig.sigma)),glsig.it
+
+let repackage r v = {it=v;sigma = !r}
+
+let apply_sig_tac r tac g =
+  check_for_interrupt (); (* Breakpoint *) 
+  let glsigma,v = tac (repackage r g) in 
+  r := glsigma.sigma;
+  (glsigma.it,v)
+
+let idtac_valid = function
+    [pf] -> pf
+  | _ -> anomaly "Refiner.idtac_valid"
+
+(* [goal_goal_list : goal sigma -> goal list sigma] *)
+let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma}
+
+(* identity tactic without any message *)
+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
+
+(* 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
+
+(* The Fail tactic *)
+let tclFAIL lvl s g = raise (FailError (lvl,s))
+
+let start_tac gls =
+  let (sigr,g) = unpackage gls in
+  (sigr,[g],idtac_valid)
+
+let finish_tac (sigr,gl,p) = (repackage sigr gl, p)
+
+(* Apply [taci.(i)] on the first n-th subgoals and [tac] on the others *)
+let thensf_tac taci tac (sigr,gs,p) =
+  let n = Array.length taci in
+  let nsg = List.length gs in
+  if nsg<n then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
+  let gll,pl =
+    List.split
+      (list_map_i (fun i -> apply_sig_tac sigr (if i<n then taci.(i) else tac))
+	0 gs) in
+  (sigr, List.flatten gll,
+   compose p (mapshape (List.map List.length gll) pl))
+
+(* Apply [taci.(i)] on the last n-th subgoals and [tac] on the others *)
+let thensl_tac tac taci (sigr,gs,p) =
+  let n = Array.length taci in
+  let nsg = List.length gs in
+  if nsg<n then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
+  let gll,pl =
+    List.split
+      (list_map_i (fun i -> apply_sig_tac sigr (if i<0 then tac else taci.(i)))
+	(n-nsg) gs) in
+  (sigr, List.flatten gll,
+   compose p (mapshape (List.map List.length gll) pl))
+
+(* Apply [tac i] on the ith subgoal (no subgoals number check) *)
+let thensi_tac tac (sigr,gs,p) =
+  let gll,pl =
+    List.split (list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs) in
+  (sigr, List.flatten gll, compose p (mapshape (List.map List.length gll) pl))
+
+let then_tac tac = thensf_tac [||] tac
+
+let non_existent_goal n =
+  errorlabstrm ("No such goal: "^(string_of_int n))
+    (str"Trying to apply a tactic to a non existent goal")
+
+(* Apply tac on the i-th goal (if i>0). If i<0, then start counting from
+   the last goal (i=-1). *)
+let theni_tac i tac ((_,gl,_) as subgoals) =
+  let nsg = List.length gl in
+  let k = if i < 0 then nsg + i + 1 else i in
+  if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.")
+  else if k >= 1 & k <= nsg then
+    thensf_tac
+      (Array.init k (fun i -> if i+1 = k then tac else tclIDTAC)) tclIDTAC
+      subgoals
+  else non_existent_goal k 
+
+(* [tclTHENSFIRSTn tac1 [|t1 ; ... ; tn|] tac2 gls] applies the tactic [tac1]
+   to [gls] and applies [t1], ..., [tn] to the [n] first resulting
+   subgoals, and [tac2] to the others subgoals. Raises an error if
+   the number of resulting subgoals is strictly less than [n] *)
+let tclTHENSFIRSTn tac1 taci tac gls =
+  finish_tac (thensf_tac taci tac (then_tac tac1 (start_tac gls)))
+
+(* [tclTHENSLASTn tac1 tac2 [|t1 ;...; tn|] gls] applies the tactic [tac1]
+   to [gls] and applies [t1], ..., [tn] to the [n] last resulting
+   subgoals, and [tac2] to the other subgoals. Raises an error if the
+   number of resulting subgoals is strictly less than [n] *)
+let tclTHENSLASTn tac1 tac taci gls =
+  finish_tac (thensl_tac tac taci (then_tac tac1 (start_tac gls)))
+
+(* [tclTHEN_i tac taci gls] applies the tactic [tac] to [gls] and applies
+   [(taci i)] to the i_th resulting subgoal (starting from 1), whatever the
+   number of subgoals is *)
+let tclTHEN_i tac taci gls =
+  finish_tac (thensi_tac taci (then_tac tac (start_tac gls)))
+
+let tclTHENLASTn tac1 taci = tclTHENSLASTn tac1 tclIDTAC taci
+let tclTHENFIRSTn tac1 taci = tclTHENSFIRSTn tac1 taci tclIDTAC
+
+(* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
+   [tac2] to every resulting subgoals *)
+let tclTHEN tac1 tac2 = tclTHENSFIRSTn tac1 [||] tac2
+
+(* [tclTHENSV tac1 [t1 ; ... ; tn] gls] applies the tactic [tac1] to
+   [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises
+   an error if the number of resulting subgoals is not [n] *)
+let tclTHENSV tac1 tac2v =
+  tclTHENSFIRSTn tac1 tac2v (tclFAIL_s "Wrong number of tactics.")
+
+let tclTHENS tac1 tac2l = tclTHENSV tac1 (Array.of_list tac2l)
+
+(* [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+   to the last resulting subgoal *)
+let tclTHENLAST tac1 tac2 = tclTHENSLASTn tac1 tclIDTAC [|tac2|]
+
+(* [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+   to the first resulting subgoal *)
+let tclTHENFIRST tac1 tac2 = tclTHENSFIRSTn tac1 [|tac2|] tclIDTAC
+
+
+(* [tclTHENLIST [t1;..;tn]] applies [t1] then [t2] ... then [tn]. More
+   convenient than [tclTHEN] when [n] is large. *)
+let rec tclTHENLIST = function
+    [] -> tclIDTAC
+  | t1::tacl -> tclTHEN t1 (tclTHENLIST tacl)
+
+
+
+
+(* various progress criterions *)
+let same_goal gl subgoal = 
+  (hypotheses subgoal) = (hypotheses gl) &
+  eq_constr (conclusion subgoal) (conclusion gl)
+
+
+let weak_progress gls ptree =
+  (List.length gls.it <> 1) or 
+  (not (same_goal (List.hd gls.it) ptree.it))
+
+(* Il y avait ici un ts_eq ........ *)
+let progress gls ptree =
+  (weak_progress gls ptree) or
+  (not (ptree.sigma == gls.sigma))
+
+
+(* PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves
+the goal unchanged *)
+let tclPROGRESS tac ptree =
+  let rslt = tac ptree in
+  if progress (fst rslt) ptree then rslt
+  else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.")
+
+(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails 
+   if tac leaves the goal unchanged, possibly modifying sigma *)
+let tclWEAK_PROGRESS tac ptree =
+  let rslt = tac ptree in
+  if weak_progress (fst rslt) ptree then rslt
+  else errorlabstrm "Refiner.tclWEAK_PROGRESS" (str"Failed to progress.")
+
+
+(* Same as tclWEAK_PROGRESS but fails also if tactics generates several goals,
+   one of them being identical to the original goal *)
+let tclNOTSAMEGOAL (tac : tactic) goal =
+  let rslt = tac goal in
+  let gls = (fst rslt).it in
+  if List.exists (same_goal goal.it) gls
+  then errorlabstrm "Refiner.tclNOTSAMEGOAL" 
+      (str"Tactic generated a subgoal identical to the original goal.")
+  else rslt
+
+
+
+(* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *)
+let tclORELSE0 t1 t2 g =
+  try 
+    t1 g
+  with (* Breakpoint *)
+  | e when catchable_exception e -> check_for_interrupt (); t2 g
+  | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) ->
+      check_for_interrupt (); t2 g
+  | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
+  | Stdpp.Exc_located (s,FailError (lvl,s')) ->
+      raise (Stdpp.Exc_located (s,FailError (lvl - 1, s')))
+
+(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, 
+   then applies t2 *)
+let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
+
+(* TRY f tries to apply f, and if it fails, leave the goal unchanged *)
+let tclTRY f = (tclORELSE0 f tclIDTAC)
+
+let tclTHENTRY f g = (tclTHEN f (tclTRY g))
+
+(* Try the first tactic that does not fail in a list of tactics *)
+
+let rec tclFIRST = function
+  | [] -> tclFAIL_s "No applicable tactic."
+  |  t::rest -> tclORELSE0 t (tclFIRST rest)
+
+let ite_gen tcal tac_if continue tac_else gl=
+  let success=ref false in
+  let tac_if0 gl=
+    let result=tac_if gl in
+      success:=true;result in
+  let tac_else0 e gl=
+    if !success then 
+      raise e 
+    else 
+      tac_else gl in
+    try 
+      tcal tac_if0 continue gl
+    with (* Breakpoint *)
+      | e when catchable_exception e ->
+	  check_for_interrupt (); tac_else0 e gl
+      | (FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_))) as e ->
+	  check_for_interrupt (); tac_else0 e gl
+      | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
+      | Stdpp.Exc_located (s,FailError (lvl,s')) ->
+	  raise (Stdpp.Exc_located (s,FailError (lvl - 1, s')))
+	
+(* Try the first tactic and, if it succeeds, continue with 
+   the second one, and if it fails, use the third one *)
+
+let tclIFTHENELSE=ite_gen tclTHEN
+
+(* Idem with tclTHENS and tclTHENSV *)
+
+let tclIFTHENSELSE=ite_gen tclTHENS
+
+let tclIFTHENSVELSE=ite_gen tclTHENSV
+
+
+(* Fails if a tactic did not solve the goal *)
+let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.")
+
+(* Try the first thats solves the current goal *)
+let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl)
+
+			   
+(* Iteration tacticals *)
+
+let tclDO n t = 
+  let rec dorec k = 
+    if k < 0 then errorlabstrm "Refiner.tclDO"
+      (str"Wrong argument : Do needs a positive integer.");
+    if k = 0 then tclIDTAC
+    else if k = 1 then t else (tclTHEN t (dorec (k-1)))
+  in 
+  dorec n 
+
+(* Beware: call by need of CAML, g is needed *)
+let rec tclREPEAT t g =
+  (tclORELSE (tclTHEN t (tclREPEAT t)) tclIDTAC) g
+
+let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t))
+
+(* Repeat on the first subgoal (no failure if no more subgoal) *)
+let rec tclREPEAT_MAIN t g =
+  (tclORELSE (tclTHEN_i t (fun i -> if i = 1 then (tclREPEAT_MAIN t) else
+    tclIDTAC)) tclIDTAC) g
+
+(*s Tactics handling a list of goals. *)
+
+type validation_list = proof_tree list -> proof_tree list
+
+type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+
+(* Functions working on goal list for correct backtracking in Prolog *)
+
+let tclFIRSTLIST = tclFIRST
+let tclIDTAC_list gls = (gls, fun x -> x)
+
+(* first_goal : goal list sigma -> goal sigma *)
+
+let first_goal gls = 
+  let gl = gls.it and sig_0 = gls.sigma in 
+  if gl = [] then error "first_goal"; 
+  { it = List.hd gl; sigma = sig_0 }
+
+(* goal_goal_list : goal sigma -> goal list sigma *)
+
+let goal_goal_list gls = 
+  let gl = gls.it and sig_0 = gls.sigma in { it = [gl]; sigma = sig_0 }
+
+(* tactic -> tactic_list : Apply a tactic to the first goal in the list *)
+
+let apply_tac_list tac glls = 
+  let (sigr,lg) = unpackage glls in
+  match lg with
+  | (g1::rest) ->
+      let (gl,p) = apply_sig_tac sigr tac g1 in
+      let n = List.length gl in 
+      (repackage sigr (gl@rest), 
+       fun pfl -> let (pfg,pfrest) = list_chop n pfl in (p pfg)::pfrest)
+  | _ -> error "apply_tac_list"
+	  
+let then_tactic_list tacl1 tacl2 glls = 
+  let (glls1,pl1) = tacl1 glls in
+  let (glls2,pl2) = tacl2 glls1 in
+  (glls2, compose pl1 pl2)
+
+(* Transform a tactic_list into a tactic *)
+
+let tactic_list_tactic tac gls = 
+    let (glres,vl) = tac (goal_goal_list gls) in
+    (glres, compose idtac_valid vl)
+
+
+
+
+(* 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
+   proof-tree remembering how to rebuild the global proof-tree
+   possibly after modification of one of the focused children proof-tree.
+   The number in the stack corresponds to 
+   either the selected subtree and the validation is a function from a
+   proof-tree list consisting only of one proof-tree to the global
+   proof-tree 
+   or -1 when the move is done behind a registered tactic in which
+   case the validation corresponds to a constant function giving back 
+   the original proof-tree. *)
+
+type pftreestate = {
+  tpf      : proof_tree ;
+  tpfsigma : evar_map;
+  tstack   : (int * validation) list }
+
+let proof_of_pftreestate pts = pts.tpf
+let is_top_pftreestate pts = pts.tstack = [] 
+let cursor_of_pftreestate pts = List.map fst pts.tstack
+let evc_of_pftreestate pts = pts.tpfsigma
+
+let top_goal_of_pftreestate pts = 
+  { it = goal_of_proof pts.tpf; sigma = pts.tpfsigma }
+
+let nth_goal_of_pftreestate n pts =
+  let goals = fst (frontier pts.tpf) in
+  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];
+	       tstack = tl;
+	       tpfsigma = pts.tpfsigma })
+  | -1 -> (* go to the hidden tactic-proof, if any, otherwise fail *)
+      (match pts.tpf.ref with
+	 | Some (Tactic (_,spf),_) ->
+	     let v = (fun pfl -> pts.tpf) in 
+	     { tpf = spf;
+               tstack = (-1,v)::pts.tstack;
+               tpfsigma = pts.tpfsigma }
+	 | _ -> error "traverse: not a tactic-node")
+  | n -> (* when n>0, go to the nth child *)
+      let (npf,v) = descend n pts.tpf in 
+      { tpf = npf;
+        tpfsigma = pts.tpfsigma;
+        tstack = (n,v):: pts.tstack }
+
+let change_constraints_pftreestate newgc pts = { pts with tpfsigma = newgc }
+
+let app_tac sigr tac p =
+  let (gll,v) = tac {it=p.goal;sigma= !sigr} in
+  sigr := gll.sigma;
+  v (List.map leaf gll.it)
+
+(* solve the nth subgoal with tactic tac *)
+let solve_nth_pftreestate n tac pts =
+  let sigr = ref pts.tpfsigma in
+  let tpf' = frontier_map (app_tac sigr tac) n 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
+  { tpf      = tpf'';
+    tpfsigma = !sigr;
+    tstack   = pts.tstack }
+
+let solve_pftreestate = solve_nth_pftreestate 1
+
+(* This function implements a poor man's undo at the current goal.
+   This is a gross approximation as it does not attempt to clean correctly
+   the global constraints given in tpfsigma. *)
+
+let weak_undo_pftreestate pts =
+  let pf = leaf pts.tpf.goal in
+  { tpf = pf;
+    tpfsigma = pts.tpfsigma;
+    tstack = pts.tstack }
+
+(* Gives a new proof (a leaf) of a goal gl *)
+let mk_pftreestate g =
+  { tpf      = leaf g;
+    tstack   = [];
+    tpfsigma = Evd.empty }
+
+(* Extracts a constr from a proof-tree state ; raises an error if the
+   proof is not complete or the state does not correspond to the head
+   of the proof-tree *)
+
+let extract_open_pftreestate pts =
+  extract_open_proof pts.tpfsigma pts.tpf
+
+let extract_pftreestate pts =
+  if pts.tstack <> [] then
+    errorlabstrm "extract_pftreestate"
+      (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
+  if subgoals <> [] then
+   errorlabstrm "extract_proof"
+   (str "Attempt to save an incomplete proof");
+  let env = Global.env_of_context pts.tpf.goal.evar_hyps in
+  strong whd_betaiotaevar env pts.tpfsigma pfterm
+  (***
+  local_strong (Evarutil.whd_ise (ts_it pts.tpfsigma)) pfterm
+  ***)
+(* Focus on the first leaf proof in a proof-tree state *)
+
+let rec first_unproven pts =
+  let pf = (proof_of_pftreestate pts) in 
+  if is_complete_proof pf then
+    errorlabstrm "first_unproven" (str"No unproven subgoals");
+  if is_leaf_proof pf then
+    pts
+  else
+    let childnum =
+      list_try_find_i 
+	(fun n pf -> 
+	   if not(is_complete_proof pf) then n else failwith "caught")
+	1 (children_of_proof pf)
+    in 
+    first_unproven (traverse childnum pts)
+
+(* Focus on the last leaf proof in a proof-tree state *)
+
+let rec last_unproven pts =
+  let pf = proof_of_pftreestate pts in 
+  if is_complete_proof pf then
+    errorlabstrm "last_unproven" (str"No unproven subgoals");
+  if is_leaf_proof pf then
+    pts
+  else 
+    let children = (children_of_proof pf) in
+    let nchilds = List.length children in
+    let childnum =
+      list_try_find_i 
+        (fun n pf ->
+           if not(is_complete_proof pf) then n else failwith "caught")
+        1 (List.rev children)
+    in 
+    last_unproven (traverse (nchilds-childnum+1) pts)
+      
+let rec nth_unproven n pts =
+  let pf = proof_of_pftreestate pts in 
+  if is_complete_proof pf then
+    errorlabstrm "nth_unproven" (str"No unproven subgoals");
+  if is_leaf_proof pf then
+    if n = 1 then 
+      pts 
+    else
+      errorlabstrm "nth_unproven" (str"Not enough unproven subgoals")
+  else 
+    let children = children_of_proof pf in
+    let rec process i k = function
+      | [] -> 
+	  errorlabstrm "nth_unproven" (str"Not enough unproven subgoals")
+      | pf1::rest -> 
+	  let k1 = nb_unsolved_goals pf1 in 
+	  if k1 < k then 
+	    process (i+1) (k-k1) rest
+	  else 
+	    nth_unproven k (traverse i pts)
+    in 
+    process 1 n children
+
+let rec node_prev_unproven loc pts =
+  let pf = proof_of_pftreestate pts in 
+  match cursor_of_pftreestate pts with
+    | [] -> last_unproven pts
+    | n::l ->
+	if is_complete_proof pf or loc = 1 then
+          node_prev_unproven n (traverse 0 pts)
+	else 
+	  let child = List.nth (children_of_proof pf) (loc - 2) in
+	  if is_complete_proof child then
+	    node_prev_unproven (loc - 1) pts
+	  else 
+	    first_unproven (traverse (loc - 1) pts)
+
+let rec node_next_unproven loc pts =
+  let pf = proof_of_pftreestate pts in 
+  match cursor_of_pftreestate pts with
+    | [] -> first_unproven pts
+    | n::l ->
+	if is_complete_proof pf ||
+           loc = (List.length (children_of_proof pf)) then
+             node_next_unproven n (traverse 0 pts)
+	else if is_complete_proof (List.nth (children_of_proof pf) loc) then
+	  node_next_unproven (loc + 1) pts
+	else 
+	  last_unproven(traverse (loc + 1) pts)
+
+let next_unproven pts =
+  let pf = proof_of_pftreestate pts in 
+  if is_leaf_proof pf then
+    match cursor_of_pftreestate pts with
+      | [] -> error "next_unproven"
+      | n::_ -> node_next_unproven n (traverse 0 pts)
+  else 
+    node_next_unproven (List.length (children_of_proof pf)) pts
+
+let prev_unproven pts =
+  let pf = proof_of_pftreestate pts in 
+  if is_leaf_proof pf then
+    match cursor_of_pftreestate pts with
+      | [] -> error "prev_unproven"
+      | n::_ -> node_prev_unproven n (traverse 0 pts)
+  else 
+    node_prev_unproven 1 pts
+
+let rec top_of_tree pts = 
+  if is_top_pftreestate pts then pts else top_of_tree(traverse 0 pts)
+
+
+(* Pretty-printers. *)
+
+open Pp
+
+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
+
+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
+    msgnl (hov 0 (str" == " ++
+                  print_subscript (sig_sig gls) sign pf))
+  with e when catchable_exception e -> 
+    msgnl (hov 0 (str "Info failed to apply validation"))
+  end;
+  res
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
new file mode 100644
index 00000000..bed1158d
--- /dev/null
+++ b/proofs/refiner.mli
@@ -0,0 +1,210 @@
+
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: refiner.mli,v 1.31.2.1 2004/07/16 19:30:49 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Sign
+open Evd
+open Proof_trees
+open Proof_type
+open Tacexpr
+(*i*)
+
+(* The refiner (handles primitive rules and high-level tactics). *)
+
+val sig_it  : 'a sigma -> 'a
+val sig_sig : 'a sigma -> evar_map
+
+val project_with_focus : goal sigma -> named_context sigma
+
+val unpackage : 'a sigma -> evar_map ref * 'a
+val repackage : evar_map ref -> 'a -> 'a sigma
+val apply_sig_tac :
+  evar_map ref -> ('a sigma -> 'b sigma * 'c) -> 'a -> 'b * 'c
+
+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
+
+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
+
+val local_Constraints : tactic
+
+(* [frontier_map f n p] applies f on the n-th open subgoal of p and
+   rebuilds proof-tree.
+   n=1 for first goal, n negative counts from the right *)
+val frontier_map :
+  (proof_tree -> proof_tree) -> int -> proof_tree -> proof_tree
+
+(* [frontier_mapi f p] applies (f i) on the i-th open subgoal of p. *)
+val frontier_mapi :
+  (int -> proof_tree -> proof_tree) -> proof_tree -> proof_tree
+
+(*s Tacticals. *)
+
+(* [tclIDTAC] is the identity tactic without message printing*)
+val tclIDTAC          : tactic
+val tclIDTAC_MESSAGE  : string -> tactic
+
+
+(* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
+   [tac2] to every resulting subgoals *)
+val tclTHEN          : tactic -> tactic -> tactic
+
+(* [tclTHENLIST [t1;..;tn]] applies [t1] THEN [t2] ... THEN [tn]. More
+   convenient than [tclTHEN] when [n] is large *)
+val tclTHENLIST      : tactic list -> tactic
+
+(* [tclTHEN_i tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
+   [(tac2 i)] to the [i]$^{th}$ resulting subgoal (starting from 1) *)
+val tclTHEN_i        : tactic -> (int -> tactic) -> tactic
+
+(* [tclTHENLAST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+   to the last resulting subgoal (previously called [tclTHENL]) *)
+val tclTHENLAST         : tactic -> tactic -> tactic
+
+(* [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls] and [tac2]
+   to the first resulting subgoal *)
+val tclTHENFIRST         : tactic -> tactic -> tactic
+
+(* [tclTHENS tac1 [|t1 ; ... ; tn|] gls] applies the tactic [tac1] to
+   [gls] and applies [t1],..., [tn] to the [n] resulting subgoals. Raises
+   an error if the number of resulting subgoals is not [n] *)
+val tclTHENSV         : tactic -> tactic array -> tactic
+
+(* Same with a list of tactics *)
+val tclTHENS         : tactic -> tactic list -> tactic
+
+(* [tclTHENST] is renamed [tclTHENSFIRSTn]
+val tclTHENST        : tactic -> tactic array -> tactic -> tactic
+*)
+
+(* [tclTHENSLASTn tac1 [t1 ; ... ; tn] tac2 gls] applies [t1],...,[tn] on the
+   last [n] resulting subgoals and [tac2] on the remaining first subgoals *)
+val tclTHENSLASTn     : tactic -> tactic -> tactic array -> tactic
+
+(* [tclTHENSFIRSTn tac1 [t1 ; ... ; tn] tac2 gls] first applies [tac1], then
+   applies [t1],...,[tn] on the first [n] resulting subgoals and
+   [tac2] for the remaining last subgoals (previously called tclTHENST) *)
+val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic
+
+(* [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
+   applies [t1],...,[tn] on the last [n] resulting subgoals and leaves
+   unchanged the other subgoals *)
+val tclTHENLASTn    : tactic -> tactic array -> tactic
+
+(* [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then,
+   applies [t1],...,[tn] on the first [n] resulting subgoals and leaves
+   unchanged the other subgoals (previously called [tclTHENSI]) *)
+val tclTHENFIRSTn   : tactic -> tactic array -> tactic
+
+(* A special exception for levels for the Fail tactic *)
+exception FailError of int * string
+
+val tclORELSE        : tactic -> tactic -> tactic
+val tclREPEAT        : tactic -> tactic
+val tclREPEAT_MAIN   : tactic -> tactic
+val tclFIRST         : tactic list -> tactic
+val tclSOLVE         : tactic list -> tactic
+val tclTRY           : tactic -> tactic
+val tclTHENTRY       : tactic -> tactic -> tactic
+val tclCOMPLETE      : tactic -> tactic
+val tclAT_LEAST_ONCE : tactic -> tactic
+val tclFAIL          : int -> string -> tactic
+val tclDO            : int -> tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
+val tclWEAK_PROGRESS : tactic -> tactic
+val tclNOTSAMEGOAL   : tactic -> tactic
+val tclINFO          : tactic -> tactic
+
+(* [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
+   if it succeeds, applies [tac2] to the resulting subgoals, 
+   and if not applies [tac3] to the initial goal [gls] *)
+val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
+val tclIFTHENSELSE   : tactic -> tactic list -> tactic ->tactic
+val tclIFTHENSVELSE   : tactic -> tactic array -> tactic ->tactic
+
+(*s Tactics handling a list of goals. *)
+
+type validation_list = proof_tree list -> proof_tree list
+
+type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+
+val tclFIRSTLIST       : tactic_list list -> tactic_list
+val tclIDTAC_list      : tactic_list
+val first_goal         : 'a list sigma -> 'a sigma
+val apply_tac_list     : tactic -> tactic_list
+val then_tactic_list   : tactic_list -> tactic_list -> tactic_list
+val tactic_list_tactic : tactic_list -> tactic
+val goal_goal_list     : 'a sigma -> 'a list sigma
+
+
+(*s Functions for handling the state of the proof editor. *)
+
+type pftreestate
+
+val proof_of_pftreestate : pftreestate -> proof_tree
+val cursor_of_pftreestate : pftreestate -> int list
+val is_top_pftreestate : 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 solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate
+val solve_pftreestate : tactic -> pftreestate -> pftreestate
+
+(* a weak version of logical undoing, that is really correct only *)
+(* if there are no existential variables.                         *)
+val weak_undo_pftreestate : pftreestate -> pftreestate
+
+val mk_pftreestate : goal -> pftreestate
+val extract_open_pftreestate : pftreestate -> constr * Termops.metamap
+val extract_pftreestate : pftreestate -> constr
+val first_unproven : pftreestate -> pftreestate
+val last_unproven : pftreestate -> pftreestate
+val nth_unproven : int -> pftreestate -> pftreestate
+val node_prev_unproven : int -> pftreestate -> pftreestate
+val node_next_unproven : int -> pftreestate -> pftreestate
+val next_unproven : pftreestate -> pftreestate
+val prev_unproven : pftreestate -> pftreestate
+val top_of_tree : pftreestate -> pftreestate
+val change_constraints_pftreestate 
+  : evar_map -> pftreestate -> pftreestate
+
+
+(*s Pretty-printers. *)
+
+(*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
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
new file mode 100644
index 00000000..d8d7319d
--- /dev/null
+++ b/proofs/tacexpr.ml
@@ -0,0 +1,314 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tacexpr.ml,v 1.33.2.1 2004/07/16 19:30:49 herbelin Exp $ *)
+
+open Names
+open Topconstr
+open Libnames
+open Nametab
+open Rawterm
+open Util
+open Genarg
+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 raw_red_flag =
+  | FBeta
+  | FIota
+  | FZeta
+  | FConst of reference list
+  | FDeltaBut of reference list
+
+let make_red_flag =
+  let rec add_flag red = function
+    | [] -> red
+    | FBeta :: lf -> add_flag { red with rBeta = true } lf
+    | FIota :: lf -> add_flag { red with rIota = true } lf
+    | FZeta :: lf -> add_flag { red with rZeta = true } lf
+    | FConst l :: lf ->
+	if red.rDelta then
+	  error
+	    "Cannot set both constants to unfold and constants not to unfold";
+        add_flag { red with rConst = list_union red.rConst l } lf
+    | FDeltaBut l :: lf ->
+	if red.rConst <> [] & not red.rDelta then
+	  error
+	    "Cannot set both constants to unfold and constants not to unfold";
+        add_flag 
+	  { red with rConst = list_union red.rConst l; rDelta = true }
+	  lf
+  in
+  add_flag
+    {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} 
+
+type hyp_location_flag = (* To distinguish body and type of local defs *)
+  | InHyp
+  | InHypTypeOnly
+  | InHypValueOnly
+
+type 'a raw_hyp_location = 
+    'a * int list * (hyp_location_flag * hyp_location_flag option ref)
+
+type 'a induction_arg =
+  | ElimOnConstr of 'a
+  | ElimOnIdent of identifier located
+  | ElimOnAnonHyp of int
+
+type inversion_kind =
+  | SimpleInversion
+  | FullInversion
+  | 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
+  | InversionUsing of 'c * 'id list
+
+type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
+
+type 'id gsimple_clause = ('id raw_hyp_location) option
+(* onhyps:
+     [None] means *on every hypothesis*
+     [Some l] means on hypothesis belonging to l *)
+type 'id gclause =
+  { onhyps : 'id raw_hyp_location list option;
+    onconcl : bool;
+    concl_occs :int list }
+
+let simple_clause_of = function
+    { onhyps = Some[scl]; onconcl = false } -> Some scl
+  | { onhyps = Some []; onconcl = true; concl_occs=[] } -> None
+  | _ -> error "not a simple clause (one hypothesis or conclusion)"
+
+type pattern_expr = constr_expr
+
+(* Type of patterns *)
+type 'a match_pattern =
+  | Term of 'a
+  | Subterm of identifier option * 'a
+
+(* Type of hypotheses for a Match Context rule *)
+type 'a match_context_hyps =
+  | Hyp of name located * 'a match_pattern
+
+(* Type of a Match rule for Match Context and Match *)
+type ('a,'t) match_rule =
+  | Pat of 'a match_context_hyps list * 'a match_pattern * 't
+  | All of 't
+
+type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
+  (* Basic tactics *)
+  | TacIntroPattern of intro_pattern_expr list
+  | TacIntrosUntil of quantified_hypothesis
+  | TacIntroMove of identifier option * identifier located option
+  | TacAssumption
+  | TacExact of 'constr
+  | TacApply of 'constr with_bindings
+  | TacElim of 'constr with_bindings * 'constr with_bindings option
+  | TacElimType of 'constr
+  | TacCase of 'constr with_bindings
+  | TacCaseType of 'constr
+  | TacFix of identifier option * int
+  | TacMutualFix of identifier * int * (identifier * int * 'constr) list
+  | TacCofix of identifier option
+  | TacMutualCofix of identifier * (identifier * 'constr) list
+  | TacCut of 'constr
+  | TacTrueCut of name * 'constr 
+  | TacForward of bool * name * 'constr
+  | TacGeneralize of 'constr list
+  | TacGeneralizeDep of 'constr
+  | TacLetTac of name * 'constr * 'id gclause
+  | TacInstantiate of int * 'constr * 'id gclause
+
+  (* 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)
+  | 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)
+
+  | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis
+  | TacDecomposeAnd of 'constr
+  | TacDecomposeOr of 'constr
+  | TacDecompose of 'ind list * 'constr
+  | TacSpecialize of int option * 'constr with_bindings
+  | TacLApply of 'constr
+
+  (* Automation tactics *)
+  | TacTrivial of string list option
+  | TacAuto of int option * string list option
+  | TacAutoTDB of int option
+  | TacDestructHyp of (bool * identifier located)
+  | TacDestructConcl
+  | TacSuperAuto of (int option * reference list * bool * bool)
+  | TacDAuto of int option * int option
+
+  (* Context management *)
+  | TacClear of 'id list
+  | TacClearBody of 'id list
+  | TacMove of bool * 'id * 'id
+  | TacRename of 'id * 'id
+
+  (* Constructors *)
+  | TacLeft of 'constr bindings
+  | TacRight of 'constr bindings
+  | TacSplit of bool * 'constr bindings
+  | TacAnyConstructor of 'tac option
+  | TacConstructor of int or_metaid * 'constr bindings
+
+  (* Conversion *)
+  | TacReduce of ('constr,'cst) red_expr_gen * 'id gclause
+  | TacChange of
+      'constr occurrences option * 'constr * 'id gclause
+
+  (* Equivalence relations *)
+  | TacReflexivity
+  | TacSymmetry of 'id gclause
+  | TacTransitivity of 'constr 
+
+  (* Equality and inversion *)
+  | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis
+      
+  (* For ML extensions *)
+  | TacExtend of loc * string * ('constr,'tac) generic_argument list
+
+  (* For syntax extensions *)
+  | TacAlias of loc * string *
+      (identifier * ('constr,'tac) generic_argument) list
+      * (dir_path * 'tac)
+
+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
+  | 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
+  | TacDo of int or_var * ('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
+  | 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
+  | 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
+
+and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_fun_ast =
+  identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr
+
+  (* These are possible arguments of a tactic definition *)
+and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg =
+  | TacDynamic     of loc * Dyn.t
+  | TacVoid
+  | MetaIdArg      of loc * string
+  | ConstrMayEval  of ('constr,'cst) may_eval
+  | IntroPattern   of intro_pattern_expr
+  | Reference      of 'ref
+  | Integer        of int
+  | TacCall        of loc *
+      'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list
+  | TacFreshId     of string option
+  | Tacexp of 'tac
+
+type raw_tactic_expr =
+    (constr_expr,
+     pattern_expr,
+     reference,
+     reference,
+     reference,
+     identifier located or_metaid,
+     raw_tactic_expr) gen_tactic_expr
+
+type raw_atomic_tactic_expr =
+    (constr_expr,                  (* constr *)
+     pattern_expr,                 (* pattern *)
+     reference,                    (* evaluable reference *)
+     reference,                    (* inductive *)
+     reference,                    (* ltac reference *)
+     identifier located or_metaid, (* identifier *)
+     raw_tactic_expr) gen_atomic_tactic_expr
+
+type raw_tactic_arg =
+    (constr_expr,
+     pattern_expr,
+     reference,
+     reference,
+     reference,
+     identifier located or_metaid,
+     raw_tactic_expr) gen_tactic_arg
+
+type raw_generic_argument =
+    (constr_expr,raw_tactic_expr) 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,
+     evaluable_global_reference and_short_name or_var,
+     inductive or_var,
+     ltac_constant located or_var,
+     identifier located,
+     glob_tactic_expr) gen_atomic_tactic_expr
+
+type glob_tactic_arg =
+    (rawconstr_and_expr,
+     constr_pattern,
+     evaluable_global_reference and_short_name or_var,
+     inductive or_var,
+     ltac_constant located,
+     identifier located or_var,
+     glob_tactic_expr) gen_tactic_arg
+
+type glob_generic_argument =
+    (rawconstr_and_expr,glob_tactic_expr) generic_argument
+
+type glob_red_expr =
+    (rawconstr_and_expr, evaluable_global_reference or_var) red_expr_gen
+
+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
+
+type 'a glob_abstract_argument_type =
+    ('a,rawconstr_and_expr,glob_tactic_expr) abstract_argument_type
+
+type open_generic_argument =
+    (Term.constr,glob_tactic_expr) generic_argument
+
+type closed_generic_argument =
+    (Term.constr,glob_tactic_expr) generic_argument
+
+type 'a closed_abstract_argument_type =
+    ('a,Term.constr,glob_tactic_expr) abstract_argument_type
+
+type declaration_hook = Decl_kinds.strength -> global_reference -> unit
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
new file mode 100644
index 00000000..0e3a49b0
--- /dev/null
+++ b/proofs/tacmach.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: tacmach.ml,v 1.61.2.1 2004/07/16 19:30:50 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Termops
+open Instantiate
+open Environ
+open Reductionops
+open Evd
+open Typing
+open Tacred
+open Proof_trees
+open Proof_type
+open Logic
+open Refiner
+open Tacexpr
+
+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 validation = Proof_type.validation;;
+type tactic     = Proof_type.tactic;;
+
+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 pf_concl gls = (sig_it gls).evar_concl
+let pf_hyps_types gls  =
+  let sign = Environ.named_context (pf_env gls) in
+  List.map (fun (id,_,x) -> (id, x)) sign
+
+let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id
+
+let pf_last_hyp gl = List.hd (pf_hyps gl)
+
+let pf_get_hyp gls id = 
+  try 
+    Sign.lookup_named id (pf_hyps gls)
+  with Not_found -> 
+    error ("No such hypothesis : " ^ (string_of_id id))
+
+let pf_get_hyp_typ gls id =
+  let (_,_,ty)= (pf_get_hyp gls id) in
+  ty
+
+let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls)
+
+let pf_get_new_id id gls = 
+  next_ident_away id (pf_ids_of_hyps gls)
+
+let pf_get_new_ids ids gls =
+  let avoid = pf_ids_of_hyps gls in
+  List.fold_right
+    (fun id acc -> (next_ident_away id (acc@avoid))::acc)
+    ids []
+
+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
+
+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_apply f gls = f (pf_env gls) (project gls)
+let pf_reduce = pf_apply
+
+let pf_whd_betadeltaiota         = pf_reduce whd_betadeltaiota
+let pf_whd_betadeltaiota_stack   = pf_reduce whd_betadeltaiota_stack
+let pf_hnf_constr                = pf_reduce hnf_constr
+let pf_red_product               = pf_reduce red_product
+let pf_nf                        = pf_reduce nf
+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_conv_x                   = pf_reduce is_conv
+let pf_conv_x_leq               = pf_reduce is_conv_leq
+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 pf_check_type gls c1 c2 = ignore (pf_type_of gls (mkCast (c1, c2)))
+
+(************************************)
+(* Tactics handling a list of goals *)
+(************************************)
+
+type transformation_tactic = proof_tree -> (goal list * validation)
+
+type validation_list = proof_tree list -> proof_tree list
+
+type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+
+let first_goal         = first_goal
+let goal_goal_list     = goal_goal_list
+let apply_tac_list     = apply_tac_list
+let then_tactic_list   = then_tactic_list
+let tactic_list_tactic = tactic_list_tactic
+let tclFIRSTLIST       = tclFIRSTLIST
+let tclIDTAC_list      = tclIDTAC_list
+
+
+(********************************************************)
+(* Functions for handling the state of the proof editor *)
+(********************************************************)
+
+type pftreestate = Refiner.pftreestate
+
+let proof_of_pftreestate    = proof_of_pftreestate
+let cursor_of_pftreestate   = cursor_of_pftreestate
+let is_top_pftreestate      = is_top_pftreestate
+let evc_of_pftreestate      = evc_of_pftreestate
+let top_goal_of_pftreestate = top_goal_of_pftreestate
+let nth_goal_of_pftreestate = nth_goal_of_pftreestate
+let traverse                = traverse
+let solve_nth_pftreestate   = solve_nth_pftreestate
+let solve_pftreestate       = solve_pftreestate
+let weak_undo_pftreestate   = weak_undo_pftreestate
+let mk_pftreestate          = mk_pftreestate
+let extract_pftreestate     = extract_pftreestate
+let extract_open_pftreestate = extract_open_pftreestate
+let first_unproven          = first_unproven
+let last_unproven           = last_unproven
+let nth_unproven            = nth_unproven
+let node_prev_unproven      = node_prev_unproven
+let node_next_unproven      = node_next_unproven
+let next_unproven           = next_unproven
+let prev_unproven           = prev_unproven
+let top_of_tree             = top_of_tree
+let frontier                = frontier
+let change_constraints_pftreestate = change_constraints_pftreestate
+
+
+(********************************************)
+(* Definition of the most primitive tactics *)
+(********************************************)
+
+let refiner = refiner
+
+(* This does not check that the variable name is not here *)
+let introduction_no_check id =
+  refiner (Prim (Intro id))
+
+(* This does not check that the dependencies are correct *)
+let intro_replacing_no_check whereid gl = 
+  refiner (Prim (Intro_replacing whereid)) gl
+
+let internal_cut_no_check id t gl = 
+  refiner (Prim (Cut (true,id,t))) gl
+
+let internal_cut_rev_no_check id t gl = 
+  refiner (Prim (Cut (false,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_hyp_no_check d gl =
+  refiner (Prim (Convert_hyp d)) gl
+
+(* This does not check dependencies *)
+let thin_no_check ids gl =
+  if ids = [] then tclIDTAC gl else refiner (Prim (Thin ids)) gl
+
+(* This does not check dependencies *)
+let thin_body_no_check ids gl =
+  if ids = [] then tclIDTAC gl else refiner (Prim (ThinBody ids)) gl
+
+let move_hyp_no_check with_dep id1 id2 gl = 
+  refiner (Prim (Move (with_dep,id1,id2))) gl
+
+let rename_hyp_no_check id1 id2 gl = 
+  refiner (Prim (Rename (id1,id2))) gl
+
+let mutual_fix f n others gl = 
+  with_check (refiner (Prim (FixRule (f,n,others)))) gl
+
+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
+
+
+(* Versions with consistency checks *)
+
+let introduction id    = with_check (introduction_no_check id) 
+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_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)
+let move_hyp b id id'  = with_check (move_hyp_no_check b id id') 
+let rename_hyp id id'  = with_check (rename_hyp_no_check id id')
+    
+(* Pretty-printers *)
+
+open Pp
+open Printer
+open Tacexpr
+open Rawterm
+
+let rec pr_list f = function
+  | []   -> mt ()
+  | 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))
+
+let pr_glls glls =
+  hov 0 (pr_decls (sig_sig glls) ++ fnl () ++
+         prlist_with_sep pr_fnl pr_seq (sig_it glls))
+  
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
new file mode 100644
index 00000000..59b48da2
--- /dev/null
+++ b/proofs/tacmach.mli
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: tacmach.mli,v 1.50.2.1 2004/07/16 19:30:50 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Environ
+open Evd
+open Reduction
+open Proof_trees
+open Proof_type
+open Refiner
+open Tacred
+open Tacexpr
+open Rawterm
+(*i*)
+
+(* Operations for handling terms under a local typing context. *)
+
+type 'a sigma   = 'a Proof_type.sigma;;
+type validation = Proof_type.validation;;
+type tactic     = Proof_type.tactic;;
+
+val sig_it  : 'a sigma   -> 'a
+val project : goal sigma -> evar_map
+
+val re_sig : 'a -> evar_map -> 'a sigma
+
+val unpackage : 'a sigma -> evar_map ref * 'a
+val repackage : evar_map ref -> 'a -> 'a sigma
+val apply_sig_tac :
+  evar_map ref -> ('a sigma -> 'b sigma * 'c) -> 'a -> 'b * 'c
+
+val pf_concl              : goal sigma -> types
+val pf_env                : goal sigma -> env
+val pf_hyps               : goal sigma -> named_context
+(*i val pf_untyped_hyps       : goal sigma -> (identifier * constr) list i*)
+val pf_hyps_types         : goal sigma -> (identifier * types) list
+val pf_nth_hyp_id         : goal sigma -> int -> identifier
+val pf_last_hyp           : goal sigma -> named_declaration
+val pf_ids_of_hyps        : goal sigma -> identifier list
+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
+val pf_interp_type        : goal sigma -> Topconstr.constr_expr -> types
+
+val pf_get_hyp            : goal sigma -> identifier -> named_declaration
+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_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a
+val pf_reduce : 
+  (env -> evar_map -> constr -> constr) ->
+    goal sigma -> constr -> constr
+
+val pf_whd_betadeltaiota       : goal sigma -> constr -> constr
+val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list 
+val pf_hnf_constr              : goal sigma -> constr -> constr
+val pf_red_product             : goal sigma -> constr -> constr
+val pf_nf                      : goal sigma -> constr -> constr
+val pf_nf_betaiota             : goal sigma -> constr -> constr
+val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types
+val pf_reduce_to_atomic_ind     : goal sigma -> types -> inductive * types
+val pf_compute                 : goal sigma -> constr -> constr
+val pf_unfoldn    : (int list * evaluable_global_reference) list
+        -> goal sigma -> constr -> constr
+
+val pf_const_value : goal sigma -> constant -> constr
+val pf_conv_x      : goal sigma -> constr -> constr -> bool
+val pf_conv_x_leq  : goal sigma -> constr -> constr -> bool
+
+type transformation_tactic = proof_tree -> (goal list * validation)
+
+val frontier : transformation_tactic
+
+
+(*s Functions for handling the state of the proof editor. *)
+
+type pftreestate = Refiner.pftreestate
+
+val proof_of_pftreestate    : pftreestate -> proof_tree
+val cursor_of_pftreestate   : pftreestate -> int list
+val is_top_pftreestate      : 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 weak_undo_pftreestate   : pftreestate -> pftreestate
+val solve_nth_pftreestate   : int -> tactic -> pftreestate -> pftreestate
+val solve_pftreestate       : tactic -> pftreestate -> pftreestate
+val mk_pftreestate          : goal -> pftreestate
+val extract_open_pftreestate : pftreestate -> constr * Termops.metamap
+val extract_pftreestate     : pftreestate -> constr
+val first_unproven          : pftreestate -> pftreestate
+val last_unproven           : pftreestate -> pftreestate
+val nth_unproven            : int -> pftreestate -> pftreestate
+val node_prev_unproven      : int -> pftreestate -> pftreestate
+val node_next_unproven      : int -> pftreestate -> pftreestate
+val next_unproven           : pftreestate -> pftreestate
+val prev_unproven           : pftreestate -> pftreestate
+val top_of_tree             : pftreestate -> pftreestate
+val change_constraints_pftreestate :
+  evar_map -> pftreestate -> pftreestate
+
+(*
+val vernac_tactic : string * tactic_arg list -> tactic
+*)
+(*s The most primitive tactics. *)
+
+val refiner                   : rule -> tactic
+val introduction_no_check     : identifier -> tactic
+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_hyp_no_check      : named_declaration -> tactic
+val thin_no_check             : identifier list -> tactic
+val thin_body_no_check        : identifier list -> tactic
+val move_hyp_no_check         : bool -> identifier -> identifier -> tactic
+val rename_hyp_no_check       : identifier -> identifier -> tactic
+val mutual_fix      :
+  identifier -> int -> (identifier * int * constr) list -> tactic
+val mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val rename_bound_var_goal : tactic
+
+(*s The most primitive tactics with consistency and type checking *)
+
+val introduction     : identifier -> tactic
+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_hyp      : named_declaration -> tactic
+val thin             : identifier list -> tactic
+val thin_body        : identifier list -> tactic
+val move_hyp         : bool -> identifier -> identifier -> tactic
+val rename_hyp       : identifier -> identifier -> tactic
+
+(*s Tactics handling a list of goals. *)
+
+type validation_list = proof_tree list -> proof_tree list
+
+type tactic_list = (goal list sigma) -> (goal list sigma) * validation_list
+
+val first_goal         : 'a list sigma -> 'a sigma
+val goal_goal_list     : 'a sigma -> 'a list sigma
+val apply_tac_list     : tactic -> tactic_list
+val then_tactic_list   : tactic_list -> tactic_list -> tactic_list
+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
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
new file mode 100644
index 00000000..1fa1101d
--- /dev/null
+++ b/proofs/tactic_debug.ml
@@ -0,0 +1,179 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Ast
+open 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
+
+(* 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
+   complete panel of commands dedicated to a proof assistant framework *)
+
+(* Debug information *)
+type debug_info =
+  | DebugOn of int
+  | DebugOff
+
+(* An exception handler *)
+let explain_logic_error = ref (fun e -> mt())
+
+(* Prints the goal *)
+let db_pr_goal g =
+  msgnl (str "Goal:" ++ fnl () ++ Proof_trees.pr_goal (Tacmach.sig_it g))
+
+(* Prints the commands *)
+let help () =
+  msgnl (str "Commands: <Enter>=Continue" ++ fnl() ++
+         str "          h/?=Help" ++ fnl() ++
+         str "          r<num>=Run <num> times" ++ fnl() ++
+         str "          s=Skip" ++ fnl() ++
+         str "          x=Exit")
+
+(* Prints the goal and the command to be executed *)
+let goal_com g tac =
+  begin
+    db_pr_goal g;
+    msg (str "Going to execute:" ++ fnl () ++ pr_glob_tactic tac ++ fnl ())
+  end
+
+(* Gives the number of a run command *)
+let run_com inst =
+  if (String.get inst 0)='r' then
+    let num = int_of_string (String.sub inst 1 ((String.length inst)-1)) in
+    if num>0 then num
+    else raise (Invalid_argument "run_com")
+  else
+    raise (Invalid_argument "run_com")
+
+let allskip = ref 0
+let skip = ref 0
+
+(* Prints the run counter *)
+let run ini =
+  if not ini then 
+    for i=1 to 2 do
+      print_char (Char.chr 8);print_char (Char.chr 13)
+    done;
+  msg (str "Executed expressions: " ++ int (!allskip - !skip) ++ 
+       fnl() ++ fnl())
+
+(* Prints the prompt *)
+let rec prompt level =
+  begin
+    msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ");
+    flush stdout;
+    let inst = read_line () in
+    match inst with
+    | ""  -> true
+    | "s" -> false
+    | "x" -> print_char (Char.chr 8);skip:=0;allskip:=0;raise Sys.Break
+    | "h"| "?" ->
+      begin
+        help ();
+        prompt level
+      end
+    | _ ->
+      (try let ctr=run_com inst in skip:=ctr;allskip:=ctr;run true;true
+       with Failure _ | Invalid_argument _ -> prompt level)
+  end
+
+(* Prints the state and waits for an instruction *)
+let debug_prompt lev g tac f =
+  (* What to print and to do next *)
+  let continue =
+    if !skip = 0 then (goal_com g tac; prompt lev)
+    else (decr skip; run false; if !skip=0 then allskip:=0; true) in
+  (* What to execute *)
+  try f (if continue then DebugOn (lev+1) else DebugOff)
+  with e ->
+    skip:=0; allskip:=0;
+    if Logic.catchable_exception e then
+      ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e);
+    raise e
+
+(* Prints a constr *)
+let db_constr debug env c =
+  if debug <> DebugOff & !skip = 0 then
+    msgnl (str "Evaluated term: " ++ prterm_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)
+  end
+
+(* Prints the hypothesis pattern identifier if it exists *)
+let hyp_bound = function
+  | Anonymous -> " (unbound)"
+  | Name id -> " (bound to "^(Names.string_of_id id)^")"
+
+(* Prints a matched hypothesis *)
+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)
+
+(* 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)
+
+(* Prints a success message when the goal has been matched *)
+let db_mc_pattern_success debug =
+  if debug <> DebugOff & !skip = 0 then
+    msgnl (str "The goal has been successfully matched!" ++ fnl() ++
+           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)
+  | Subterm (o,c) ->
+    Subterm (o,(extern_pattern env (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)
+
+(* Prints a matching failure message for a rule *)
+let db_matching_failure debug =
+  if debug <> DebugOff & !skip = 0 then
+    msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++
+           str "Let us try the next one...")
+
+(* 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
+    msgnl 
+      (str "This rule has failed due to \"Fail\" tactic (" ++
+       str 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 =
+  if debug <> DebugOff & !skip = 0 then
+  begin
+    msgnl (!explain_logic_error err);
+    msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++
+           str "Let us try the next one...")
+  end
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
new file mode 100644
index 00000000..9ab263c4
--- /dev/null
+++ b/proofs/tactic_debug.mli
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: tactic_debug.mli,v 1.12.2.1 2004/07/16 19:30:50 herbelin Exp $ i*)
+
+open Environ
+open Pattern
+open Proof_type
+open Names
+open Tacexpr
+open Term
+
+(* 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
+   complete panel of commands dedicated to a proof assistant framework *)
+
+(* Debug information *)
+type debug_info =
+  | DebugOn of int
+  | DebugOff
+
+(* Prints the state and waits *)
+val debug_prompt :
+  int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a
+
+(* Prints a constr *)
+val db_constr : debug_info -> env -> constr -> unit
+
+(* Prints the pattern rule *)
+val db_pattern_rule :
+  debug_info -> int -> (constr_pattern,glob_tactic_expr) match_rule -> unit
+
+(* Prints a matched hypothesis *)
+val db_matched_hyp :
+  debug_info -> env -> identifier * constr -> name -> unit
+
+(* Prints the matched conclusion *)
+val db_matched_concl : debug_info -> env -> constr -> unit
+
+(* Prints a success message when the goal has been matched *)
+val db_mc_pattern_success : debug_info -> unit
+
+(* Prints a failure message for an hypothesis pattern *)
+val db_hyp_pattern_failure :
+  debug_info -> env -> name * constr_pattern match_pattern -> unit
+
+(* Prints a matching failure message for a rule *)
+val db_matching_failure : debug_info -> unit
+
+(* Prints an evaluation failure message for a rule *)
+val db_eval_failure : debug_info -> string -> unit
+
+(* An exception handler *)
+val explain_logic_error: (exn -> Pp.std_ppcmds) ref
+
+(* Prints a logic failure message for a rule *)
+val db_logic_failure : debug_info -> exn -> unit
diff --git a/proofs/tmp-src b/proofs/tmp-src
new file mode 100644
index 00000000..1da11fe0
--- /dev/null
+++ b/proofs/tmp-src
@@ -0,0 +1,56 @@
+
+(********* INSTANTIATE ****************************************************)
+
+(* existential_type gives the type of an existential *)
+let existential_type env k = 
+  let (sp,args) = destConst k in
+  let evd = Evd.map (evar_map env) sp in
+  instantiate_constr 
+    (ids_of_sign evd.evar_hyps) evd.evar_concl.body (Array.to_list args)
+
+(* existential_value gives the value of a defined existential *)
+let existential_value env k =
+  let (sp,args) = destConst k in
+  if defined_const env k then
+    let evd = Evd.map (evar_map env) sp in
+    match evd.evar_body with
+      | EVAR_DEFINED c ->
+ 	  instantiate_constr (ids_of_sign evd.evar_hyps) c (Array.to_list args)
+      | _ -> anomalylabstrm "termenv__existential_value"
+            [< 'sTR"The existential variable code just registered a" ;
+               'sPC ; 'sTR"grave internal error." >]
+  else 
+    failwith "undefined existential"
+
+
+(******* REDUCTION ********************************************************)
+
+
+(************ REDUCTION.MLI **********************************************)
+
+(*********** TYPEOPS *****************************************************)
+
+
+(* Constants or existentials. *)
+
+let type_of_constant_or_existential env c =
+  if is_existential c then
+    type_of_existential env c
+  else
+    type_of_constant env c
+
+
+(******** TYPING **********************************************************)
+
+    | IsMeta n ->
+       	let metaty =
+          try lookup_meta n env
+          with Not_found -> error "A variable remains non instanciated" 
+	in
+        (match kind_of_term metaty with
+           | IsCast (typ,kind) -> 
+	       ({ uj_val = cstr; uj_type = typ; uj_kind = kind }, cst0)
+           | _ ->
+	       let (jty,cst) = execute mf env metaty in
+	       let k = whd_betadeltaiotaeta env jty.uj_type in
+	       ({ uj_val = cstr; uj_type = metaty; uj_kind = k }, cst))
diff --git a/scripts/coqc.ml b/scripts/coqc.ml
new file mode 100644
index 00000000..7d1cc206
--- /dev/null
+++ b/scripts/coqc.ml
@@ -0,0 +1,182 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqc.ml,v 1.25.2.1 2004/07/16 19:30:50 herbelin Exp $ *)
+
+(* Afin de rendre Coq plus portable, ce programme Caml remplace le script
+   coqc. 
+
+   Ici, on trie la ligne de commande pour en extraire les fichiers à compiler,
+   puis on les compile un par un en passant le reste de la ligne de commande
+   à un process "coqtop -batch -load-vernac-source <fichier>".
+
+   On essaye au maximum d'utiliser les modules Sys et Filename pour que la
+   portabilité soit maximale, mais il reste encore des appels à des fonctions
+   du module Unix. Ceux-ci sont préfixés par "Unix."
+*)
+
+(* environment *)
+
+let environment = Unix.environment ()
+
+let bindir = ref Coq_config.bindir
+let binary = ref ("coqtop." ^ Coq_config.best)
+let image = ref ""
+
+(* the $COQBIN environment variable has priority over the Coq_config value *)
+let _ = 
+  try 
+    let c = Sys.getenv "COQBIN" in
+    if c <> "" then bindir := c
+  with Not_found -> ()
+
+(* coqc options *)
+
+let specification = ref false
+let keep = ref false
+let verbose = ref false
+
+(* Verifies that a string starts by a letter and do not contain
+   others caracters than letters, digits, or `_` *)
+
+let check_module_name s =
+  let err c =
+    output_string stderr "Invalid module name: ";
+    output_string stderr s;
+    output_string stderr " character ";
+    if c = '\'' then
+      output_string stderr "\"'\""
+    else
+      (output_string stderr"'"; output_char stderr c; output_string stderr"'");
+    output_string stderr " is not allowed in module names\n";
+    exit 1 
+  in
+  match String.get s 0 with 
+    | 'a' .. 'z' | 'A' .. 'Z' -> 
+	for i = 1 to (String.length s)-1 do
+	  match String.get s i with 
+	    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_'  -> ()
+	    | c -> err c
+	done
+    | c -> err c
+
+let rec make_compilation_args = function
+  | [] -> []
+  | file :: fl -> 
+      let dirname = Filename.dirname file in
+      let basename = Filename.basename file in
+      let modulename =
+        if Filename.check_suffix basename ".v" then
+          Filename.chop_suffix basename ".v"
+        else
+          basename
+      in
+      check_module_name modulename;
+      let file = Filename.concat dirname modulename in
+      (if !verbose then "-compile-verbose" else "-compile")
+      :: file :: (make_compilation_args fl)
+
+(* compilation of files [files] with command [command] and args [args] *)
+
+let compile command args files =
+  let args' = command :: args @ (make_compilation_args files) in
+  match Sys.os_type with
+  | "Win32" -> 
+     let pid = 
+        Unix.create_process_env command (Array.of_list args') environment
+        Unix.stdin Unix.stdout Unix.stderr 
+     in
+     ignore (Unix.waitpid [] pid)
+  | _ ->
+     Unix.execvpe command (Array.of_list args') environment 
+
+(* parsing of the command line
+ *
+ * special treatment for -bindir and -i.
+ * other options are passed to coqtop *)
+
+let usage () =
+  Usage.print_usage_coqc () ;
+  flush stderr ;
+  exit 1
+
+let parse_args () =
+  let rec parse (cfiles,args) = function
+    | [] -> 
+	List.rev cfiles, List.rev args
+    | "-i" :: rem -> 
+	specification := true ; parse (cfiles,args) rem
+    | "-t" :: rem -> 
+	keep := true ; parse (cfiles,args) rem
+    | ("-verbose" | "--verbose") :: rem -> 
+	verbose := true ; parse (cfiles,args) rem
+    | "-boot" :: rem ->
+	bindir:= Filename.concat Coq_config.coqtop "bin";
+	parse (cfiles, "-boot"::args) rem
+    | "-bindir" :: d :: rem ->
+	bindir := d ; parse (cfiles,args) rem
+    | "-bindir" :: []       ->
+	usage ()
+    | "-byte" :: rem ->
+	binary := "coqtop.byte"; parse (cfiles,args) rem
+    | "-opt" :: rem ->
+	binary := "coqtop.opt"; parse (cfiles,args) rem
+    | "-image" :: f :: rem ->
+	image := f; parse (cfiles,args) rem
+    | "-image" :: [] ->
+	usage ()
+    | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
+    | ("-libdir"|"-I"|"-include"|"-outputstate"
+      |"-inputstate"|"-is"|"-load-vernac-source"|"-l"|"-load-vernac-object"
+      |"-load-ml-source"|"-require"|"-load-ml-object"|"-user"
+      |"-init-file"|"-dump-glob" as o) :: rem ->
+	begin
+	  match rem with
+	    | s :: rem' -> parse (cfiles,s::o::args) rem'
+	    | []        -> usage ()
+	end
+    | "-R" as o :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem
+    | ("-notactics"|"-debug"|"-db"|"-debugger"|"-nolib"|"-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 ->
+	parse (cfiles,o::args) rem
+    | ("-v"|"--version") :: _ ->
+        Usage.version ()
+    | "-where" :: _ -> 
+	print_endline Coq_config.coqlib; exit 0
+    | f :: rem -> 
+	if Sys.file_exists f then
+	  parse (f::cfiles,args) rem
+	else 
+	  let fv = f ^ ".v" in
+	  if Sys.file_exists fv then
+	    parse (fv::cfiles,args) rem
+	  else begin
+	    prerr_endline ("coqc: "^f^": no such file or directory") ;
+	    exit 1
+	  end
+  in
+  parse ([],[]) (List.tl (Array.to_list Sys.argv))
+
+(* main: we parse the command line, define the command to compile files
+ * and then call the compilation on each file *)
+
+let main () =
+  let cfiles, args = parse_args () in
+  if cfiles = [] then begin
+    prerr_endline "coqc: too few arguments" ;
+    usage ()
+  end;
+  let coqtopname = 
+    if !image <> "" then !image else Filename.concat !bindir (!binary ^ Coq_config.exec_extension)
+  in
+(*  List.iter (compile coqtopname args) cfiles*)
+  Unix.handle_unix_error (compile coqtopname args) cfiles
+    
+let _ = Printexc.print main (); exit 0
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
new file mode 100644
index 00000000..78306877
--- /dev/null
+++ b/scripts/coqmktop.ml
@@ -0,0 +1,357 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqmktop.ml,v 1.28.2.1 2004/07/16 19:30:50 herbelin Exp $ *)
+
+(* coqmktop is a script to link Coq, analogous to ocamlmktop.
+   The command line contains options specific to coqmktop, options for the
+   Ocaml linker and files to link (in addition to the default Coq files). *)
+
+open Unix
+
+(* Objects to link *)
+
+(* 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 spaces = Str.regexp "[ \t\n]+"
+let split_cmo 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 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
+
+let gramobjs = []
+let notopobjs = gramobjs
+
+(* 5. High-level tactics objects *)
+let hightactics = 
+ (split_cmo Tolink.hightactics) @ (split_cmo Tolink.contrib) 
+
+(* environment *)
+let src_coqtop = ref Coq_config.coqtop
+let opt        = ref false
+let full       = ref false
+let top        = ref false
+let searchisos = ref false
+let coqide     = ref false
+let echo       = ref false
+
+let src_dirs () = 
+  [ []; [ "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] @ 
+     (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
+
+(* Transform bytecode object file names in native object file names *)
+let native_suffix f =
+  if Filename.check_suffix f ".cmo" then 
+    (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")
+
+(* Transforms a file name in the corresponding Caml module name. *)
+let rem_ext_regexpr = Str.regexp "\\(.*\\)\\.\\(cm..?\\|ml\\)"
+
+let module_of_file name =
+  let s = Str.replace_first rem_ext_regexpr "\\1" (Filename.basename name) in
+  String.capitalize s
+
+(* 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 
+    "str.cma"::"threads.cma"::"lablgtk.cma"::"gtkThread.cmo"::ide 
+  else [] 
+  in
+  let ide_libs = if !coqide then 
+    ["str.cma" ; "threads.cma" ; "lablgtk.cma" ; "gtkThread.cmo" ;
+     "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 objstolink,libstolink =
+    if !opt then 
+      ((List.map native_suffix objs) @ userfiles,
+       (List.map native_suffix libs) @ userfiles)
+    else 
+      (objs @ userfiles ,libs @ userfiles )
+  in
+  let modules = List.map module_of_file objstolink in
+  (modules, libstolink)
+
+(* Gives the list of all the directories under [dir].
+   Uses [Unix] (it is hard to do without it). *)
+let all_subdirs dir =
+  let l = ref [dir] in
+  let add f = l := f :: !l in
+  let rec traverse dir =
+    let dirh = 
+      try opendir dir with Unix_error _ -> invalid_arg "all_subdirs" 
+    in
+    try
+      while true do
+	let f = readdir dirh in
+	if f <> "." && f <> ".." then
+	  let file = Filename.concat dir f in
+	  if (stat file).st_kind = S_DIR then begin
+	    add file;
+	    traverse file
+	  end
+      done
+    with End_of_file ->
+      closedir dirh
+  in
+  traverse dir; List.rev !l
+
+(* usage *)
+let usage () =
+  prerr_endline "Usage: coqmktop <options> <ocaml options> files
+Options are:
+  -srcdir dir   Specify where the Coq source files are
+  -o exec-file  Specify the name of the resulting toplevel
+  -opt          Compile in native code
+  -full         Link high level tactics
+  -top          Build Coq on a ocaml toplevel (incompatible with -opt)
+  -searchisos   Build a toplevel for SearchIsos
+  -ide          Build a toplevel for the Coq IDE
+  -R dir        Specify recursively directories for Ocaml
+  -v8           Link with V8 grammar\n";
+  exit 1
+
+(* parsing of the command line *)
+let parse_args () =
+  let rec parse (op,fl) = function
+    | [] -> List.rev op, List.rev fl
+    | "-srcdir" :: d :: rem -> src_coqtop := d ; parse (op,fl) rem
+    | "-srcdir" :: _        -> usage ()
+    | "-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
+    | "-echo" :: rem -> echo := true ; parse (op,fl) rem
+    | ("-cclib"|"-ccopt"|"-I"|"-o" as o) :: rem' ->
+	begin
+	  match rem' with
+	    | a :: rem -> parse (a::o::op,fl) rem
+	    | []       -> usage ()
+	end
+    | "-R" :: a :: rem ->
+        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
+    | ("-h"|"--help") :: _ -> usage ()
+    | f :: rem ->
+	if Filename.check_suffix f ".ml" 
+	  or Filename.check_suffix f ".cmx" 
+	  or Filename.check_suffix f ".cmo"
+	  or Filename.check_suffix f ".cmxa"
+	  or Filename.check_suffix f ".cma" then
+	    parse (op,f::fl) rem
+	else begin
+	  prerr_endline ("Don't know what to do with " ^ f);
+	  exit 1
+	end
+  in
+  parse ([Coq_config.osdeplibs],[]) (List.tl (Array.to_list Sys.argv))
+
+let clean file =
+  let rm f = if Sys.file_exists f then Sys.remove f in
+  let basename = Filename.chop_suffix file ".ml" in
+  if not !echo then begin
+    rm file;
+    rm (basename ^ ".o");
+    rm (basename ^ ".cmi");
+    rm (basename ^ ".cmo");
+    rm (basename ^ ".cmx")
+  end
+
+(* Gives all modules in [dir]. Uses [.cmi] suffixes. Uses [Unix]. *)
+let all_modules_in_dir dir =
+  try
+    let lst = ref []
+    and stg = ref ""
+    and dh = Unix.opendir dir in
+    try
+      while true do
+	let stg = Unix.readdir dh in
+        if (Filename.check_suffix stg ".cmi") then
+          lst := !lst @ [String.capitalize (Filename.chop_suffix stg ".cmi")]
+      done;
+      []
+    with End_of_file -> 
+      Unix.closedir dh; !lst
+  with Unix.Unix_error (_,"opendir",_) ->
+    failwith ("all_modules_in_dir: directory "^dir^" not found")
+
+(* Gives a part of command line (corresponding to dir) for [extract_crc] *)
+let crc_cmd dir =
+  " -I "^dir^(List.fold_right (fun x y -> " "^x^y) (all_modules_in_dir dir)
+  "")
+
+(* Same as [crc_cmd] but recursively *)
+let rec_crc_cmd dir =
+  List.fold_right (fun x y -> x^y) (List.map crc_cmd (all_subdirs dir)) ""
+
+(* Creates another temporary file for Dynlink if needed *)
+let tmp_dynlink()=
+  let tmp = Filename.temp_file "coqdynlink" ".ml" in
+  let _ = Sys.command ("echo \"Dynlink.init();;\" > "^tmp) in
+  let _ = Sys.command (Coq_config.camllib^"/extract_crc"^(crc_cmd
+      Coq_config.camllib)^(crc_cmd Coq_config.camlp4lib)^(rec_crc_cmd
+      Coq_config.coqtop)^" >> "^tmp) in
+  let _ = Sys.command ("echo \";;\" >> "^tmp) in
+  let _ = 
+    Sys.command ("echo \"Dynlink.add_available_units crc_unit_list;;\" >> "^
+		 tmp)
+  in
+  tmp
+
+(* Initializes the kind of loading in the main program *)
+let declare_loading_string () =
+  if !opt then
+    "Mltop.set Mltop.Native;;\n"
+  else if not !top then
+    "Mltop.set Mltop.WithoutTop;;\n"
+  else
+    "let ppf = Format.std_formatter;;
+     Mltop.set (Mltop.WithTop
+       {Mltop.load_obj=Topdirs.dir_load ppf;
+        Mltop.use_file=Topdirs.dir_use ppf;
+        Mltop.add_dir=Topdirs.dir_directory;
+        Mltop.ml_loop=(fun () -> Toploop.loop ppf) });;\n"
+
+(* create a temporary main file to link *)
+let create_tmp_main_file modules =
+  let main_name = Filename.temp_file "coqmain" ".ml" in
+  let oc = open_out main_name in
+  try
+    (* Add the pre-linked modules *)    
+    output_string oc "List.iter Mltop.add_known_module [\"";
+    output_string oc (String.concat "\";\"" modules);
+    output_string oc "\"];;\n";
+    (* Initializes the kind of loading *)
+    output_string oc (declare_loading_string());
+    (* Start the right toplevel loop: Coq or Coq_searchisos *)
+    if !searchisos then 
+      output_string oc "Cmd_searchisos_line.start();;\n"
+    else if !coqide then
+      output_string oc "Coqide.start();;\n"
+    else
+      output_string oc "Coqtop.start();;\n";
+    close_out oc;
+    main_name
+  with e -> 
+    clean main_name; raise e
+
+(* main part *)
+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
+      (* 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)
+  in
+  (* files to link *)
+  let (modules, tolink) = files_to_link userfiles in
+  (*file for dynlink *)
+  let dynlink=
+    if not (!opt || !top) then
+      [tmp_dynlink()]
+    else
+      []
+  in
+  (* 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
+    (* 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
+    if !echo then 
+      begin 
+	print_endline command; 
+	print_endline 
+	  ("(command length is " ^ 
+	   (string_of_int (String.length command)) ^ " characters)");
+	flush Pervasives.stdout 
+      end;
+    let retcode = Sys.command command in
+    clean main_file;
+    (* command gives the exit code in HSB, and signal in LSB !!! *)
+    if retcode > 255 then retcode lsr 8 else retcode 
+  with e -> 
+    clean main_file; raise e
+
+let retcode =
+  try Printexc.print main () with _ -> 1
+
+let _ = exit retcode
diff --git a/states/MakeInitial.v b/states/MakeInitial.v
new file mode 100644
index 00000000..64c540fa
--- /dev/null
+++ b/states/MakeInitial.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Prelude.
+Require Export Logic_Type.
diff --git a/states/MakeInitialNew.v b/states/MakeInitialNew.v
new file mode 100644
index 00000000..64c540fa
--- /dev/null
+++ b/states/MakeInitialNew.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Prelude.
+Require Export Logic_Type.
diff --git a/states7/MakeInitial.v b/states7/MakeInitial.v
new file mode 100644
index 00000000..64c540fa
--- /dev/null
+++ b/states7/MakeInitial.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Prelude.
+Require Export Logic_Type.
diff --git a/syntax/MakeBare.v b/syntax/MakeBare.v
new file mode 100644
index 00000000..28d9b5ea
--- /dev/null
+++ b/syntax/MakeBare.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d0f75dcf
--- /dev/null
+++ b/syntax/PPCases.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..a4374c86
--- /dev/null
+++ b/syntax/PPConstr.v
@@ -0,0 +1,264 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d087420a
--- /dev/null
+++ b/tactics/auto.ml
@@ -0,0 +1,939 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: auto.ml,v 1.63.2.1 2004/07/16 19:30:51 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Inductive
+open Evd
+open Reduction
+open Typing
+open Pattern
+open Matching
+open Tacmach
+open Proof_type
+open Pfedit
+open Rawterm
+open Evar_refiner
+open Tacred
+open Tactics
+open Tacticals
+open Clenv
+open Hiddentac
+open Libnames
+open Nametab
+open Libobject
+open Library
+open Printer
+open Declarations
+open Tacexpr
+
+(****************************************************************************)
+(*            The Type of Constructions Autotactic Hints                    *)
+(****************************************************************************)
+
+type auto_tactic = 
+  | Res_pf     of constr * unit clausenv (* Hint Apply *)
+  | ERes_pf    of constr * unit clausenv (* Hint EApply *)
+  | Give_exact of constr                  
+  | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *)
+  | Unfold_nth of global_reference       (* Hint Unfold *)
+  | Extern     of glob_tactic_expr       (* Hint Extern *) 
+
+type pri_auto_tactic = { 
+  hname : identifier;    (* name of the hint *)
+  pri  : int;            (* A number between 0 and 4, 4 = lower priority *)
+  pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
+  code : auto_tactic     (* the tactic to apply when the concl matches pat *)
+}
+
+let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2
+
+let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2
+
+let insert v l = 
+  let rec insrec = function
+    | [] -> [v]
+    | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl)
+  in 
+  insrec l
+
+(* Nov 98 -- Papageno *)
+(* Les Hints sont ré-organisés en plusieurs databases. 
+
+  La table impérative "searchtable", de type "hint_db_table",
+   associe une database (hint_db) à chaque nom.
+
+  Une hint_db est une table d'association fonctionelle constr -> search_entry
+  Le constr correspond à la constante de tête de la conclusion.
+
+  Une search_entry est un triplet comprenant :
+     - la liste des tactiques qui n'ont pas de pattern associé
+     - la liste des tactiques qui ont un pattern
+     - un discrimination net borné (Btermdn.t) constitué de tous les
+       patterns de la seconde liste de tactiques *)
+
+type stored_data = pri_auto_tactic
+
+type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+
+let empty_se = ([],[],Btermdn.create ())
+
+let add_tac t (l,l',dn) =
+  match t.pat with
+      None -> (insert t l, l', dn)
+    | Some pat -> (l, insert t l', Btermdn.add dn (pat,t))
+
+
+let lookup_tacs (hdc,c) (l,l',dn) =
+  let l'  = List.map snd (Btermdn.lookup dn c) in
+  let sl' = Sort.list pri_order l' in
+    Sort.merge pri_order l sl'
+
+
+module Constr_map = Map.Make(struct 
+			       type t = constr_label
+			       let compare = Pervasives.compare 
+			     end)
+
+module Hint_db = struct
+
+  type t = search_entry Constr_map.t
+
+  let empty = Constr_map.empty
+
+  let find key db =
+    try Constr_map.find key db
+    with Not_found -> empty_se
+
+  let map_all k db =
+    let (l,l',_) = find k db in
+      Sort.merge pri_order l l'
+   
+  let map_auto (k,c) db =
+    lookup_tacs (k,c) (find k db)
+
+  let add_one (k,v) db =
+    let oval = find k db in 
+      Constr_map.add k (add_tac v oval) db
+
+  let add_list l db = List.fold_right add_one l db
+
+  let iter f db = Constr_map.iter (fun k (l,l',_) -> f k (l@l')) db
+
+end
+
+type frozen_hint_db_table = Hint_db.t Stringmap.t 
+
+type hint_db_table = Hint_db.t Stringmap.t ref
+
+type hint_db_name = string
+
+let searchtable = (ref Stringmap.empty : hint_db_table)
+
+let searchtable_map name = 
+  Stringmap.find name !searchtable
+let searchtable_add (name,db) = 
+  searchtable := Stringmap.add name db !searchtable
+
+(**************************************************************************)
+(*                       Definition of the summary                        *)
+(**************************************************************************)
+
+let init     () = searchtable := Stringmap.empty
+let freeze   () = !searchtable
+let unfreeze fs = searchtable := fs
+
+let _ = Summary.declare_summary "search"
+	  { Summary.freeze_function   = freeze;
+	    Summary.unfreeze_function = unfreeze;
+	    Summary.init_function     = init;
+	    Summary.survive_module = false;
+	    Summary.survive_section   = false }
+
+ 
+(**************************************************************************)
+(*             Auxiliary functions to prepare AUTOHINT objects            *)
+(**************************************************************************)
+
+let rec nb_hyp c = match kind_of_term c with
+  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
+  | _ -> 0 
+
+(* adding and removing tactics in the search table *)
+
+let try_head_pattern c = 
+  try head_pattern_bound c
+  with BoundPattern -> error "Bound head variable"
+
+let make_exact_entry name (c,cty) =
+  let cty = strip_outer_cast cty in
+  match kind_of_term cty with
+    | Prod (_,_,_) -> 
+	failwith "make_exact_entry"
+    | _ ->
+	(head_of_constr_reference (List.hd (head_constr cty)),
+	   { hname=name; pri=0; pat=None; code=Give_exact c })
+
+let make_apply_entry env sigma (eapply,verbose) name (c,cty) =
+  let cty = hnf_constr env sigma cty in
+  match kind_of_term cty with
+    | Prod _ ->
+        let ce = mk_clenv_from () (c,cty) in
+	let c' = (clenv_template_type ce).rebus in
+	let pat = Pattern.pattern_of_constr c' in
+        let hd = (try head_pattern_bound pat
+                  with BoundPattern -> failwith "make_apply_entry") in
+        let nmiss = List.length (clenv_missing ce) 
+        in 
+	if eapply & (nmiss <> 0) then begin
+          if verbose then 
+	    warn (str "the hint: EApply " ++ prterm c ++
+		    str " will only be used by EAuto"); 
+          (hd,
+           { hname = name;
+	     pri = nb_hyp cty + nmiss;
+             pat = Some pat;
+             code = ERes_pf(c,ce) })
+        end else 
+	  (hd,
+           { hname = name;
+	     pri = nb_hyp cty;
+             pat = Some pat;
+             code = Res_pf(c,ce) })
+    | _ -> failwith "make_apply_entry"
+ 
+(* eap is (e,v) with e=true if eapply and v=true if verbose 
+   c is a constr
+   cty is the type of constr *)
+
+let make_resolves env sigma name eap (c,cty) =
+  let ents = 
+    map_succeed 
+      (fun f -> f name (c,cty)) 
+      [make_exact_entry; make_apply_entry env sigma eap]
+  in 
+  if ents = [] then 
+    errorlabstrm "Hint" (prterm c ++ spc () ++ str "cannot be used as a hint");
+  ents
+
+(* used to add an hypothesis to the local hint database *)
+let make_resolve_hyp env sigma (hname,_,htyp) = 
+  try
+    [make_apply_entry env sigma (true, false) hname
+       (mkVar hname,  htyp)]
+  with 
+    | Failure _ -> []
+    | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
+
+(* REM : in most cases hintname = id *)
+let make_unfold (hintname, ref) =
+  (Pattern.label_of_ref ref,
+   { hname = hintname;
+     pri = 4;
+     pat = None;
+     code = Unfold_nth ref })
+
+let make_extern name pri pat tacast = 
+  let hdconstr = try_head_pattern pat in 
+  (hdconstr,
+   { hname = name;
+     pri=pri;
+     pat = Some pat;
+     code= Extern tacast })
+
+let make_trivial env sigma (name,c) =
+  let t = hnf_constr env sigma (type_of env sigma c) in
+  let hd = head_of_constr_reference (List.hd (head_constr t)) in
+  let ce = mk_clenv_from () (c,t) in
+  (hd, { hname = name;
+	       pri=1;
+               pat = Some (Pattern.pattern_of_constr (clenv_template_type ce).rebus);
+               code=Res_pf_THEN_trivial_fail(c,ce) })
+
+open Vernacexpr
+
+(**************************************************************************)
+(*               declaration of the AUTOHINT library object               *)
+(**************************************************************************)
+
+(* If the database does not exist, it is created *)
+(* TODO: should a warning be printed in this case ?? *)
+let add_hint dbname hintlist = 
+  try 
+    let db = searchtable_map dbname in
+    let db' = Hint_db.add_list hintlist db in
+    searchtable_add (dbname,db')
+  with Not_found -> 
+    let db = Hint_db.add_list hintlist Hint_db.empty in
+    searchtable_add (dbname,db)
+
+let cache_autohint (_,(local,name,hintlist)) = add_hint name hintlist
+
+(*  let recalc_hints hintlist =
+    let env = Global.env() and sigma = Evd.empty in
+    let recalc_hint ((_,data) as hint) =
+      match data.code with
+	| Res_pf (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_apply_entry env sigma (false,false) 
+		  data.hname (c', type_of env sigma c')
+	| ERes_pf (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_apply_entry env sigma (true,false) 
+		  data.hname (c', type_of env sigma c')
+	| Give_exact c ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_exact_entry data.hname (c',type_of env sigma c')
+	| Res_pf_THEN_trivial_fail (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_trivial env sigma (data.hname,c')
+	| Unfold_nth ref -> 
+	    let ref' = subst_global subst ref in
+	      if ref==ref' then hint else
+		make_unfold (data.hname,ref')
+	| Extern _ ->
+	    anomaly "Extern hints cannot be substituted!!!"
+    in
+      list_smartmap recalc_hint hintlist
+*)
+
+let forward_subst_tactic = 
+  ref (fun _ -> failwith "subst_tactic is not installed for Auto")
+
+let set_extern_subst_tactic f = forward_subst_tactic := f
+
+let subst_autohint (_,subst,(local,name,hintlist as obj)) = 
+  let trans_clenv clenv = Clenv.subst_clenv (fun _ a -> a) subst clenv in
+  let trans_data data code = 	      
+    { data with
+	pat = option_smartmap (subst_pattern subst) data.pat ;
+	code = code ;
+    }
+  in
+  let subst_hint (lab,data as hint) =
+    let lab' = subst_label subst lab in
+    let data' = match data.code with
+      | Res_pf (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (Res_pf (c', trans_clenv clenv))
+      | ERes_pf (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (ERes_pf (c', trans_clenv clenv))
+      | Give_exact c ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (Give_exact c')
+      | Res_pf_THEN_trivial_fail (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in
+		trans_data data code'
+      | Unfold_nth ref -> 
+	  let ref' = subst_global subst ref in
+	    if ref==ref' then data else
+	      trans_data data (Unfold_nth ref')
+      | Extern tac ->
+	  let tac' = !forward_subst_tactic subst tac in
+	    if tac==tac' then data else
+	      trans_data data (Extern tac')
+    in
+      if lab' == lab && data' == data then hint else
+	(lab',data')
+  in
+  let hintlist' = list_smartmap subst_hint hintlist in
+    if hintlist' == hintlist then obj else
+      (local,name,hintlist')
+
+let classify_autohint (_,((local,name,hintlist) as obj)) =
+  if local or hintlist = [] then Dispose else Substitute obj
+
+let export_autohint ((local,name,hintlist) as obj) =
+  if local then None else Some obj
+
+let (inAutoHint,outAutoHint) =
+  declare_object {(default_object "AUTOHINT") with
+                    cache_function = cache_autohint;
+		    load_function = (fun _ -> cache_autohint);
+		    subst_function = subst_autohint;
+		    classify_function = classify_autohint;
+                    export_function = export_autohint }
+
+
+(**************************************************************************)
+(*                     The "Hint" vernacular command                      *)
+(**************************************************************************)
+let add_resolves env sigma clist local dbnames =
+  List.iter 
+    (fun dbname ->
+       Lib.add_anonymous_leaf
+	 (inAutoHint
+	    (local,dbname,
+     	     List.flatten
+	       (List.map
+		  (fun (name,c) -> 
+		     let ty = type_of env sigma c in
+		     let verbose = Options.is_verbose() in
+		       make_resolves env sigma name (true,verbose) (c,ty)) clist
+	       )
+	    )))
+    dbnames
+
+
+let add_unfolds l local dbnames =
+  List.iter 
+    (fun dbname -> Lib.add_anonymous_leaf 
+       (inAutoHint (local,dbname, List.map make_unfold l)))
+    dbnames
+
+
+let add_extern name pri (patmetas,pat) tacast local dbname =
+  (* We check that all metas that appear in tacast have at least
+     one occurence in the left pattern pat *)
+(* TODO
+  let tacmetas = Coqast.collect_metas tacast in
+*)
+  let tacmetas = [] in
+  match (list_subtract tacmetas patmetas) with
+    | i::_ ->
+	errorlabstrm "add_extern" 
+	  (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound")
+    | []  ->
+	Lib.add_anonymous_leaf
+	  (inAutoHint(local,dbname, [make_extern name pri pat tacast]))
+
+let add_externs name pri pat tacast local dbnames = 
+  List.iter (add_extern name pri pat tacast local) dbnames
+
+let add_trivials env sigma l local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf (
+	 inAutoHint(local,dbname, List.map (make_trivial env sigma) l)))
+    dbnames
+
+let forward_intern_tac = 
+  ref (fun _ -> failwith "intern_tac is not installed for Auto")
+
+let set_extern_intern_tac f = forward_intern_tac := f
+
+let add_hints local dbnames0 h =
+  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
+  match h with
+  | HintsResolve lhints ->	
+      let env = Global.env() and sigma = Evd.empty in
+      let f (n,c) =
+	let c = Constrintern.interp_constr sigma env c in
+	let n = match n with
+	  | None -> (*id_of_global (reference_of_constr c)*)
+              id_of_string "<anonymous hint>"
+	  | Some n -> n in
+	(n,c) in
+      add_resolves env sigma (List.map f lhints) local dbnames
+  | HintsImmediate lhints ->
+      let env = Global.env() and sigma = Evd.empty in
+      let f (n,c) = 
+	let c = Constrintern.interp_constr sigma env c in
+	let n = match n with
+	  | None -> (*id_of_global (reference_of_constr c)*)
+              id_of_string "<anonymous hint>"
+	  | Some n -> n in
+	(n,c) in
+      add_trivials env sigma (List.map f lhints) local dbnames
+  | HintsUnfold lhints ->
+      let f (n,locqid) =
+	let r = Nametab.global locqid in
+	let n = match n with
+	  | None -> id_of_global r
+	  | Some n -> n in
+	(n,r) in
+      add_unfolds (List.map f lhints) local dbnames
+  | HintsConstructors (hintname, lqid) ->
+      let add_one qid =
+        let env = Global.env() and sigma = Evd.empty in
+        let isp = global_inductive qid in
+        let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in
+        let lcons = list_tabulate
+          (fun i -> mkConstruct (isp,i+1)) (Array.length consnames) in
+        let lcons = List.map2
+          (fun id c -> (id,c)) (Array.to_list consnames) lcons in
+        add_resolves env sigma lcons local dbnames in
+      List.iter add_one lqid
+  | HintsExtern (hintname, pri, patcom, tacexp) ->
+      let hintname = match hintname with
+          Some h -> h
+        | _ -> id_of_string "<anonymous hint>" in
+      let pat =	Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in
+      let tacexp = !forward_intern_tac (fst pat) tacexp in
+      add_externs hintname pri pat tacexp local dbnames
+  | HintsDestruct(na,pri,loc,pat,code) ->
+      if dbnames0<>[] then
+        warn (str"Database selection not implemented for destruct hints");
+      Dhyp.add_destructor_hint local na loc pat pri code
+
+(**************************************************************************)
+(*                    Functions for printing the hints                    *)
+(**************************************************************************)
+
+let fmt_autotactic = function
+  | Res_pf (c,clenv) -> (str"Apply " ++ prterm c)
+  | ERes_pf (c,clenv) -> (str"EApply " ++ prterm c)
+  | Give_exact c -> (str"Exact " ++ prterm c)
+  | Res_pf_THEN_trivial_fail (c,clenv) -> 
+      (str"Apply " ++ prterm c ++ str" ; Trivial")
+  | Unfold_nth c -> (str"Unfold " ++  pr_global c)
+  | Extern tac -> (str "Extern " ++ Pptactic.pr_glob_tactic tac)
+
+let fmt_hint v =
+  (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
+
+let fmt_hint_list hintlist =
+  (str "  " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ())
+
+let fmt_hints_db (name,db,hintlist) =
+  (str "In the database " ++ str name ++ str ":" ++
+     if hintlist = [] then (str " nothing" ++ fnl ())
+     else (fnl () ++ fmt_hint_list hintlist))
+
+(* Print all hints associated to head c in any database *)
+let fmt_hint_list_for_head c = 
+  let dbs = stringmap_to_list !searchtable in
+  let valid_dbs = 
+    map_succeed 
+      (fun (name,db) -> (name,db,Hint_db.map_all c db)) 
+      dbs 
+  in
+  if valid_dbs = [] then 
+    (str "No hint declared for :" ++ pr_ref_label c)
+  else 
+    hov 0 
+      (str"For " ++ pr_ref_label c ++ str" -> " ++ fnl () ++
+	 hov 0 (prlist fmt_hints_db valid_dbs))
+
+let fmt_hint_ref ref = fmt_hint_list_for_head (label_of_ref ref)
+
+(* Print all hints associated to head id in any database *)
+let print_hint_ref ref =  ppnl(fmt_hint_ref ref)
+
+let fmt_hint_term cl = 
+  try 
+    let (hdc,args) = match head_constr_bound cl [] with 
+      | hdc::args -> (hdc,args)
+      | [] -> assert false 
+    in
+    let hd = head_of_constr_reference hdc in
+    let dbs = stringmap_to_list !searchtable in
+    let valid_dbs = 
+      if occur_existential cl then 
+	map_succeed 
+	  (fun (name, db) -> (name, db, Hint_db.map_all hd db)) 
+	  dbs
+      else 
+	map_succeed 
+	  (fun (name, db) -> 
+	     (name, db, Hint_db.map_auto (hd,applist(hdc,args)) db)) 
+	  dbs
+    in 
+    if valid_dbs = [] then 
+      (str "No hint applicable for current goal")
+    else
+      (str "Applicable Hints :" ++ fnl () ++
+	 hov 0 (prlist fmt_hints_db valid_dbs))
+  with Bound | Match_failure _ | Failure _ -> 
+    (str "No hint applicable for current goal")
+	  
+let print_hint_term cl = ppnl (fmt_hint_term cl)
+
+(* print all hints that apply to the concl of the current goal *)
+let print_applicable_hint () = 
+  let pts = get_pftreestate () in 
+  let gl = nth_goal_of_pftreestate 1 pts in 
+  print_hint_term (pf_concl gl)
+    
+(* displays the whole hint database db *)
+let print_hint_db db =
+  Hint_db.iter 
+    (fun head hintlist ->
+       msg (hov 0 
+	      (str "For " ++ pr_ref_label head ++ str " -> " ++
+		 fmt_hint_list hintlist)))
+    db
+
+let print_hint_db_by_name dbname =
+  try 
+    let db = searchtable_map dbname in print_hint_db db
+  with Not_found -> 
+    error (dbname^" : No such Hint database")
+  
+(* displays all the hints of all databases *)
+let print_searchtable () =
+  Stringmap.iter
+    (fun name db ->
+       msg (str "In the database " ++ str name ++ fnl ());
+       print_hint_db db)
+    !searchtable
+
+(**************************************************************************)
+(*                           Automatic tactics                            *)
+(**************************************************************************)
+
+(**************************************************************************)
+(*          tactics with a trace mechanism for automatic search           *)
+(**************************************************************************)
+
+let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
+
+
+(* Try unification with the precompiled clause, then use registered Apply *)
+
+let unify_resolve (c,clenv) gls = 
+  let (wc,kONT) = startWalk gls in
+  let clenv' = connect_clenv wc clenv in
+  let _ = clenv_unique_resolver false clenv' gls in  
+  h_simplest_apply c gls
+
+(* builds a hint database from a constr signature *)
+(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
+
+let make_local_hint_db g = 
+  let sign = pf_hyps g in
+  let hintlist = list_map_append (make_resolve_hyp (pf_env g) (project g)) sign
+  in Hint_db.add_list hintlist Hint_db.empty
+
+
+(* Serait-ce possible de compiler d'abord la tactique puis de faire la
+   substitution sans passer par bdize dont l'objectif est de préparer un
+   terme pour l'affichage ? (HH) *)
+
+(* Si on enlève le dernier argument (gl) conclPattern est calculé une
+fois pour toutes : en particulier si Pattern.somatch produit une UserError 
+Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même
+si après Intros la conclusion matche le pattern.
+*)
+
+(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
+
+let forward_interp_tactic = 
+  ref (fun _ -> failwith "interp_tactic is not installed for Auto")
+
+let set_extern_interp f = forward_interp_tactic := f
+
+let conclPattern concl pat tac gl =
+  let constr_bindings =
+    try matches pat concl
+    with PatternMatchingFailure -> error "conclPattern" in
+  !forward_interp_tactic constr_bindings tac gl
+
+(**************************************************************************)
+(*                           The Trivial tactic                           *)
+(**************************************************************************)
+
+(* local_db is a Hint database containing the hypotheses of current goal *)
+(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
+  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
+
+let rec trivial_fail_db db_list local_db gl =
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g'->
+	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+  in
+  tclFIRST 
+    (assumption::intro_tac::
+     (List.map tclCOMPLETE 
+	(trivial_resolve db_list local_db (pf_concl gl)))) gl
+
+and my_find_search db_list local_db hdc concl =
+  let tacl = 
+    if occur_existential concl then 
+      list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
+    else 
+      list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
+      	(local_db::db_list)
+  in
+  List.map 
+    (fun ({pri=b; pat=p; code=t} as patac) -> 
+       (b,
+	match t with
+	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
+	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
+	  | Give_exact c  -> exact_check c
+	  | Res_pf_THEN_trivial_fail (term,cl) -> 
+	      tclTHEN 
+		(unify_resolve (term,cl)) 
+		(trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> unfold_constr c
+	  | Extern tacast -> 
+	      conclPattern concl (out_some p) tacast))
+    tacl
+
+and trivial_resolve db_list local_db cl = 
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    priority 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+let trivial dbnames gl =
+  let db_list = 
+    List.map
+      (fun x -> 
+	 try 
+	   searchtable_map x
+	 with Not_found -> 
+	   error ("Trivial: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl 
+    
+let full_trivial gl =
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames = list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl
+
+let gen_trivial = function
+  | None -> full_trivial
+  | Some l -> trivial l
+
+let h_trivial l = Refiner.abstract_tactic (TacTrivial l) (gen_trivial l)
+
+(**************************************************************************)
+(*                       The classical Auto tactic                        *)
+(**************************************************************************)
+
+let possible_resolve db_list local_db cl =
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    List.map snd 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+let decomp_unary_term c gls = 
+  let typc = pf_type_of gls c in 
+  let hd = List.hd (head_constr typc) in 
+  if Hipattern.is_conjunction hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") 
+
+let decomp_empty_term c gls = 
+  let typc = pf_type_of gls c in 
+  let (hd,_) = decompose_app typc in 
+  if Hipattern.is_empty_type hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") 
+
+
+(* decomp is an natural number giving an indication on decomposition 
+   of conjunction in hypotheses, 0 corresponds to no decomposition *)
+(* n is the max depth of search *)
+(* local_db contains the local Hypotheses *)
+
+let rec search_gen decomp n db_list local_db extra_sign goal =
+  if n=0 then error "BOUND 2";
+  let decomp_tacs = match decomp with 
+    | 0 -> [] 
+    | p -> 
+	(tclTRY_sign decomp_empty_term extra_sign)
+	::
+	(List.map 
+	   (fun id -> tclTHENSEQ
+               [decomp_unary_term (mkVar id);
+                clear [id];
+		search_gen decomp p db_list local_db []])
+	   (pf_ids_of_hyps goal)) 
+  in
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g' -> 
+	 let (hid,_,htyp as d) = pf_last_hyp g' in
+	 let hintl = 
+	   try 
+	     [make_apply_entry (pf_env g') (project g')
+		(true,false) 
+		hid (mkVar hid, htyp)]
+	   with Failure _ -> [] 
+	 in
+         search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d] g') 
+  in
+  let rec_tacs = 
+    List.map 
+      (fun ntac -> 
+	 tclTHEN ntac
+	   (search_gen decomp (n-1) db_list local_db empty_named_context))
+      (possible_resolve db_list local_db (pf_concl goal))
+  in 
+  tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
+
+
+let search = search_gen 0
+
+let default_search_depth = ref 5
+			     
+let auto n dbnames gl = 
+  let db_list = 
+    List.map
+      (fun x -> 
+	 try 
+	   searchtable_map x
+	 with Not_found -> 
+	   error ("Auto: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  let hyps = pf_hyps gl in
+  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+
+let default_auto = auto !default_search_depth []
+
+let full_auto n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames = list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  let hyps = pf_hyps gl in
+  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+  
+let default_full_auto gl = full_auto !default_search_depth gl
+
+let gen_auto n dbnames =
+  let n = match n with None -> !default_search_depth | Some n -> n in
+  match dbnames with
+  | None -> full_auto n
+  | Some l -> auto n l
+
+let h_auto n l = Refiner.abstract_tactic (TacAuto (n,l)) (gen_auto n l)
+
+(**************************************************************************)
+(*                  The "destructing Auto" from Eduardo                   *)
+(**************************************************************************)
+
+(* Depth of search after decomposition of hypothesis, by default 
+   one look for an immediate solution *) 
+(* Papageno : de toute façon un paramète > 1 est traité comme 1 pour 
+   l'instant *)
+let default_search_decomp = ref 1
+
+let destruct_auto des_opt n gl = 
+  let hyps = pf_hyps gl in
+  search_gen des_opt n [searchtable_map "core"] 
+    (make_local_hint_db gl) hyps gl
+    
+let dautomatic des_opt n = tclTRY (destruct_auto des_opt n)
+
+let default_dauto = dautomatic !default_search_decomp !default_search_depth
+
+let dauto = function
+  | None, None     -> default_dauto
+  | Some n, None   -> dautomatic !default_search_decomp n
+  | Some n, Some p -> dautomatic p n
+  | None, Some p   -> dautomatic p !default_search_depth
+
+let h_dauto (n,p) = Refiner.abstract_tactic (TacDAuto (n,p)) (dauto (n,p))
+
+(***************************************)
+(*** A new formulation of Auto *********)
+(***************************************)
+
+type autoArguments =
+  | UsingTDB       
+  | Destructing   
+
+let keepAfter tac1 tac2 = 
+  (tclTHEN tac1 
+     (function g -> tac2 [pf_last_hyp g] g))
+
+let compileAutoArg contac = function
+  | Destructing -> 
+      (function g -> 
+         let ctx = pf_hyps g in  
+	 tclFIRST 
+           (List.map 
+              (fun (id,_,typ) -> 
+                let cl = snd (decompose_prod typ) in
+                 if Hipattern.is_conjunction cl
+		 then 
+		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] 
+                 else 
+		   tclFAIL 0 ((string_of_id id)^"is not a conjunction"))
+	     ctx) g)
+  | UsingTDB ->  
+      (tclTHEN  
+         (Tacticals.tryAllClauses 
+            (function 
+               | Some (id,_,_) -> Dhyp.h_destructHyp false id
+               | None          -> Dhyp.h_destructConcl))
+         contac)
+
+let compileAutoArgList contac = List.map (compileAutoArg contac)
+
+let rec super_search n db_list local_db argl goal =
+  if n = 0 then error "BOUND 2";
+  tclFIRST
+    (assumption
+     ::
+     (tclTHEN intro 
+        (fun g -> 
+	   let (hid,_,htyp) = pf_last_hyp g in
+	   let hintl =
+	     make_resolves (pf_env g) (project g)
+	       hid (true,false) (mkVar hid, htyp) in
+	   super_search n db_list (Hint_db.add_list hintl local_db)
+	     argl g))
+     ::
+     ((List.map 
+         (fun ntac -> 
+            tclTHEN ntac 
+              (super_search (n-1) db_list local_db argl))
+         (possible_resolve db_list local_db (pf_concl goal)))
+      @
+      (compileAutoArgList  
+         (super_search (n-1) db_list local_db argl) argl))) goal
+
+let search_superauto n to_add argl g = 
+  let sigma =
+    List.fold_right
+      (fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
+      to_add empty_named_context in
+  let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in
+  let db = Hint_db.add_list db0 (make_local_hint_db g) in
+  super_search n [Stringmap.find "core" !searchtable] db argl g
+
+let superauto n to_add argl  = 
+  tclTRY (tclCOMPLETE (search_superauto n to_add argl))
+
+let default_superauto g = superauto !default_search_depth [] [] g
+
+let interp_to_add gl locqid =
+  let r = Nametab.global locqid in
+  let id = id_of_global r in
+  (next_ident_away id (pf_ids_of_hyps gl), constr_of_reference r)
+
+let gen_superauto nopt l a b gl =
+  let n = match nopt with Some n -> n | None -> !default_search_depth in
+  let al = (if a then [Destructing] else [])@(if b then [UsingTDB] else []) in
+  superauto n (List.map (interp_to_add gl) l) al gl
+
+let h_superauto no l a b =
+  Refiner.abstract_tactic (TacSuperAuto (no,l,a,b)) (gen_superauto no l a b)
+
diff --git a/tactics/auto.mli b/tactics/auto.mli
new file mode 100644
index 00000000..ef6b85ea
--- /dev/null
+++ b/tactics/auto.mli
@@ -0,0 +1,197 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: auto.mli,v 1.22.2.1 2004/07/16 19:30:51 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Proof_type
+open Tacmach
+open Clenv
+open Pattern
+open Environ
+open Evd
+open Libnames
+open Vernacexpr
+(*i*)
+  
+type auto_tactic = 
+  | Res_pf     of constr * unit clausenv    (* Hint Apply *)
+  | ERes_pf    of constr * unit clausenv    (* Hint EApply *)
+  | Give_exact of constr                  
+  | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *)
+  | Unfold_nth of global_reference          (* Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr   (* Hint Extern *)
+
+open Rawterm
+
+type pri_auto_tactic = { 
+  hname : identifier;     (* name of the hint *)
+  pri   : int;            (* A number between 0 and 4, 4 = lower priority *)
+  pat   : constr_pattern option; (* A pattern for the concl of the Goal *)
+  code  : auto_tactic;    (* the tactic to apply when the concl matches pat *)
+}
+
+type stored_data = pri_auto_tactic 
+
+type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+
+module Hint_db :
+  sig
+    type t
+    val empty : t
+    val find : constr_label -> t -> search_entry
+    val map_all : constr_label -> t -> pri_auto_tactic list
+    val map_auto : constr_label * constr -> t -> pri_auto_tactic list
+    val add_one : constr_label * pri_auto_tactic -> t -> t
+    val add_list : (constr_label * pri_auto_tactic) list -> t -> t
+    val iter : (constr_label -> stored_data list -> unit) -> t -> unit
+  end
+
+type frozen_hint_db_table = Hint_db.t Stringmap.t
+
+type hint_db_table = Hint_db.t Stringmap.t ref
+
+type hint_db_name = string
+
+val add_hints : locality_flag -> hint_db_name list -> hints -> unit
+
+val print_searchtable : unit -> unit
+
+val print_applicable_hint : unit -> unit
+
+val print_hint_ref : global_reference -> unit
+
+val print_hint_db_by_name : hint_db_name -> unit
+
+val searchtable : hint_db_table
+
+(* [make_exact_entry hint_name (c, ctyp)]. 
+   [hint_name] is the name of then hint;
+   [c] is the term given as an exact proof to solve the goal;
+   [ctyp] is the type of [hc]. *)
+
+val make_exact_entry :
+  identifier -> constr * constr -> constr_label * pri_auto_tactic
+
+(* [make_apply_entry (eapply,verbose) name (c,cty)].
+   [eapply] is true if this hint will be used only with EApply;
+   [name] is the name of then hint;
+   [c] is the term given as an exact proof to solve the goal;
+   [cty] is the type of [hc]. *)
+
+val make_apply_entry :
+  env -> evar_map -> bool * bool -> identifier -> constr * constr
+      -> constr_label * pri_auto_tactic
+
+(* A constr which is Hint'ed will be:
+   (1) used as an Exact, if it does not start with a product
+   (2) used as an Apply, if its HNF starts with a product, and
+       has no missing arguments.
+   (3) used as an EApply, if its HNF starts with a product, and
+       has missing arguments. *)
+
+val make_resolves :
+  env -> evar_map -> identifier -> bool * bool -> constr * constr -> 
+    (constr_label * pri_auto_tactic) list
+
+(* [make_resolve_hyp hname htyp].
+   used to add an hypothesis to the local hint database;
+   Never raises an User_exception;
+   If the hyp cannot be used as a Hint, the empty list is returned. *)
+
+val make_resolve_hyp : 
+  env -> evar_map -> named_declaration ->
+      (constr_label * pri_auto_tactic) list
+
+(* [make_extern name pri pattern tactic_expr] *)
+
+val make_extern :
+  identifier -> int -> constr_pattern -> Tacexpr.glob_tactic_expr
+      -> constr_label * pri_auto_tactic
+
+val set_extern_interp :
+  (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
+
+val set_extern_intern_tac :
+  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr)
+  -> unit
+
+val set_extern_subst_tactic :
+  (Names.substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
+  -> unit
+
+(* Create a Hint database from the pairs (name, constr).
+   Useful to take the current goal hypotheses as hints *)
+
+val make_local_hint_db : goal sigma -> Hint_db.t
+
+val priority : (int * 'a) list -> 'a list
+
+val default_search_depth : int ref
+
+(* Try unification with the precompiled clause, then use registered Apply *)
+val unify_resolve : (constr * unit clausenv) -> tactic
+
+(* [ConclPattern concl pat tacast]:
+   if the term concl matches the pattern pat, (in sense of 
+   [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
+   right values to build a tactic *)
+
+val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tactic
+
+(* The Auto tactic *)
+
+val auto : int -> hint_db_name list -> tactic
+
+(* auto with default search depth and with the hint database "core" *)
+val default_auto : tactic
+
+(* auto with all hint databases except the "v62" compatibility database *)
+val full_auto : int -> tactic
+
+(* auto with default search depth and with all hint databases 
+   except the "v62" compatibility database *)
+val default_full_auto : tactic
+
+(* The generic form of auto (second arg [None] means all bases) *)
+val gen_auto : int option -> hint_db_name list option -> tactic
+
+(* The hidden version of auto *)
+val h_auto   : int option -> hint_db_name list option -> tactic
+
+(* Trivial *)
+val trivial : hint_db_name list -> tactic
+val gen_trivial : hint_db_name list option -> tactic
+val full_trivial : tactic
+val h_trivial : hint_db_name list option -> tactic
+
+val fmt_autotactic : auto_tactic -> Pp.std_ppcmds
+
+(*s The following is not yet up to date -- Papageno. *)
+
+(* DAuto *)
+val dauto : int option * int option -> tactic
+val default_search_decomp : int ref
+val default_dauto : tactic
+
+val h_dauto : int option * int option -> tactic
+(* SuperAuto *)
+
+type autoArguments =
+  | UsingTDB       
+  | Destructing   
+
+(*
+val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic
+*)
+
+val h_superauto : int option -> reference list -> bool -> bool -> tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
new file mode 100644
index 00000000..7c134b89
--- /dev/null
+++ b/tactics/autorewrite.ml
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Ast
+open Coqast
+open Equality
+open Hipattern
+open Names
+open Pp
+open Proof_type
+open Tacticals
+open Tacinterp
+open Tactics
+open Term
+open Util
+open Vernacinterp
+open Tacexpr
+
+(* Rewriting rules *)
+type rew_rule = constr * bool * tactic
+
+(* Summary and Object declaration *)
+let rewtab =
+  ref (Stringmap.empty : rew_rule list Stringmap.t)
+
+let _ = 
+  let init () = rewtab := Stringmap.empty in
+  let freeze () = !rewtab in
+  let unfreeze fs = rewtab := fs in
+  Summary.declare_summary "autorewrite"
+    { Summary.freeze_function   = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function     = init;
+      Summary.survive_module = false;
+      Summary.survive_section   = false }
+
+(* Rewriting rules before tactic interpretation *)
+type raw_rew_rule = constr * bool * raw_tactic_expr
+
+(* Applies all the rules of one base *)
+let one_base tac_main bas =
+  let lrul = 
+    try 
+      Stringmap.find bas !rewtab
+    with Not_found -> 
+      errorlabstrm "AutoRewrite" 
+        (str ("Rewriting base "^(bas)^" does not exist"))
+  in
+    tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
+      tclTHEN tac
+        (tclREPEAT_MAIN 
+	  (tclTHENSFIRSTn (general_rewrite dir csr) [|tac_main|] tc)))
+      tclIDTAC lrul))
+
+(* The AutoRewrite tactic *)
+let autorewrite tac_main lbas =
+  tclREPEAT_MAIN (tclPROGRESS
+    (List.fold_left (fun tac bas -> 
+       tclTHEN tac (one_base tac_main bas)) tclIDTAC lbas))
+
+(* Functions necessary to the library object declaration *)
+let cache_hintrewrite (_,(rbase,lrl)) =
+  let l = List.rev_map (fun (c,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrl in
+  let l = 
+    try 
+      List.rev_append l (Stringmap.find rbase !rewtab) 
+    with
+      | Not_found -> List.rev l
+  in
+    rewtab:=Stringmap.add rbase l !rewtab
+
+let export_hintrewrite x = Some x
+
+let subst_hintrewrite (_,subst,(rbase,list as node)) = 
+  let subst_first (cst,b,t as pair) = 
+    let cst' = Term.subst_mps subst cst in
+    let t' = Tacinterp.subst_tactic subst t in
+      if cst == cst' & t == t' then pair else
+	(cst',b,t)
+  in
+  let list' = list_smartmap subst_first list in
+    if list' == list then node else
+      (rbase,list')
+      
+let classify_hintrewrite (_,x) = Libobject.Substitute x
+
+
+(* Declaration of the Hint Rewrite library object *)
+let (in_hintrewrite,out_hintrewrite)=
+  Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
+       Libobject.open_function = (fun i o -> if i=1 then cache_hintrewrite o);
+       Libobject.cache_function = cache_hintrewrite;
+       Libobject.subst_function = subst_hintrewrite;
+       Libobject.classify_function = classify_hintrewrite;
+       Libobject.export_function = export_hintrewrite }
+
+(* To add rewriting rules to a base *)
+let add_rew_rules base lrul =
+  let lrul = List.rev_map (fun (c,b,t) -> (c,b,Tacinterp.glob_tactic t)) lrul in
+  Lib.add_anonymous_leaf (in_hintrewrite (base,lrul))
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
new file mode 100644
index 00000000..e97cde83
--- /dev/null
+++ b/tactics/autorewrite.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: autorewrite.mli,v 1.5.10.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Tacmach
+(*i*)
+
+(* Rewriting rules before tactic interpretation *)
+type raw_rew_rule = Term.constr * bool * Tacexpr.raw_tactic_expr
+
+(* To add rewriting rules to a base *)
+val add_rew_rules : string -> raw_rew_rule list -> unit
+
+(* The AutoRewrite tactic *)
+val autorewrite : tactic -> string list -> tactic
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
new file mode 100644
index 00000000..c5cdd540
--- /dev/null
+++ b/tactics/btermdn.ml
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: btermdn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Term
+open Termdn
+open Pattern
+
+(* Discrimination nets with bounded depth.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97). *)
+
+let dnet_depth = ref 8
+		   
+let bounded_constr_pat_discr (t,depth) =
+  if depth = 0 then 
+    None 
+  else
+    match constr_pat_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+let bounded_constr_val_discr (t,depth) =
+  if depth = 0 then 
+    None 
+  else
+    match constr_val_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+type 'a t = (constr_label,constr_pattern * int,'a) Dn.t
+
+let create = Dn.create
+
+let add dn (c,v) = Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)
+
+let rmv dn (c,v) = Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)
+
+let lookup dn t =
+  List.map 
+    (fun ((c,_),v) -> (c,v)) 
+    (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))
+
+let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
+
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
new file mode 100644
index 00000000..fe247495
--- /dev/null
+++ b/tactics/btermdn.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: btermdn.mli,v 1.8.16.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+
+(* Discrimination nets with bounded depth. *)
+
+type 'a t
+
+val create : unit -> 'a t
+
+val add : 'a t -> (constr_pattern * 'a) -> 'a t
+val rmv : 'a t -> (constr_pattern * 'a) -> 'a t
+
+val lookup : 'a t -> constr -> (constr_pattern * 'a) list
+val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
+
+val dnet_depth : int ref
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
new file mode 100644
index 00000000..c9d0ead5
--- /dev/null
+++ b/tactics/contradiction.ml
@@ -0,0 +1,88 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: contradiction.ml,v 1.3.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Util
+open Term
+open Proof_type
+open Hipattern
+open Tacmach
+open Tacticals
+open Tactics
+open Coqlib
+open Reductionops
+open Rawterm
+
+(* Absurd *)
+
+let absurd c gls =
+  (tclTHENS
+     (tclTHEN (elim_type (build_coq_False ())) (cut c)) 
+     ([(tclTHENS
+          (cut (applist(build_coq_not (),[c]))) 
+	  ([(tclTHEN intros
+	       ((fun gl ->
+		   let ida = pf_nth_hyp_id gl 1
+                   and idna = pf_nth_hyp_id gl 2 in
+                   exact_no_check (applist(mkVar idna,[mkVar ida])) gl)));
+            tclIDTAC]));
+       tclIDTAC])) gls
+
+(* Contradiction *)
+
+let filter_hyp f tac gl =
+  let rec seek = function
+    | [] -> raise Not_found
+    | (id,_,t)::rest when f t -> tac id gl
+    | _::rest -> seek rest in
+  seek (pf_hyps gl)
+
+let contradiction_context gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rec seek_neg l gl = match l with
+    | [] ->  error "No such contradiction"
+    | (id,_,typ)::rest ->
+	let typ = whd_betadeltaiota env sigma typ in
+	if is_empty_type typ then
+	  simplest_elim (mkVar id) gl
+	else match kind_of_term typ with
+	  | Prod (na,t,u) when is_empty_type u ->
+	      (try
+		filter_hyp (fun typ -> pf_conv_x_leq gl typ t) 
+		  (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
+		  gl
+	      with Not_found -> seek_neg rest gl)
+	  | _ -> seek_neg rest gl in
+  seek_neg (pf_hyps gl) gl
+
+let is_negation_of env sigma typ t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t
+    | _ -> false
+
+let contradiction_term (c,lbind as cl) gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let typ = pf_type_of gl c in
+  let _, ccl = splay_prod env sigma typ in
+  if is_empty_type ccl then
+    tclTHEN (elim cl None) (tclTRY assumption) gl
+  else
+    try
+      if lbind = NoBindings then
+	filter_hyp (is_negation_of env sigma typ)
+	  (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl
+      else
+	raise Not_found
+    with Not_found -> error "Not a contradiction"
+
+let contradiction = function
+  | None -> tclTHEN intros contradiction_context
+  | Some c -> contradiction_term c
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
new file mode 100644
index 00000000..90ec101c
--- /dev/null
+++ b/tactics/contradiction.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: contradiction.mli,v 1.2.2.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Rawterm
+(*i*)
+
+val absurd                      : constr -> tactic
+val contradiction               : constr with_bindings option -> tactic
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
new file mode 100644
index 00000000..fb672d0b
--- /dev/null
+++ b/tactics/dhyp.ml
@@ -0,0 +1,373 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: dhyp.ml,v 1.30.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+(* Chet's comments about this tactic :
+ 
+ Programmable destruction of hypotheses and conclusions.
+
+   The idea here is that we are going to store patterns.  These
+   patterns look like:
+
+   TYP=<pattern>
+   SORT=<pattern>
+
+   and from these patterns, we will be able to decide which tactic to
+   execute.
+
+   For hypotheses, we have a vector of 4 patterns:
+
+   HYP[TYP] HYP[SORT] CONCL[TYP] CONCL[SORT]
+
+   and for conclusions, we have 2:
+
+   CONCL[TYP] CONCL[SORT]
+
+   If the user doesn't supply some of these, they are just replaced
+   with empties.
+
+   The process of matching goes like this:
+
+   We use a discrimination net to look for matches between the pattern
+   for HYP[TOP] (CONCL[TOP]) and the type of the chosen hypothesis.
+   Then, we use this to look for the right tactic to apply, by
+   matching the rest of the slots.  Each match is tried, and if there
+   is more than one, this fact is reported, and the one with the
+   lowest priority is taken.  The priority is a parameter of the
+   tactic input.
+
+   The tactic input is an expression to hand to the
+   tactic-interpreter, and its priority.
+
+   For most tactics, the priority should be the number of subgoals
+   generated.
+
+   Matching is compatible with second-order matching of sopattern.
+
+   SYNTAX:
+
+   Hint DHyp <hyp-pattern> pri <tac-pattern>.
+
+   and
+
+   Hint DConcl <concl-pattern> pri <tac-pattern>.
+
+   The bindings at the end allow us to transfer information from the
+   patterns on terms into the patterns on tactics in a safe way - we
+   will perform second-order normalization and conversion to an AST
+   before substitution into the tactic-expression.
+
+   WARNING: The binding mechanism is NOT intended to facilitate the
+   transfer of large amounts of information from the terms to the
+   tactic.  This should be done in a special-purpose tactic.
+
+ *)
+
+(*
+
+Example : The tactic "if there is a hypothesis saying that the
+successor of some number is smaller than zero, then invert such
+hypothesis" is defined in this way:
+
+Require DHyp.
+Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1
+  (:tactic:<Inversion $0>).
+
+Then, the tactic is used like this:
+
+Goal (le (S O) O) -> False.
+Intro H.
+DHyp  H.
+Qed.
+
+The name "$0" refers to the matching hypothesis --in this case the
+hypothesis H.
+
+Similarly for the conclusion :
+
+Hint Destruct Conclusion equal_zero  (? = ?) 1 (:tactic:<Reflexivity>).
+
+Goal (plus O O)=O.
+DConcl.
+Qed.
+
+The "Discardable" option clears the hypothesis after using it.
+
+Require DHyp.
+Hint Destruct  Discardable Hypothesis less_than_zero (le (S ?) O) 1
+  (:tactic:<Inversion $0>).
+
+Goal (n:nat)(le (S n) O) -> False.
+Intros n H.
+DHyp  H.
+Qed.
+-- Eduardo (9/3/97 )
+
+*)
+
+open Pp
+open Util
+open Names
+open Term
+open Environ
+open Reduction
+open Proof_type
+open Rawterm
+open Tacmach
+open Refiner
+open Tactics
+open Clenv
+open Tactics
+open Tacticals
+open Libobject
+open Library
+open Pattern
+open Matching
+open Ast
+open Pcoq
+open Tacexpr
+open Libnames
+
+(* two patterns - one for the type, and one for the type of the type *)
+type destructor_pattern = {
+  d_typ: constr_pattern; 
+  d_sort: constr_pattern }
+
+let subst_destructor_pattern subst { d_typ = t; d_sort = s } =
+  { d_typ = subst_pattern subst t; d_sort = subst_pattern subst s }
+
+(* hypothesis patterns might need to do matching on the conclusion, too.
+ * conclusion-patterns only need to do matching on the hypothesis *)
+type located_destructor_pattern =
+   (* discardable, pattern for hyp, pattern for concl *)
+   (bool * destructor_pattern * destructor_pattern,
+   (* pattern for concl *)
+   destructor_pattern) location
+
+let subst_located_destructor_pattern subst = function
+  | HypLocation (b,d,d') -> 
+      HypLocation
+        (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d')
+  | ConclLocation d ->
+      ConclLocation (subst_destructor_pattern subst d)
+
+type destructor_data = {
+  d_pat : located_destructor_pattern;
+  d_pri : int;
+  d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *)
+}
+
+type t = (identifier,destructor_data) Nbtermdn.t
+type frozen_t = (identifier,destructor_data) Nbtermdn.frozen_t
+
+let tactab = (Nbtermdn.create () : t)
+
+let lookup pat = Nbtermdn.lookup tactab pat
+
+let init () = Nbtermdn.empty tactab
+
+let freeze () = Nbtermdn.freeze tactab
+let unfreeze fs = Nbtermdn.unfreeze fs tactab
+
+let rollback f x =
+  let fs = freeze() in 
+  try f x with e -> (unfreeze fs; raise e)
+
+let add (na,dd) =
+  let pat = match dd.d_pat with
+    | HypLocation(_,p,_) -> p.d_typ
+    | ConclLocation p -> p.d_typ
+  in 
+  if Nbtermdn.in_dn tactab na then begin
+    msgnl (str "Warning [Overriding Destructor Entry " ++ 
+             str (string_of_id na) ++ str"]");
+    Nbtermdn.remap tactab na (pat,dd)
+  end else 
+    Nbtermdn.add tactab (na,(pat,dd))
+
+let _ = 
+  Summary.declare_summary "destruct-hyp-concl"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let forward_subst_tactic = 
+  ref (fun _ -> failwith "subst_tactic is not installed for DHyp")
+
+let set_extern_subst_tactic f = forward_subst_tactic := f
+
+let cache_dd (_,(_,na,dd)) =
+  try 
+    add (na,dd)
+  with _ -> 
+    anomalylabstrm "Dhyp.add"
+      (str"The code which adds destructor hints broke;" ++ spc () ++ 
+	 str"this is not supposed to happen")
+
+let classify_dd (_,(local,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_dd (local,_,_ as x) = if local then None else Some x
+
+let subst_dd (_,subst,(local,na,dd)) =
+  (local,na,
+  { d_pat = subst_located_destructor_pattern subst dd.d_pat;
+    d_pri = dd.d_pri; 
+    d_code = !forward_subst_tactic subst dd.d_code })
+
+let (inDD,outDD) =
+  declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
+                    cache_function = cache_dd;
+		    open_function = (fun i o -> if i=1 then cache_dd o);
+                    subst_function = subst_dd;
+		    classify_function = classify_dd;
+                    export_function = export_dd }
+
+let forward_intern_tac = 
+  ref (fun _ -> failwith "intern_tac is not installed for DHyp")
+
+let set_extern_intern_tac f = forward_intern_tac := f
+
+let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT"))
+let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE"))
+    
+let add_destructor_hint local na loc pat pri code =
+  let code = !forward_intern_tac code in
+  let code =
+    begin match loc, code with
+      | HypLocation _, TacFun ([id],body) -> (id,body)
+      | ConclLocation _, _ -> (None, code)
+      | _ ->
+	  errorlabstrm "add_destructor_hint"
+          (str "The tactic should be a function of the hypothesis name") end
+  in
+  let (_,pat) = Constrintern.interp_constrpattern Evd.empty (Global.env()) pat
+  in
+  let pat = match loc with
+    | HypLocation b ->
+	HypLocation
+	  (b,{d_typ=pat;d_sort=catch_all_sort_pattern},
+	     {d_typ=catch_all_type_pattern;d_sort=catch_all_sort_pattern})
+    | ConclLocation () ->
+	ConclLocation({d_typ=pat;d_sort=catch_all_sort_pattern}) in
+  Lib.add_anonymous_leaf
+    (inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code }))
+
+let match_dpat dp cls gls =
+  match (cls,dp) with
+    | ({onhyps=lo;onconcl=false},HypLocation(_,hypd,concld)) ->
+        let hl = match lo with
+            Some l -> l
+          | None -> List.map (fun id -> (id,[],(InHyp,ref None)))
+                     (pf_ids_of_hyps gls) in
+        if not
+          (List.for_all
+            (fun (id,_,(hl,_)) ->
+              let cltyp = pf_get_hyp_typ gls id in
+              let cl = pf_concl gls in
+              (hl=InHyp) &
+              (is_matching hypd.d_typ cltyp) &
+              (is_matching hypd.d_sort (pf_type_of gls cltyp)) &
+              (is_matching concld.d_typ cl) &
+              (is_matching concld.d_sort (pf_type_of gls cl)))
+            hl)
+        then error "No match"
+    | ({onhyps=Some[];onconcl=true},ConclLocation concld) ->
+        let cl = pf_concl gls in
+        if not
+          ((is_matching concld.d_typ cl) &
+           (is_matching concld.d_sort (pf_type_of gls cl)))
+        then error "No match"
+    | _ -> error "ApplyDestructor"
+
+let forward_interp_tactic = 
+  ref (fun _ -> failwith "interp_tactic is not installed for DHyp")
+
+let set_extern_interp f = forward_interp_tactic := f
+
+let applyDestructor cls discard dd gls =
+  match_dpat dd.d_pat cls gls;
+  let cll = simple_clause_list_of cls gls in
+  let tacl =
+    List.map (fun cl ->
+      match cl, dd.d_code with
+        | Some (id,_,_), (Some x, tac) -> 
+	    let arg =
+              ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
+            TacLetIn ([(dummy_loc, x), None, arg], tac)
+        | None, (None, tac) -> tac
+        | _, (Some _,_) -> error "Destructor expects an hypothesis"
+        | _, (None,_) -> error "Destructor is for conclusion")
+      cll in
+  let discard_0 =
+    List.map (fun cl ->
+      match (cl,dd.d_pat) with
+        | (Some (id,_,_),HypLocation(discardable,_,_)) ->
+            if discard & discardable then thin [id] else tclIDTAC
+        | (None,ConclLocation _) -> tclIDTAC
+        | _ -> error "ApplyDestructor" ) cll in
+  tclTHEN (tclMAP !forward_interp_tactic tacl) (tclTHENLIST discard_0) gls
+
+
+(* [DHyp id gls]
+
+   will take an identifier, get its type, look it up in the
+   discrimination net, get the destructors stored there, and then try
+   them in order of priority. *)
+
+let destructHyp discard id gls =
+  let hyptyp = pf_get_hyp_typ gls id in
+  let ddl = List.map snd (lookup hyptyp) in
+  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
+  tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls
+
+let cDHyp id gls = destructHyp true id gls
+let dHyp id gls = destructHyp false id gls
+
+let h_destructHyp b id =
+  abstract_tactic (TacDestructHyp (b,(dummy_loc,id))) (destructHyp b id)
+
+(* [DConcl gls]
+
+   will take a goal, get its concl, look it up in the
+   discrimination net, get the destructors stored there, and then try
+   them in order of priority. *)
+
+let dConcl gls =
+  let ddl = List.map snd (lookup (pf_concl gls)) in
+  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
+  tclFIRST (List.map (applyDestructor onConcl false) sorted_ddl) gls
+
+let h_destructConcl = abstract_tactic TacDestructConcl dConcl
+
+let to2Lists (table : t) = Nbtermdn.to2lists table
+
+let rec search n =
+  if n=0 then error "Search has reached zero.";
+  tclFIRST
+    [intros;
+     assumption;
+     (tclTHEN  
+        (Tacticals.tryAllClauses 
+           (function 
+              | Some (id,_,_) -> (dHyp id)
+              | None    ->  dConcl ))
+        (search (n-1)))]
+    
+let auto_tdb n = tclTRY (tclCOMPLETE (search n))
+   
+let search_depth_tdb = ref(5)
+
+let depth_tdb = function
+  | None -> !search_depth_tdb
+  | Some n -> n
+
+let h_auto_tdb n = abstract_tactic (TacAutoTDB n) (auto_tdb (depth_tdb n))
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
new file mode 100644
index 00000000..a0cef679
--- /dev/null
+++ b/tactics/dhyp.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: dhyp.mli,v 1.8.2.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Tacmach
+open Tacexpr
+(*i*)
+
+(* Programmable destruction of hypotheses and conclusions. *)
+
+val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
+val set_extern_intern_tac : (raw_tactic_expr -> glob_tactic_expr) -> unit
+
+(*
+val dHyp : identifier -> tactic
+val dConcl : tactic
+*)
+val h_destructHyp : bool -> identifier -> tactic
+val h_destructConcl : tactic
+val h_auto_tdb : int option -> tactic
+
+val add_destructor_hint :
+  Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
+    Topconstr.constr_expr -> int -> raw_tactic_expr -> unit
diff --git a/tactics/dn.ml b/tactics/dn.ml
new file mode 100644
index 00000000..55116831
--- /dev/null
+++ b/tactics/dn.ml
@@ -0,0 +1,80 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: dn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+(* This file implements the basic structure of what Chet called
+   ``discrimination nets''. If my understanding is right, it serves
+   to associate actions (for example, tactics) with a priority to term
+   patterns, so that if a hypothesis matches a pattern in the net,
+   then the associated tactic is applied. Discrimination nets are used
+   (only) to implement the tactics Auto, DHyp and Point.
+
+   A discrimination net is a tries structure, that is, a tree structure 
+   specially conceived for searching patterns, like for example strings
+   --see the file Tlm.ml in the directory lib/util--. Here the tries
+   structure are used for looking for term patterns.
+
+   This module is then used in :
+     - termdn.ml   (discrimination nets of terms);
+     - btermdn.ml  (discrimination nets of terms with bounded depth,
+                    used in the tactic auto);
+     - nbtermdn.ml (named discrimination nets with bounded depth, used
+                    in the tactics Dhyp and Point).
+  Eduardo (4/8/97) *)
+
+(* Definition of the basic structure *)
+
+type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option
+
+type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t
+
+let create () = Tlm.empty
+
+(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in 
+prefix ordering, [dna] is the function returning the main node of a pattern *)
+
+let path_of dna =
+  let rec path_of_deferred = function
+    | [] -> []
+    | h::tl -> pathrec tl h
+	    
+  and pathrec deferred t =
+    match dna t with
+      | None -> 
+	  None :: (path_of_deferred deferred)
+      | Some (lbl,[]) ->
+	  (Some (lbl,0))::(path_of_deferred deferred)
+      | Some (lbl,(h::def_subl as v)) ->
+	  (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
+  in 
+  pathrec []
+    
+let tm_of tm lbl =
+  try [Tlm.map tm lbl] with Not_found -> []
+
+let lookup tm dna t =
+  let rec lookrec t tm =
+    (tm_of tm None)@
+    (match dna t with
+       | None -> []
+       | Some(lbl,v) ->
+	   List.fold_left 
+	     (fun l c -> List.flatten(List.map (lookrec c) l))
+             (tm_of tm (Some(lbl,List.length v))) v)
+  in 
+  List.flatten(List.map Tlm.xtract (lookrec t tm))
+
+let add tm dna (pat,inf) =
+  let p = path_of dna pat in Tlm.add tm (p,(pat,inf))
+    
+let rmv tm dna (pat,inf) =
+  let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf))
+    
+let app f tm = Tlm.app (fun (_,p) -> f p) tm
+
diff --git a/tactics/dn.mli b/tactics/dn.mli
new file mode 100644
index 00000000..a54007d8
--- /dev/null
+++ b/tactics/dn.mli
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: dn.mli,v 1.4.16.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(* Discrimination nets. *)
+
+type ('lbl,'tree) decompose_fun = 'tree -> ('lbl * 'tree list) option
+
+type ('lbl,'pat,'inf) t (* = (('lbl * int) option,'pat * 'inf) Tlm.t *)
+
+val create : unit -> ('lbl,'pat,'inf) t
+
+(* [add t f (tree,inf)] adds a structured object [tree] together with
+   the associated information [inf] to the table [t]; the function
+   [f] is used to translated [tree] into its prefix decomposition: [f]
+   must decompose any tree into a label characterizing its root node and
+   the list of its subtree *)
+
+val add : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf
+  -> ('lbl,'pat,'inf) t
+
+val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf 
+  -> ('lbl,'pat,'inf) t
+
+(* [lookup t f tree] looks for trees (and their associated
+   information) in table [t] such that the structured object [tree]
+   matches against them; [f] is used to translated [tree] into its
+   prefix decomposition: [f] must decompose any tree into a label
+   characterizing its root node and the list of its subtree *)
+
+val lookup : ('lbl,'pat,'inf) t -> ('lbl,'term) decompose_fun -> 'term
+  -> ('pat * 'inf) list
+
+val app : (('pat * 'inf) -> unit) -> ('lbl,'pat,'inf) t -> unit
diff --git a/tactics/doc.tex b/tactics/doc.tex
new file mode 100644
index 00000000..d44cc14a
--- /dev/null
+++ b/tactics/doc.tex
@@ -0,0 +1,11 @@
+
+\newpage
+\section*{The Tactics}
+
+\ocwsection \label{tactics}
+This chapter describes the \Coq\ main tactics.
+The modules of that chapter are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=tactics.dep.ps,width=\linewidth}\end{center}
+
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
new file mode 100644
index 00000000..31d79948
--- /dev/null
+++ b/tactics/eauto.ml4
@@ -0,0 +1,448 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: eauto.ml4,v 1.11.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Reduction
+open Proof_type
+open Proof_trees
+open Declarations
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Pattern
+open Clenv
+open Auto
+open Rawterm
+
+let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in 
+  if occur_existential t1 or occur_existential t2 then 
+     tclTHEN (unify t1) (exact_check c) gl
+  else exact_check c gl
+
+let assumption id = e_give_exact (mkVar id)
+        
+let e_assumption gl = 
+  tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
+
+let e_resolve_with_bindings_tac  (c,lbind) gl = 
+  let (wc,kONT) = startWalk gl in
+  let t = w_hnf_constr wc (w_type_of wc c) in 
+  let clause = make_clenv_binding_apply wc (-1) (c,t) lbind in 
+  e_res_pf kONT clause gl
+
+let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls
+			     
+(* V8 TACTIC EXTEND eexact
+| [ "eexact" constr(c) ] -> [ e_give_exact c ]
+END*)
+TACTIC EXTEND Eexact
+| [ "EExact" constr(c) ] -> [ e_give_exact c ]
+END
+
+let e_give_exact_constr = h_eexact
+
+let registered_e_assumption gl = 
+  tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) 
+              (pf_ids_of_hyps gl)) gl
+
+(* This automatically define h_eApply (among other things) *)
+(*V8 TACTIC EXTEND eapply
+  [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
+END*)
+TACTIC EXTEND eapply
+  [ "EApply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
+END
+
+let vernac_e_resolve_constr c = h_eapply (c,NoBindings)
+
+let e_constructor_tac boundopt i lbind gl = 
+    let cl = pf_concl gl in 
+  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in 
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames
+  and sigma   = project gl in
+  if i=0 then error "The constructors are numbered starting from 1";
+  if i > nconstr then error "Not enough constructors";
+  begin match boundopt with 
+    | Some expctdnum -> 
+        if expctdnum <> nconstr then 
+	  error "Not the expected number of constructors"
+    | None -> ()
+  end;
+  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
+  let apply_tac = e_resolve_with_bindings_tac (cons,lbind) in
+  (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl
+
+let e_one_constructor i = e_constructor_tac None i
+
+let e_any_constructor tacopt gl =
+  let t = match tacopt with None -> tclIDTAC | Some t -> t in
+  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
+  if nconstr = 0 then error "The type has no constructors";
+  tclFIRST (List.map (fun i -> tclTHEN (e_one_constructor i NoBindings) t) 
+              (interval 1 nconstr)) gl
+
+let e_left = e_constructor_tac (Some 2) 1
+
+let e_right = e_constructor_tac (Some 2) 2
+
+let e_split = e_constructor_tac (Some 1) 1
+
+(* This automatically define h_econstructor (among other things) *)
+(*V8 TACTIC EXTEND eapply
+  [ "econstructor" integer(n) with_bindings(c) ] -> [ e_constructor_tac None n c ]
+END*)
+TACTIC EXTEND econstructor
+  [ "EConstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ]
+  | [ "EConstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ]
+  | [ "EConstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] 
+      END
+
+TACTIC EXTEND eleft
+  [ "ELeft" "with" bindings(l) ] -> [e_left l]
+  | [ "ELeft"] -> [e_left NoBindings]
+END
+
+TACTIC EXTEND eright
+  [ "ERight" "with" bindings(l) ] -> [e_right l]
+  | [ "ERight" ] -> [e_right NoBindings]
+END
+
+TACTIC EXTEND esplit
+  [ "ESplit" "with" bindings(l) ] -> [e_split l]
+  | [ "ESplit"] -> [e_split NoBindings]
+END
+
+
+TACTIC EXTEND eexists
+  [ "EExists" bindings(l) ] -> [e_split l]
+END
+
+
+(************************************************************************)
+(*   PROLOG tactic                                                      *)
+(************************************************************************)
+
+let one_step l gl =
+  [Tactics.intro]
+  @ (List.map e_resolve_constr (List.map mkVar (pf_ids_of_hyps gl)))
+  @ (List.map e_resolve_constr l)
+  @ (List.map assumption (pf_ids_of_hyps gl))
+
+let rec prolog l n gl =
+  if n <= 0 then error "prolog - failure";
+  let prol = (prolog l (n-1)) in
+  (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
+
+let prolog_tac l n gl =
+  let n =
+    match n with
+      |  Genarg.ArgArg n -> n
+      | _ -> error "Prolog called with a non closed argument"
+  in
+  try (prolog l n gl)
+  with UserError ("Refiner.tclFIRST",_) ->
+    errorlabstrm "Prolog.prolog" (str "Prolog failed")
+
+(* V8 TACTIC EXTEND prolog
+| [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+END*)
+TACTIC EXTEND Prolog
+| [ "Prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+END
+
+(*
+let vernac_prolog =
+  let uncom = function
+    | Constr c -> c
+    | _ -> assert false
+  in
+  let gentac = 
+    hide_tactic "Prolog"
+      (function
+	 | (Integer n) :: al -> prolog_tac (List.map uncom al) n
+	 | _ -> assert false)
+  in 
+  fun coms n -> 
+    gentac ((Integer n) :: (List.map (fun com -> (Constr com)) coms))
+*)
+
+open Auto
+
+(***************************************************************************)
+(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
+(***************************************************************************)
+
+let unify_e_resolve  (c,clenv) gls = 
+  let (wc,kONT) = startWalk gls in
+  let clenv' = connect_clenv wc clenv in
+  let _ = clenv_unique_resolver false clenv' gls in
+  vernac_e_resolve_constr c gls
+
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl = 
+    registered_e_assumption ::
+    (tclTHEN Tactics.intro 
+       (function g'->
+	  let d = pf_last_hyp g' in
+	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
+          (e_trivial_fail_db db_list
+	     (Hint_db.add_list hintl local_db) g'))) ::
+    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+  in 
+  tclFIRST (List.map tclCOMPLETE tacl) goal 
+
+and e_my_find_search db_list local_db hdc concl = 
+  let hdc = head_of_constr_reference hdc in
+  let hintl =
+    if occur_existential concl then 
+      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+    else 
+      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+  in 
+  let tac_of_hint = 
+    fun ({pri=b; pat = p; code=t} as patac) -> 
+      (b, 
+       let tac =
+	 match t with
+	   | Res_pf (term,cl) -> unify_resolve (term,cl)
+	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
+	   | Give_exact (c) -> e_give_exact_constr c
+	   | Res_pf_THEN_trivial_fail (term,cl) ->
+               tclTHEN (unify_e_resolve (term,cl)) 
+		 (e_trivial_fail_db db_list local_db)
+	   | Unfold_nth c -> unfold_constr c
+	   | Extern tacast -> conclPattern concl 
+	       (out_some p) tacast
+       in 
+       (tac,fmt_autotactic t))
+       (*i
+	 fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); 
+                     try tac gls
+		     with e when Logic.catchable_exception(e) -> 
+                            (Format.print_string "Fail\n"; 
+			     Format.print_flush (); 
+			     raise e)
+       i*)
+  in 
+  List.map tac_of_hint hintl
+    
+and e_trivial_resolve db_list local_db gl = 
+  try 
+    Auto.priority 
+      (e_my_find_search db_list local_db 
+	 (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db gl =
+  try List.map snd (e_my_find_search db_list local_db 
+		      (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
+
+let find_first_goal gls = 
+  try first_goal gls with UserError _ -> assert false
+
+(*s The following module [SearchProblem] is used to instantiate the generic
+    exploration functor [Explore.Make]. *)
+      
+module SearchProblem = struct
+
+  type state = { 
+    depth : int; (*r depth of search before failing *)
+    tacres : goal list sigma * validation;
+    last_tactic : std_ppcmds;
+    dblist : Auto.Hint_db.t list;
+    localdb :  Auto.Hint_db.t list }
+		 
+  let success s = (sig_it (fst s.tacres)) = []
+
+  let rec filter_tactics (glls,v) = function
+    | [] -> []
+    | (tac,pptac) :: tacl -> 
+	try 
+	  let (lgls,ptl) = apply_tac_list tac glls in 
+	  let v' p = v (ptl p) in
+	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
+	with e when Logic.catchable_exception e ->
+	  filter_tactics (glls,v) tacl
+
+  let rec list_addn n x l = 
+    if n = 0 then l else x :: (list_addn (pred n) x l)
+
+  (* Ordering of states is lexicographic on depth (greatest first) then
+     number of remaining goals. *)
+  let compare s s' =
+    let d = s'.depth - s.depth in
+    let nbgoals s = List.length (sig_it (fst s.tacres)) in
+    if d <> 0 then d else nbgoals s - nbgoals s'
+
+  let branching s = 
+    if s.depth = 0 then 
+      []
+    else      
+      let lg = fst s.tacres in
+      let nbgl = List.length (sig_it lg) in
+      assert (nbgl > 0);
+      let g = find_first_goal lg in
+      let assumption_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (List.map 
+	       (fun id -> (e_give_exact_constr (mkVar id),
+			   (str "Exact" ++ spc () ++ pr_id id)))
+	       (pf_ids_of_hyps g))
+	in
+	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
+				    last_tactic = pp; dblist = s.dblist;
+				    localdb = List.tl s.localdb }) l
+      in
+      let intro_tac = 
+	List.map 
+	  (fun ((lgls,_) as res,pp) -> 
+	     let g' = first_goal lgls in 
+	     let hintl = 
+	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	     in
+             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+	     { depth = s.depth; tacres = res; 
+	       last_tactic = pp; dblist = s.dblist;
+	       localdb = ldb :: List.tl s.localdb })
+	  (filter_tactics s.tacres [Tactics.intro,(str "Intro")])
+      in
+      let rec_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+	in
+	List.map 
+	  (fun ((lgls,_) as res, pp) -> 
+	     let nbgl' = List.length (sig_it lgls) in
+	     if nbgl' < nbgl then
+	       { depth = s.depth; tacres = res; last_tactic = pp;
+		 dblist = s.dblist; localdb = List.tl s.localdb }
+	     else 
+	       { depth = pred s.depth; tacres = res; 
+		 dblist = s.dblist; last_tactic = pp;
+		 localdb = 
+		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
+	  l
+      in
+      List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
+
+  let pp s = 
+    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ 
+		  s.last_tactic ++ str "\n"))
+
+end
+
+module Search = Explore.Make(SearchProblem)
+
+let make_initial_state n gl dblist localdb =
+  { SearchProblem.depth = n;
+    SearchProblem.tacres = tclIDTAC gl;
+    SearchProblem.last_tactic = (mt ());
+    SearchProblem.dblist = dblist;
+    SearchProblem.localdb = [localdb] }
+
+let e_depth_search debug p db_list local_db gl =
+  try
+    let tac = if debug then Search.debug_depth_first else Search.depth_first in
+    let s = tac (make_initial_state p gl db_list local_db) in
+    s.SearchProblem.tacres
+  with Not_found -> error "EAuto: depth first search failed"
+
+let e_breadth_search debug n db_list local_db gl =
+  try
+    let tac = 
+      if debug then Search.debug_breadth_first else Search.breadth_first 
+    in
+    let s = tac (make_initial_state n gl db_list local_db) in
+    s.SearchProblem.tacres
+  with Not_found -> error "EAuto: breadth first search failed"
+
+let e_search_auto debug (in_depth,p) db_list gl = 
+  let local_db = make_local_hint_db gl in 
+  if in_depth then 
+    e_depth_search debug p db_list local_db gl
+  else 
+    e_breadth_search debug p db_list local_db gl
+
+let eauto debug np dbnames = 
+  let db_list =
+    List.map
+      (fun x -> 
+	 try Stringmap.find x !searchtable
+	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  tclTRY (e_search_auto debug np db_list)
+
+let full_eauto debug n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames =  list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in
+  let local_db = make_local_hint_db gl in
+  tclTRY (e_search_auto debug n db_list) gl
+
+let gen_eauto d np = function
+  | None -> full_eauto d np
+  | Some l -> eauto d np l
+
+let make_depth = function
+  | None -> !default_search_depth 
+  | Some (Genarg.ArgArg d) -> d
+  | _ -> error "EAuto called with a non closed argument"
+
+let make_dimension n = function
+  | None -> (true,make_depth n)
+  | Some (Genarg.ArgArg d) -> (false,d)
+  | _ -> error "EAuto called with a non closed argument"
+
+open Genarg
+
+(* Hint bases *)
+
+let pr_hintbases _prc _prt = function 
+  | None -> str " with *"
+  | Some [] -> mt ()
+  | Some l -> str " with " ++ Util.prlist_with_sep spc str l
+
+ARGUMENT EXTEND hintbases
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ "with" "*" ] -> [ None ]
+| [ "with" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ Some [] ]
+END
+
+TACTIC EXTEND EAuto
+| [ "EAuto" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] ->
+    [ gen_eauto false (make_dimension n p) db ]
+END
+
+V7 TACTIC EXTEND EAutodebug
+| [ "EAutod" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] ->
+    [ gen_eauto true (make_dimension n p) db ]
+END
+
+
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
new file mode 100644
index 00000000..c3084e65
--- /dev/null
+++ b/tactics/eauto.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i*)
+open Term
+open Proof_type
+open Tacexpr
+(*i*)
+
+val rawwit_hintbases : string list option raw_abstract_argument_type
+
+val e_assumption : tactic
+
+val registered_e_assumption : tactic
+
+val e_resolve_constr :  constr -> tactic
+
+val vernac_e_resolve_constr :  constr -> tactic
+
+val e_give_exact_constr : constr -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
new file mode 100644
index 00000000..5573f9ea
--- /dev/null
+++ b/tactics/elim.ml
@@ -0,0 +1,195 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: elim.ml,v 1.37.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Environ
+open Libnames
+open Reduction
+open Inductiveops
+open Proof_type
+open Clenv
+open Hipattern
+open Tacmach
+open Tacticals
+open Tactics
+open Hiddentac
+open Genarg
+open Tacexpr
+
+let introElimAssumsThen tac ba =
+  let nassums = 
+    List.fold_left 
+      (fun acc b -> if b then acc+2 else acc+1) 
+      0 ba.branchsign 
+  in 
+  let introElimAssums = tclDO nassums intro in 
+  (tclTHEN introElimAssums (elim_on_ba tac ba))
+
+let introCaseAssumsThen tac ba =
+  let case_thin_sign =
+    List.flatten
+      (List.map (function b -> if b then [false;true] else [false])
+	ba.branchsign)
+  in 
+  let n1 = List.length case_thin_sign in
+  let n2 = List.length ba.branchnames in
+  let (l1,l2),l3 =
+    if n1 < n2 then list_chop n1 ba.branchnames, []
+    else 
+      (ba.branchnames, []),
+       if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
+  let introCaseAssums = tclTHEN (intros_pattern None l1) (intros_clearing l3)
+  in
+  (tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
+
+(* The following tactic Decompose repeatedly applies the
+   elimination(s) rule(s) of the types satisfying the predicate
+   ``recognizer'' onto a certain hypothesis. For example :
+
+Require Elim.
+Require Le.
+   Goal (y:nat){x:nat | (le O x)/\(le x y)}->{x:nat | (le O x)}.
+   Intros y H.
+   Decompose [sig and] H;EAuto.
+   Qed.
+
+Another example :
+
+   Goal (A,B,C:Prop)(A/\B/\C \/ B/\C \/ C/\A) -> C.
+   Intros A B C H; Decompose [and or] H; Assumption.
+   Qed.
+*)
+
+let elimHypThen tac id gl =
+  elimination_then tac ([],[]) (mkVar id) gl
+
+let rec general_decompose_on_hyp recognizer =
+  ifOnHyp recognizer (general_decompose recognizer) (fun _ -> tclIDTAC)
+
+and general_decompose recognizer id =
+  elimHypThen
+    (introElimAssumsThen
+       (fun bas ->
+	  tclTHEN (clear [id])
+	    (tclMAP (general_decompose_on_hyp recognizer)
+               (ids_of_named_context bas.assums))))
+    id
+
+(* Faudrait ajouter un COMPLETE pour que l'hypothèse créée ne reste
+   pas si aucune élimination n'est possible *)
+
+(* Meilleures stratégies mais perte de compatibilité *)
+let tmphyp_name = id_of_string "_TmpHyp"
+let up_to_delta = ref false (* true *)
+
+let general_decompose recognizer c gl = 
+  let typc = pf_type_of gl c in  
+  tclTHENSV (cut typc) 
+    [| tclTHEN (intro_using tmphyp_name)
+         (onLastHyp
+	    (ifOnHyp recognizer (general_decompose recognizer)
+	      (fun id -> clear [id])));
+       exact_no_check c |] gl
+
+let head_in gls indl t =
+  try
+    let ity,_ =
+      if !up_to_delta
+      then find_mrectype (pf_env gls) (project gls) t
+      else extract_mrectype t
+    in List.mem ity indl
+  with Not_found -> false
+       
+let inductive_of = function
+  | IndRef ity -> ity
+  | r ->
+      errorlabstrm "Decompose"
+        (Printer.pr_global r ++ str " is not an inductive type")
+
+let decompose_these c l gls =
+  let indl = (*List.map inductive_of*) l in 
+  general_decompose (fun (_,t) -> head_in gls indl t) c gls
+
+let decompose_nonrec c gls =
+  general_decompose 
+    (fun (_,t) -> is_non_recursive_type t)
+    c gls
+
+let decompose_and c gls = 
+  general_decompose 
+    (fun (_,t) -> is_conjunction t)
+    c gls
+
+let decompose_or c gls = 
+  general_decompose 
+    (fun (_,t) -> is_disjunction t)
+    c gls
+
+let h_decompose l c =
+  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
+
+let h_decompose_or c =
+  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
+
+let h_decompose_and c =
+  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
+
+(* The tactic Double performs a double induction *)
+
+let simple_elimination c gls =
+  simple_elimination_then (fun _ -> tclIDTAC) c gls
+
+let induction_trailer abs_i abs_j bargs =
+  tclTHEN 
+    (tclDO (abs_j - abs_i) intro)
+    (onLastHyp
+       (fun id gls ->
+	  let idty = pf_type_of gls (mkVar id) in
+	  let fvty = global_vars (pf_env gls) idty in
+	  let possible_bring_hyps =
+	    (List.tl (nLastHyps (abs_j - abs_i) gls)) @ bargs.assums
+          in
+	  let (hyps,_) =
+            List.fold_left 
+	      (fun (bring_ids,leave_ids) (cid,_,cidty as d) ->
+                 if not (List.mem cid leave_ids)
+                 then (d::bring_ids,leave_ids)
+                 else (bring_ids,cid::leave_ids))
+	      ([],fvty) possible_bring_hyps
+	  in
+          let ids = List.rev (ids_of_named_context hyps) in
+	  (tclTHENSEQ
+            [bring_hyps hyps; tclTRY (clear ids); 
+	     simple_elimination (mkVar id)])
+          gls))
+
+let double_ind h1 h2 gls =
+  let abs_i = depth_of_quantified_hypothesis true h1 gls in
+  let abs_j = depth_of_quantified_hypothesis true h2 gls in
+  let (abs_i,abs_j) =
+    if abs_i < abs_j then (abs_i,abs_j) else
+    if abs_i > abs_j then (abs_j,abs_i) else
+      error "Both hypotheses are the same" in
+  let cl = pf_concl gls in 
+  (tclTHEN (tclDO abs_i intro)
+     (onLastHyp
+       	(fun id ->
+           elimination_then
+             (introElimAssumsThen (induction_trailer abs_i abs_j))
+             ([],[]) (mkVar id)))) gls
+
+let h_double_induction h1 h2 =
+  Refiner.abstract_tactic (TacDoubleInduction (h1,h2)) (double_ind h1 h2)
+
+
diff --git a/tactics/elim.mli b/tactics/elim.mli
new file mode 100644
index 00000000..a891cd9d
--- /dev/null
+++ b/tactics/elim.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: elim.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Tacmach
+open Genarg
+open Tacticals
+(*i*)
+
+(* Eliminations tactics. *)
+
+val introElimAssumsThen :
+  (branch_assumptions -> tactic) -> branch_args -> tactic
+
+val introCaseAssumsThen :
+  (intro_pattern_expr list -> branch_assumptions -> tactic) -> 
+    branch_args -> tactic
+
+val general_decompose : (identifier * constr -> bool) -> constr -> tactic
+val decompose_nonrec  : constr -> tactic
+val decompose_and     : constr -> tactic
+val decompose_or      : constr -> tactic
+val h_decompose       : inductive list -> constr -> tactic
+val h_decompose_or    : constr -> tactic
+val h_decompose_and   : constr -> tactic
+
+val double_ind : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis -> tactic
+val h_double_induction : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis->tactic
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
new file mode 100644
index 00000000..8edfcb3e
--- /dev/null
+++ b/tactics/eqdecide.ml4
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: eqdecide.ml4,v 1.6.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Declarations
+open Tactics
+open Tacticals
+open Hiddentac
+open Equality
+open Auto
+open Pattern
+open Matching
+open Hipattern
+open Proof_trees
+open Proof_type
+open Tacmach
+open Coqlib
+
+(* This file containts the implementation of the tactics ``Decide
+   Equality'' and ``Compare''. They can be used to decide the
+   propositional equality of two objects that belongs to a small
+   inductive datatype --i.e., an inductive set such that all the
+   arguments of its constructors are non-functional sets.
+
+   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
+   follows:
+   1. Eliminate x and then y.
+   2. Try discrimination to solve those goals where x and y has
+      been introduced by different constructors.
+   3. If x and y have been introduced by the same constructor,
+      then analyse one by one the correspoing pairs of arguments.
+      If they are equal, rewrite one into the other. If they are
+      not, derive a contradiction from the injectiveness of the
+      constructor. 
+   4. Once all the arguments have been rewritten, solve the left half 
+      of the disjunction by reflexivity.
+
+   Eduardo Gimenez (30/3/98).
+*)
+
+let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c])))
+
+let mkBranches = 
+  tclTHENSEQ
+    [intro; 
+     tclLAST_HYP h_simplest_elim;
+     clear_last;
+     intros ;
+     tclLAST_HYP h_simplest_case;
+     clear_last;
+     intros]
+
+let solveRightBranch  = 
+  tclTHEN h_simplest_right
+    (tclTHEN (intro_force true)
+      (onLastHyp (fun id -> Extratactics.h_discrHyp (Rawterm.NamedHyp id))))
+
+let h_solveRightBranch =
+  Refiner.abstract_extended_tactic "solveRightBranch" [] solveRightBranch
+
+(*
+let h_solveRightBranch =
+  hide_atomic_tactic "solveRightBranch" solveRightBranch
+*)
+
+(* Constructs the type {c1=c2}+{~c1=c2} *)
+
+let mkDecideEqGoal rectype c1 c2 g = 
+  let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
+  let disequality = mkApp(build_coq_not (), [|equality|]) in
+  mkApp(build_coq_sumbool (), [|equality; disequality |])
+
+
+(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
+
+let mkGenDecideEqGoal rectype g = 
+  let hypnames = pf_ids_of_hyps g in 
+  let xname    = next_ident_away (id_of_string "x") hypnames
+  and yname    = next_ident_away (id_of_string "y") hypnames in
+  (mkNamedProd xname rectype 
+     (mkNamedProd yname rectype 
+        (mkDecideEqGoal rectype (mkVar xname) (mkVar yname) g)))
+
+let eqCase  tac = 
+  (tclTHEN intro  
+  (tclTHEN (tclLAST_HYP Extratactics.h_rewriteLR)
+  (tclTHEN clear_last 
+  tac)))
+
+let diseqCase = 
+  let diseq  = id_of_string "diseq" in
+  let absurd = id_of_string "absurd" in 
+  (tclTHEN (intro_using diseq)
+  (tclTHEN  h_simplest_right
+  (tclTHEN  red_in_concl
+  (tclTHEN  (intro_using absurd)
+  (tclTHEN  (h_simplest_apply (mkVar diseq))
+  (tclTHEN  (Extratactics.h_injHyp (Rawterm.NamedHyp absurd))
+            full_trivial))))))
+
+let solveArg a1 a2 tac  g = 
+  let rectype = pf_type_of g a1 in
+  let decide  = mkDecideEqGoal rectype a1 a2 g in  
+  (tclTHENS
+     (h_elim_type decide) 
+     [(eqCase tac);diseqCase;default_auto]) g
+
+let solveLeftBranch rectype g =
+  try
+    let (lhs,rhs) = match_eqdec_partial (pf_concl g) in
+    let (mib,mip) = Global.lookup_inductive rectype in
+    let nparams   = mip.mind_nparams in
+    let getargs l = list_skipn nparams (snd (decompose_app l)) in
+    let rargs   = getargs rhs
+    and largs   = getargs lhs in 
+    List.fold_right2 
+      solveArg largs rargs (tclTHEN h_simplest_left h_reflexivity) g
+  with PatternMatchingFailure -> error "Unexpected conclusion!"
+
+(* The tactic Decide Equality *)
+
+let hd_app c = match kind_of_term c with
+  | App (h,_) -> h
+  | _ -> c
+
+let decideGralEquality g =
+  try
+    let typ = match_eqdec (pf_concl g) in
+    let headtyp = hd_app (pf_compute g typ) in
+    let rectype =
+      match kind_of_term headtyp with
+        | Ind mi -> mi
+	| _ -> error "This decision procedure only works for inductive objects"
+    in 
+    (tclTHEN
+      mkBranches 
+      (tclORELSE h_solveRightBranch (solveLeftBranch rectype))) g
+  with PatternMatchingFailure ->
+    error "The goal does not have the expected form"
+
+
+let decideEquality c1 c2 g = 
+  let rectype = (pf_type_of g c1) in     
+  let decide  = mkGenDecideEqGoal rectype g in  
+  (tclTHENS (cut decide) [default_auto;decideGralEquality]) g
+
+
+(* The tactic Compare *)
+
+let compare c1 c2 g = 
+  let rectype = pf_type_of g c1 in
+  let decide  = mkDecideEqGoal rectype c1 c2 g in  
+  (tclTHENS (cut decide) 
+            [(tclTHEN  intro 
+             (tclTHEN (tclLAST_HYP simplest_case)
+                       clear_last));
+             decideEquality c1 c2]) g
+
+
+(* User syntax *)
+
+TACTIC EXTEND DecideEquality
+  [ "Decide" "Equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
+| [ "Decide" "Equality" ] -> [ decideGralEquality ]
+END
+
+TACTIC EXTEND Compare
+| [ "Compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+END
+
diff --git a/tactics/equality.ml b/tactics/equality.ml
new file mode 100644
index 00000000..dd9054f5
--- /dev/null
+++ b/tactics/equality.ml
@@ -0,0 +1,1213 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: equality.ml,v 1.120.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Univ
+open Term
+open Termops
+open Inductive
+open Inductiveops
+open Environ
+open Reductionops
+open Instantiate
+open Typeops
+open Typing
+open Retyping
+open Tacmach
+open Proof_type
+open Logic
+open Evar_refiner
+open Pattern
+open Matching
+open Hipattern
+open Tacexpr
+open Tacticals
+open Tactics
+open Tacred
+open Rawterm
+open Coqlib
+open Vernacexpr
+open Setoid_replace
+open Declarations
+
+(* Rewriting tactics *)
+
+(* Warning : rewriting from left to right only works
+   if there exists in the context a theorem named <eqname>_<suffsort>_r
+   with type (A:<sort>)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y).
+   If another equality myeq is introduced, then corresponding theorems
+   myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below.
+   -- Eduardo (19/8/97
+*)
+
+let general_rewrite_bindings lft2rgt (c,l) gl =
+  let ctype = pf_type_of gl c in 
+  let env = pf_env gl in
+  let sigma = project gl in 
+  let _,t = splay_prod env sigma ctype in
+  match match_with_equation t with
+    | None -> 
+	if l = NoBindings
+	then general_s_rewrite lft2rgt c gl
+	else error "The term provided does not end with an equation" 
+    | Some (hdcncl,_) -> 
+        let hdcncls = string_of_inductive hdcncl in 
+	let suffix = Indrec.elimination_suffix (elimination_sort_of_goal gl)in
+        let elim =
+	  if lft2rgt then
+            pf_global gl (id_of_string (hdcncls^suffix^"_r"))
+          else
+	    pf_global gl (id_of_string (hdcncls^suffix))
+        in 
+	tclNOTSAMEGOAL (general_elim (c,l) (elim,NoBindings) ~allow_K:false) gl
+   (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal 
+      and did not fail for useless conditional rewritings generating an
+      extra condition *)
+
+(* Conditional rewriting, the success of a rewriting is related 
+   to the resolution of the conditions by a given tactic *)
+
+let conditional_rewrite lft2rgt tac (c,bl) = 
+  tclTHENSFIRSTn (general_rewrite_bindings lft2rgt (c,bl))
+    [|tclIDTAC|] (tclCOMPLETE tac)
+
+let general_rewrite lft2rgt c = general_rewrite_bindings lft2rgt (c,NoBindings)
+
+let rewriteLR_bindings = general_rewrite_bindings true
+let rewriteRL_bindings = general_rewrite_bindings false
+
+let rewriteLR = general_rewrite true
+let rewriteRL = general_rewrite false
+
+(* The Rewrite in tactic *)
+let general_rewrite_in lft2rgt id (c,l) gl =
+  let ctype = pf_type_of gl c in 
+  let env = pf_env gl in
+  let sigma = project gl in 
+  let _,t = splay_prod env sigma ctype in
+  match match_with_equation t with
+    | None -> (* Do not deal with setoids yet *) 
+        error "The term provided does not end with an equation" 
+    | Some (hdcncl,_) -> 
+        let hdcncls = string_of_inductive hdcncl in 
+	let suffix =
+          Indrec.elimination_suffix (elimination_sort_of_hyp id gl) in
+        let rwr_thm =
+          if lft2rgt then hdcncls^suffix else hdcncls^suffix^"_r" in
+        let elim =
+	  try pf_global gl (id_of_string rwr_thm)
+          with Not_found ->
+            error ("Cannot find rewrite principle "^rwr_thm) in 
+	general_elim_in id (c,l) (elim,NoBindings) gl
+
+let rewriteLRin = general_rewrite_in true
+let rewriteRLin = general_rewrite_in false
+
+let conditional_rewrite_in lft2rgt id tac (c,bl) = 
+  tclTHENSFIRSTn (general_rewrite_in lft2rgt id (c,bl))
+    [|tclIDTAC|] (tclCOMPLETE tac)
+
+let rewriteRL_clause = function
+  | None -> rewriteRL_bindings
+  | Some id -> rewriteRLin id
+
+(* Replacing tactics *)
+
+(* eqt,sym_eqt : equality on Type and its symmetry theorem
+   c2 c1 : c1 is to be replaced by c2
+   unsafe : If true, do not check that c1 and c2 are convertible
+   gl : goal *)
+
+let abstract_replace clause c2 c1 unsafe gl =
+  let t1 = pf_type_of gl c1 
+  and t2 = pf_type_of gl c2 in
+  if unsafe or (pf_conv_x gl t1 t2) then
+    let e = (build_coq_eqT_data ()).eq in
+    let sym = (build_coq_eqT_data ()).sym in
+    let eq = applist (e, [t1;c1;c2]) in
+    tclTHENS (assert_tac false Anonymous eq)
+      [onLastHyp (fun id -> 
+	tclTHEN 
+	  (tclTRY (rewriteRL_clause clause (mkVar id,NoBindings)))
+	  (clear [id]));
+       tclORELSE assumption 
+	(tclTRY (tclTHEN (apply sym) assumption))] gl
+  else
+    error "terms does not have convertible types"
+
+let replace c2 c1 gl = abstract_replace None c2 c1 false gl
+
+let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl
+
+(* End of Eduardo's code. The rest of this file could be improved
+   using the functions match_with_equation, etc that I defined
+   in Pattern.ml.
+   -- Eduardo (19/8/97)
+*)
+
+(* Tactics for equality reasoning with the "eq"  or "eqT"
+   relation This code  will work with any equivalence relation which 
+   is substitutive *)
+
+(* Patterns *)
+
+let build_coq_eq eq = eq.eq
+let build_ind eq = eq.ind
+let build_rect eq = 
+  match eq.rect with
+    | None -> assert false
+    | Some c -> c
+	  
+(*********** List of constructions depending of the initial state *)
+
+let find_eq_pattern aritysort sort = 
+  (* "eq" now accept arguments in Type and elimination to Type *)
+  Coqlib.build_coq_eq ()
+
+(* [find_positions t1 t2]
+
+   will find the positions in the two terms which are suitable for
+   discrimination, or for injection.  Obviously, if there is a
+   position which is suitable for discrimination, then we want to
+   exploit it, and not bother with injection.  So when we find a
+   position which is suitable for discrimination, we will just raise
+   an exception with that position.
+
+   So the algorithm goes like this:
+
+   if [t1] and [t2] start with the same constructor, then we can
+   continue to try to find positions in the arguments of [t1] and
+   [t2].
+
+   if [t1] and [t2] do not start with the same constructor, then we
+   have found a discrimination position
+
+   if one [t1] or [t2] do not start with a constructor and the two
+   terms are not already convertible, then we have found an injection
+   position.
+
+   A discriminating position consists of a constructor-path and a pair
+   of operators.  The constructor-path tells us how to get down to the
+   place where the two operators, which must differ, can be found.
+
+   An injecting position has two terms instead of the two operators,
+   since these terms are different, but not manifestly so.
+
+   A constructor-path is a list of pairs of (operator * int), where
+   the int (based at 0) tells us which argument of the operator we
+   descended into.
+
+ *)
+
+exception DiscrFound of
+  (constructor * int) list * constructor * constructor
+
+let find_positions env sigma t1 t2 =
+  let rec findrec posn t1 t2 =
+    let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
+    let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
+    match (kind_of_term hd1, kind_of_term hd2) with
+  	
+      | Construct sp1, Construct sp2 
+          when List.length args1 = mis_constructor_nargs_env env sp1
+          ->
+        (* both sides are fully applied constructors, so either we descend,
+           or we can discriminate here. *)
+	  if sp1 = sp2 then
+            List.flatten
+	      (list_map2_i
+		 (fun i arg1 arg2 ->
+		    findrec ((sp1,i)::posn) arg1 arg2)
+		 0 args1 args2)
+	  else
+	    raise (DiscrFound(List.rev posn,sp1,sp2))
+
+      | _ ->
+	  let t1_0 = applist (hd1,args1) 
+          and t2_0 = applist (hd2,args2) in
+          if is_conv env sigma t1_0 t2_0 then 
+	    []
+          else
+	    let ty1_0 = get_type_of env sigma t1_0 in
+	    match get_sort_family_of env sigma ty1_0 with
+	      | InSet | InType -> [(List.rev posn,t1_0,t2_0)]
+	      | InProp -> []
+	  in 
+	  (try 
+	     Inr(findrec [] t1 t2)
+	   with DiscrFound (path,c1,c2) -> 
+	     Inl (path,c1,c2))
+
+let discriminable env sigma t1 t2 =
+  match find_positions env sigma t1 t2 with
+    | Inl _ -> true
+    | _ -> false
+
+(* Once we have found a position, we need to project down to it.  If
+   we are discriminating, then we need to produce False on one of the
+   branches of the discriminator, and True on the other one.  So the
+   result type of the case-expressions is always Prop.
+
+   If we are injecting, then we need to discover the result-type.
+   This can be difficult, since the type of the two terms at the
+   injection-position can be different, and we need to find a
+   dependent sigma-type which generalizes them both.
+
+   We can get an approximation to the right type to choose by:
+
+   (0) Before beginning, we reserve a patvar for the default
+   value of the match, to be used in all the bogus branches.
+
+   (1) perform the case-splits, down to the site of the injection.  At
+   each step, we have a term which is the "head" of the next
+   case-split.  At the point when we actually reach the end of our
+   path, the "head" is the term to return.  We compute its type, and
+   then, backwards, make a sigma-type with every free debruijn
+   reference in that type.  We can be finer, and first do a S(TRONG)NF
+   on the type, so that we get the fewest number of references
+   possible.
+
+   (2) This gives us a closed type for the head, which we use for the
+   types of all the case-splits.
+
+   (3) Now, we can compute the type of one of T1, T2, and then unify
+   it with the type of the last component of the result-type, and this
+   will give us the bindings for the other arguments of the tuple.
+
+ *)
+
+(* The algorithm, then is to perform successive case-splits.  We have
+   the result-type of the case-split, and also the type of that
+   result-type.  We have a "direction" we want to follow, i.e. a
+   constructor-number, and in all other "directions", we want to juse
+   use the default-value.
+
+   After doing the case-split, we call the afterfun, with the updated
+   environment, to produce the term for the desired "direction".
+
+   The assumption is made here that the result-type is not manifestly
+   functional, so we can just use the length of the branch-type to
+   know how many lambda's to stick in.
+
+ *)
+
+(* [descend_then sigma env head dirn]
+
+   returns the number of products introduced, and the environment
+   which is active, in the body of the case-branch given by [dirn],
+   along with a continuation, which expects to be fed:
+
+    (1) the value of the body of the branch given by [dirn]
+    (2) the default-value
+
+    (3) the type of the default-value, which must also be the type of
+        the body of the [dirn] branch
+
+   the continuation then constructs the case-split.
+ *)
+let descend_then sigma env head dirn =
+  let IndType (indf,_) as indt =
+    try find_rectype env sigma (get_type_of env sigma head)
+    with Not_found -> assert false in
+  let ind,_ = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let cstr = get_constructors env indf in
+  let dirn_nlams = cstr.(dirn-1).cs_nargs in
+  let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in
+  (dirn_nlams,
+   dirn_env,
+   (fun dirnval (dfltval,resty) ->
+      let arign,_ = get_arity env indf in
+      let p = it_mkLambda_or_LetIn (lift mip.mind_nrealargs resty) arign in
+      let build_branch i =
+	let result = if i = dirn then dirnval else dfltval in
+	it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in
+      let brl =
+        List.map build_branch
+          (interval 1 (Array.length mip.mind_consnames)) in
+      let ci = make_default_case_info env RegularStyle ind in
+      mkCase (ci, p, head, Array.of_list brl)))
+  
+(* Now we need to construct the discriminator, given a discriminable
+   position.  This boils down to:
+
+   (1) If the position is directly beneath us, then we need to do a
+   case-split, with result-type Prop, and stick True and False into
+   the branches, as is convenient.
+
+   (2) If the position is not directly beneath us, then we need to
+   call descend_then, to descend one step, and then recursively
+   construct the discriminator.
+
+ *)
+
+(* [construct_discriminator env dirn headval]
+   constructs a case-split on [headval], with the [dirn]-th branch
+   giving [True], and all the rest giving False. *)
+
+let construct_discriminator sigma env dirn c sort =
+  let (IndType(indf,_) as indt) =
+    try find_rectype env sigma (type_of env sigma c)
+    with Not_found ->
+       (* one can find Rel(k) in case of dependent constructors 
+          like T := c : (A:Set)A->T and a discrimination 
+          on (c bool true) = (c bool false)
+          CP : changed assert false in a more informative error
+       *)
+      errorlabstrm "Equality.construct_discriminator"
+	(str "Cannot discriminate on inductive constructors with 
+		 dependent types") in
+  let (ind,_) = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let arsign,arsort = get_arity env indf in
+  let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in
+  let p = it_mkLambda_or_LetIn (mkSort sort_0) arsign in
+  let cstrs = get_constructors env indf in
+  let build_branch i =
+    let endpt = if i = dirn then true_0 else false_0 in
+    it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in
+  let brl =
+    List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in
+  let ci = make_default_case_info env RegularStyle ind in
+  mkCase (ci, p, c, Array.of_list brl)
+    
+let rec build_discriminator sigma env dirn c sort = function
+  | [] -> construct_discriminator sigma env dirn c sort
+  | ((sp,cnum),argnum)::l ->
+      let cty = type_of env sigma c in
+      let IndType (indf,_) =
+	try find_rectype env sigma cty with Not_found -> assert false in
+      let (ind,_) = dest_ind_family indf in
+      let (mib,mip) = lookup_mind_specif env ind in
+      let _,arsort = get_arity env indf in
+      let nparams = mip.mind_nparams  in
+      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let newc = mkRel(cnum_nlams-(argnum-nparams)) in
+      let subval = build_discriminator sigma cnum_env dirn newc sort l  in
+      kont subval (build_coq_False (),mkSort (Prop Null))
+
+let gen_absurdity id gl =
+  if is_empty_type (clause_type (onHyp id) gl)
+  then
+    simplest_elim (mkVar id) gl
+  else
+    errorlabstrm "Equality.gen_absurdity" 
+      (str "Not the negation of an equality")
+
+(* Precondition: eq is leibniz equality
+ 
+  returns ((eq_elim t t1 P i t2), absurd_term)
+  where  P=[e:t]discriminator 
+         absurd_term=False
+*)
+
+let discrimination_pf e (t,t1,t2) discriminator lbeq gls =
+  let i           = build_coq_I () in
+  let absurd_term = build_coq_False () in
+  let eq_elim     = build_ind lbeq in
+  (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term)
+
+exception NotDiscriminable
+
+let discr id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let sort = pf_type_of gls (pf_concl gls) in 
+  let (lbeq,(t,t1,t2)) =
+    try find_eq_data_decompose eqn
+    with PatternMatchingFailure ->
+      errorlabstrm "discr" (pr_id id ++ str": not a primitive equality here")
+  in
+  let sigma = project gls in
+  let env = pf_env gls in
+  (match find_positions env sigma t1 t2 with
+     | Inr _ ->
+	 errorlabstrm "discr" (str" Not a discriminable equality")
+     | Inl (cpath, (_,dirn), _) ->
+	 let e = pf_get_new_id (id_of_string "ee") gls in
+	 let e_env = push_named (e,None,t) env in
+	 let discriminator =
+	   build_discriminator sigma e_env dirn (mkVar e) sort cpath in
+	 let (indt,_) = find_mrectype env sigma t in 
+	 let (pf, absurd_term) =
+	   discrimination_pf e (t,t1,t2) discriminator lbeq gls 
+	 in
+	 tclCOMPLETE((tclTHENS (cut_intro absurd_term)
+			([onLastHyp gen_absurdity;
+			  refine (mkApp (pf, [| mkVar id |]))]))) gls)
+
+
+let not_found_message id =
+  (str "The variable" ++ spc () ++ str (string_of_id id) ++ spc () ++
+    str" was not found in the current environment")
+
+let onNegatedEquality tac gls =
+  if is_matching_not (pf_concl gls) then
+    (tclTHEN (tclTHEN hnf_in_concl intro) (onLastHyp tac)) gls
+  else if is_matching_imp_False (pf_concl gls)then
+    (tclTHEN intro (onLastHyp tac)) gls
+  else 
+    errorlabstrm "extract_negated_equality_then"
+      (str"The goal should negate an equality")
+
+
+let discrSimpleClause = function
+  | None -> onNegatedEquality discr
+  | Some (id,_,_) -> discr id
+
+let discrClause = onClauses discrSimpleClause
+
+let discrEverywhere = 
+  tclORELSE
+    (Tacticals.tryAllClauses discrSimpleClause)
+    (fun gls -> 
+       errorlabstrm "DiscrEverywhere" (str" No discriminable equalities"))
+
+let discr_tac = function
+  | None -> discrEverywhere
+  | Some id -> try_intros_until discr id
+
+let discrConcl gls  = discrClause onConcl gls
+let discrHyp id gls = discrClause (onHyp id) gls
+
+(* returns the sigma type (sigS, sigT) with the respective
+    constructor depending on the sort *)
+
+let find_sigma_data s =
+  match s with  
+    | Prop Pos  -> build_sigma_set ()                    (* Set *) 
+    | Type _    -> build_sigma_type ()                   (* Type *)
+    | Prop Null -> error "find_sigma_data"
+
+(* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
+   index bound in [rty]
+
+   Then we build the term
+
+     [(existS A P (mkRel lind) rterm)] of type [(sigS A P)]
+
+   where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}]
+ *)
+
+let make_tuple env sigma (rterm,rty) lind =
+  assert (dependent (mkRel lind) rty);
+  let {intro = exist_term; typ = sig_term} =
+    find_sigma_data (get_sort_of env sigma rty) in
+  let a = type_of env sigma (mkRel lind) in
+  let (na,_,_) = lookup_rel lind env in
+  (* We move [lind] to [1] and lift other rels > [lind] by 1 *)
+  let rty = lift (1-lind) (liftn lind (lind+1) rty) in
+  (* Now [lind] is [mkRel 1] and we abstract on (na:a) *)
+  let p = mkLambda (na, a, rty) in
+  (applist(exist_term,[a;p;(mkRel lind);rterm]),
+   applist(sig_term,[a;p]))
+
+(* check that the free-references of the type of [c] are contained in
+   the free-references of the normal-form of that type.  If the normal
+   form of the type contains fewer references, we want to return that
+   instead. *)
+
+let minimal_free_rels env sigma (c,cty) =
+  let cty_rels = free_rels cty in
+  let nf_cty = nf_betadeltaiota env sigma cty in
+  let nf_rels = free_rels nf_cty in
+  if Intset.subset cty_rels nf_rels then
+    (cty,cty_rels)
+  else
+    (nf_cty,nf_rels)
+
+(* [sig_clausal_form siglen ty]
+    
+   Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the 
+   type of ty), and return:
+
+   (1) a pattern, with meta-variables in it for various arguments,
+       which, when the metavariables are replaced with appropriate
+       terms, will have type [ty]
+
+   (2) an integer, which is the last argument - the one which we just
+       returned.
+
+   (3) a pattern, for the type of that last meta
+
+   (4) a typing for each patvar
+
+   WARNING: No checking is done to make sure that the 
+            sigS(or sigT)'s are actually there.
+          - Only homogenious pairs are built i.e. pairs where all the 
+   dependencies are of the same sort
+
+   [sig_clausal_form] proceed as follows: the default tuple is
+   constructed by taking the tuple-type, exploding the first [tuplen]
+   [sigS]'s, and replacing at each step the binder in the
+   right-hand-type by a fresh metavariable. In addition, on the way
+   back out, we will construct the pattern for the tuple which uses
+   these meta-vars.
+
+   This gives us a pattern, which we use to match against the type of
+   [dflt]; if that fails, then against the S(TRONG)NF of that type.  If
+   both fail, then we just cannot construct our tuple.  If one of
+   those succeed, then we can construct our value easily - we just use
+   the tuple-pattern.
+
+ *)
+
+let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) =
+  let { intro = exist_term } = find_sigma_data sort_of_ty in 
+  let isevars = Evarutil.create_evar_defs sigma in
+  let rec sigrec_clausal_form siglen p_i =
+    if siglen = 0 then
+      if Evarconv.the_conv_x env isevars p_i dFLTty then
+	(* the_conv_x had a side-effect on isevars *)
+	dFLT
+      else
+	error "Cannot solve an unification problem"
+    else
+      let (a,p_i_minus_1) = match whd_beta_stack p_i with
+	| (_sigS,[a;p]) -> (a,p)
+ 	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
+      let ev = Evarutil.new_isevar isevars env (dummy_loc,InternalHole)
+	(Evarutil.new_Type ()) in
+      let rty = beta_applist(p_i_minus_1,[ev]) in
+      let tuple_tail = sigrec_clausal_form (siglen-1) rty in
+      match
+	Instantiate.existential_opt_value (Evarutil.evars_of isevars) 
+	(destEvar ev)
+      with
+	| Some w -> applist(exist_term,[a;p_i_minus_1;w;tuple_tail])
+	| None -> anomaly "Not enough components to build the dependent tuple"
+  in
+  let scf = sigrec_clausal_form siglen ty in
+  Evarutil.nf_evar (Evarutil.evars_of isevars) scf
+
+(* The problem is to build a destructor (a generalization of the
+   predecessor) which, when applied to a term made of constructors
+   (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given
+   subterm of the term (say [term]).
+
+   Let [typ] be the type of [term]. If [term] has no dependencies in
+   the [e1], [e2], etc, then all is simple. If not, then we need to
+   encapsulated the dependencies into a dependent tuple in such a way
+   that the destructor has not a dependent type and rewriting can then
+   be applied. The destructor has the form
+
+   [e]Cases e of
+      | ...
+      | Ci (x1,x2,...) =>
+          Cases x2 of
+          | ...
+          | Cj (y1,y2,...) =>
+              Cases y2 of
+              | ...
+              | Ck (...,z,...) => z
+              | ... end
+          | ... end
+      | ... end
+
+   and the dependencies is expressed by the fact that [z] has a type
+   dependent in the x1, y1, ...
+
+   Assume [z] is typed as follows: env |- z:zty
+
+   If [zty] has no dependencies, this is simple. Otherwise, assume
+   [zty] has free (de Bruijn) variables in,...i1 then the role of
+   [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the
+   tuple
+
+   [existS [xn]Pn Rel(in) .. (existS [x2]P2 Rel(i2) (existS [x1]P1 Rel(i1) z))]
+
+   where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc.
+
+   To do this, we find the free (relative) references of the strong NF
+   of [z]'s type, gather them together in left-to-right order
+   (i.e. highest-numbered is farthest-left), and construct a big
+   iterated pair out of it. This only works when the references are
+   all themselves to members of [Set]s, because we use [sigS] to
+   construct the tuple.
+
+   Suppose now that our constructed tuple is of length [tuplen]. We
+   need also to construct a default value for the other branches of
+   the destructor. As default value, we take a tuple of the form
+
+    [existS [xn]Pn ?n (... existS [x2]P2 ?2 (existS [x1]P1 ?1 term))]
+
+   but for this we have to solve the following unification problem:
+
+     typ = zty[i1/?1;...;in/?n]
+
+   This is done by [sig_clausal_form].
+ *)
+
+let make_iterated_tuple env sigma dflt (z,zty) =
+  let (zty,rels) = minimal_free_rels env sigma (z,zty) in
+  let sort_of_zty = get_sort_of env sigma zty in
+  let sorted_rels = Sort.list (<) (Intset.elements rels) in
+  let (tuple,tuplety) =
+    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels 
+  in
+  assert (closed0 tuplety);
+  let n = List.length sorted_rels in
+  let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
+  (tuple,tuplety,dfltval)
+
+let rec build_injrec sigma env (t1,t2) c = function
+  | [] ->
+      make_iterated_tuple env sigma (t1,type_of env sigma t1)
+        (c,type_of env sigma c)
+  | ((sp,cnum),argnum)::l ->
+      let cty = type_of env sigma c in
+      let (ity,_) = find_mrectype env sigma cty in
+      let (mib,mip) = lookup_mind_specif env ity in
+      let nparams = mip.mind_nparams in
+      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let newc = mkRel(cnum_nlams-(argnum-nparams)) in
+      let (subval,tuplety,dfltval) =
+      	build_injrec sigma cnum_env (t1,t2) newc l
+      in
+      (kont subval (dfltval,tuplety),
+       tuplety,dfltval)
+
+let build_injector sigma env (t1,t2) c cpath =
+  let (injcode,resty,_) = build_injrec sigma env (t1,t2) c cpath in
+  (injcode,resty)
+
+let try_delta_expand env sigma t =
+  let whdt = whd_betadeltaiota env sigma t  in 
+  let rec hd_rec c  =
+    match kind_of_term c with
+      | Construct _ -> whdt
+      | App (f,_)  -> hd_rec f
+      | Cast (c,_) -> hd_rec c
+      | _  -> t
+  in 
+  hd_rec whdt 
+
+(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it 
+   expands then only when the whdnf has a constructor of an inductive type
+   in hd position, otherwise delta expansion is not done *)
+
+let inj id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let (eq,(t,t1,t2))= 
+    try find_eq_data_decompose eqn
+    with PatternMatchingFailure ->
+      errorlabstrm "Inj" (pr_id id ++ str": not a primitive equality here") 
+  in
+  let sigma = project gls in
+  let env = pf_env gls in
+  match find_positions env sigma t1 t2 with
+    | Inl _ ->
+	errorlabstrm "Inj"
+	  (str (string_of_id id) ++
+	    str" is not a projectable equality but a discriminable one")
+    | Inr [] ->
+	errorlabstrm "Equality.inj" 
+	   (str"Nothing to do, it is an equality between convertible terms")
+    | Inr posns ->
+	let e = pf_get_new_id (id_of_string "e") gls in
+	let e_env = push_named (e,None,t) env in
+	let injectors =
+	  map_succeed
+	    (fun (cpath,t1_0,t2_0) ->
+	      try 
+		let (injbody,resty) =
+		  build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in
+		let injfun = mkNamedLambda e t injbody in
+		let _ = type_of env sigma injfun in (injfun,resty)
+	      with e when catchable_exception e ->
+		(* may fail because ill-typed or because of a Prop argument *)
+		(* error "find_sigma_data" *)
+		failwith "caught")
+            posns
+	in
+	if injectors = [] then
+	  errorlabstrm "Equality.inj" 
+	    (str "Failed to decompose the equality");
+	tclMAP 
+	  (fun (injfun,resty) ->
+	     let pf = applist(eq.congr,
+			      [t;resty;injfun;
+			       try_delta_expand env sigma t1;
+			       try_delta_expand env sigma t2;
+			       mkVar id]) 
+	     in
+	     let ty =
+	       try pf_nf gls (pf_type_of gls pf)
+               with
+		 | UserError("refiner__fail",_) -> 
+		     errorlabstrm "InjClause" 
+		(str (string_of_id id) ++ str" Not a projectable equality")
+	     in ((tclTHENS  (cut  ty) ([tclIDTAC;refine pf]))))
+	  injectors
+	  gls
+	    
+let injClause = function
+  | None -> onNegatedEquality inj
+  | Some id -> try_intros_until inj id
+
+let injConcl gls  = injClause None gls
+let injHyp id gls = injClause (Some id) gls
+
+let decompEqThen ntac id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let (lbeq,(t,t1,t2))= find_eq_data_decompose eqn in
+  let sort = pf_type_of gls (pf_concl gls) in 
+  let sigma = project gls in
+  let env = pf_env gls in 
+  (match find_positions env sigma t1 t2 with
+     | Inl (cpath, (_,dirn), _) ->
+	 let e = pf_get_new_id (id_of_string "e") gls in
+	 let e_env = push_named (e,None,t) env in
+	 let discriminator =
+	   build_discriminator sigma e_env dirn (mkVar e) sort cpath in
+	 let (pf, absurd_term) =
+	   discrimination_pf e (t,t1,t2) discriminator lbeq gls in
+	 tclCOMPLETE
+	   ((tclTHENS (cut_intro absurd_term)
+	       ([onLastHyp gen_absurdity;
+		 refine (mkApp (pf, [| mkVar id |]))]))) gls
+     | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
+         ntac 0 gls
+     | Inr posns ->
+	 (let e = pf_get_new_id (id_of_string "e") gls in
+	  let e_env = push_named (e,None,t) env in
+	  let injectors =
+	    map_succeed
+	      (fun (cpath,t1_0,t2_0) ->
+		 let (injbody,resty) =
+		   build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in
+		 let injfun = mkNamedLambda e t injbody in
+		 try 
+		   let _ = type_of env sigma injfun in (injfun,resty)
+		 with e when catchable_exception e -> failwith "caught")
+	      posns 
+	  in
+	  if injectors = [] then
+	    errorlabstrm "Equality.decompEqThen" 
+              (str "Discriminate failed to decompose the equality");
+	  (tclTHEN
+	      (tclMAP (fun (injfun,resty) ->
+			 let pf = applist(lbeq.congr,
+					  [t;resty;injfun;t1;t2;
+					   mkVar id]) in
+			 let ty = pf_nf gls (pf_type_of gls pf) in
+			 ((tclTHENS (cut ty) 
+			     ([tclIDTAC;refine pf]))))
+		 (List.rev injectors))
+	      (ntac (List.length injectors)))
+	  gls))
+
+let decompEq = decompEqThen (fun x -> tclIDTAC)
+
+let dEqThen ntac = function
+  | None -> onNegatedEquality (decompEqThen ntac)
+  | Some id -> try_intros_until (decompEqThen ntac) id
+
+let dEq = dEqThen (fun x -> tclIDTAC)
+
+let dEqConcl gls = dEq None gls
+let dEqHyp id gls = dEq (Some id) gls
+
+let rewrite_msg = function 
+  | None -> str "passed term is not a primitive equality" 
+  | Some id -> pr_id id ++ str "does not satisfy preconditions "
+
+let swap_equands gls eqn =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in 
+  applist(lbeq.eq,[t;e2;e1])
+
+let swapEquandsInConcl gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose (pf_concl gls) in
+  let sym_equal = lbeq.sym in
+  refine (applist(sym_equal,[t;e2;e1;mkMeta (Clenv.new_meta())])) gls
+
+let swapEquandsInHyp id gls =
+  ((tclTHENS (cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id)))
+      ([tclIDTAC;
+      	(tclTHEN (swapEquandsInConcl) (exact_no_check (mkVar id)))]))) gls
+
+(* find_elim determines which elimination principle is necessary to
+   eliminate lbeq on sort_of_gl. It yields the boolean true wether
+   it is a dependent elimination principle (as idT.rect) and false
+   otherwise *)
+
+let find_elim  sort_of_gl  lbeq =
+  match kind_of_term sort_of_gl  with
+    | Sort(Prop Null)  (* Prop *)  -> (lbeq.ind, false)  
+    | Sort(Prop Pos)   (* Set *)   ->  
+	(match lbeq.rrec with
+           | Some eq_rec -> (eq_rec, false) 
+	   | None -> errorlabstrm "find_elim"
+		 (str "this type of elimination is not allowed"))
+    | _ (* Type *) -> 
+        (match lbeq.rect with
+           | Some eq_rect -> (eq_rect, true) 
+           | None -> errorlabstrm "find_elim"
+		 (str "this type of elimination is not allowed"))
+
+(* builds a predicate [e:t][H:(lbeq t e t1)](body e)
+   to be used as an argument for equality dependent elimination principle:
+   Preconditon: dependent body (mkRel 1) *)
+
+let build_dependent_rewrite_predicate (t,t1,t2) body lbeq gls =
+  let e = pf_get_new_id  (id_of_string "e") gls in 
+  let h = pf_get_new_id  (id_of_string "HH") gls in 
+  let eq_term = lbeq.eq in
+  (mkNamedLambda e t 
+     (mkNamedLambda h (applist (eq_term, [t;t1;(mkRel 1)])) 
+        (lift 1 body))) 
+
+(* builds a predicate [e:t](body e) ???
+   to be used as an argument for equality non-dependent elimination principle:
+   Preconditon: dependent body (mkRel 1) *)
+
+let build_non_dependent_rewrite_predicate (t,t1,t2) body gls =
+  lambda_create (pf_env gls) (t,body)
+
+let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
+  let (eq_elim,dep) =
+    try 
+      find_elim (pf_type_of gls (pf_concl gls)) lbeq  
+    with e when catchable_exception e -> 
+      errorlabstrm "RevSubstIncConcl"
+        (str "this type of substitution is not allowed")  
+  in 
+  let p =
+    if dep then
+      (build_dependent_rewrite_predicate (t,e1,e2)  body lbeq gls)
+    else
+      (build_non_dependent_rewrite_predicate (t,e1,e2)  body  gls)
+  in
+  refine (applist(eq_elim,[t;e1;p;mkMeta(Clenv.new_meta());
+                           e2;mkMeta(Clenv.new_meta())])) gls
+
+(* [subst_tuple_term dep_pair B]
+
+   Given that dep_pair looks like:
+
+   (existS e1 (existS e2 ... (existS en en+1) ... ))
+
+   and B might contain instances of the ei, we will return the term:
+
+   ([x1:ty(e1)]...[xn:ty(en)]B
+    (projS1 (mkRel 1))
+    (projS1 (projS2 (mkRel 1)))
+    ... etc ...)
+
+   That is, we will abstract out the terms e1...en+1 as usual, but
+   will then produce a term in which the abstraction is on a single
+   term - the debruijn index [mkRel 1], which will be of the same type
+   as dep_pair.
+
+   ALGORITHM for abstraction:
+
+   We have a list of terms, [e1]...[en+1], which we want to abstract
+   out of [B].  For each term [ei], going backwards from [n+1], we
+   just do a [subst_term], and then do a lambda-abstraction to the
+   type of the [ei].
+
+ *)
+
+let decomp_tuple_term env c t = 
+  let rec decomprec inner_code ex exty =
+    try
+      let {proj1 = p1; proj2 = p2 },(a,p,car,cdr) =
+	find_sigma_data_decompose ex in
+      let car_code = applist (p1,[a;p;inner_code])
+      and cdr_code = applist (p2,[a;p;inner_code]) in
+      let cdrtyp = beta_applist (p,[car]) in
+      ((car,a),car_code)::(decomprec cdr_code cdr cdrtyp)
+    with PatternMatchingFailure ->
+      [((ex,exty),inner_code)]
+  in
+  List.split (decomprec (mkRel 1) c t)
+
+let subst_tuple_term env sigma dep_pair b =
+  let typ = get_type_of env sigma dep_pair in
+  let e_list,proj_list = decomp_tuple_term env dep_pair typ in
+  let abst_B =
+    List.fold_right
+      (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in
+  let app_B = applist(abst_B,proj_list) in app_B
+    
+(* |- (P e2)
+     BY RevSubstInConcl (eq T e1 e2)
+     |- (P e1)
+     |- (eq T e1 e2)
+ *)
+(* Redondant avec Replace ! *)
+
+let substInConcl_RL eqn gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in
+  let body = subst_tuple_term (pf_env gls) (project gls) e2 (pf_concl gls) in
+  assert (dependent (mkRel 1) body);
+  bareRevSubstInConcl lbeq body (t,e1,e2) gls
+
+(* |- (P e1)
+     BY SubstInConcl (eq T e1 e2)
+     |- (P e2)
+     |- (eq T e1 e2)
+ *)
+let substInConcl_LR eqn gls =
+  (tclTHENS (substInConcl_RL (swap_equands gls eqn))
+     ([tclIDTAC;
+       swapEquandsInConcl])) gls
+
+let substInConcl l2r = if l2r then substInConcl_LR else substInConcl_RL
+
+let substInHyp_LR eqn id gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in 
+  let body = subst_term e1 (pf_get_hyp_typ gls id) in
+  if not (dependent (mkRel 1) body) then errorlabstrm  "SubstInHyp" (mt ());
+  (tclTHENS (cut_replacing id (subst1 e2 body))
+     ([tclIDTAC;
+       (tclTHENS (bareRevSubstInConcl lbeq body (t,e1,e2))
+          ([exact_no_check (mkVar id);tclIDTAC]))])) gls
+
+let substInHyp_RL eqn id gls =
+  (tclTHENS (substInHyp_LR (swap_equands gls eqn) id)
+     ([tclIDTAC;
+       swapEquandsInConcl])) gls
+
+let substInHyp l2r = if l2r then substInHyp_LR else substInHyp_RL
+
+let try_rewrite tac gls =
+  try 
+    tac gls
+  with 
+    | PatternMatchingFailure ->
+	errorlabstrm "try_rewrite" (str "Not a primitive equality here")
+    | e when catchable_exception e -> 
+	errorlabstrm "try_rewrite"
+          (str "Cannot find a well-typed generalization of the goal that" ++
+             str " makes the proof progress")
+
+let subst l2r eqn cls gls =
+  match cls with
+    | None ->    substInConcl l2r eqn gls
+    | Some id -> substInHyp l2r eqn id gls
+
+(* |- (P a)
+ * SubstConcl_LR a=b 
+ *  |- (P b)
+ *  |- a=b
+ *)
+
+let substConcl l2r eqn gls = try_rewrite (subst l2r eqn None) gls
+let substConcl_LR = substConcl true
+
+(* id:(P a) |- G
+ * SubstHyp a=b id
+ *  id:(P b) |- G
+ *  id:(P a) |-a=b
+*)
+
+let hypSubst l2r id cls gls =
+  onClauses (function
+    | None -> 
+	(tclTHENS (substInConcl l2r (pf_get_hyp_typ gls id))
+	   ([tclIDTAC; exact_no_check (mkVar id)]))
+    | Some (hypid,_,_) -> 
+	(tclTHENS (substInHyp l2r (pf_get_hyp_typ gls id) hypid)
+	   ([tclIDTAC;exact_no_check (mkVar id)])))
+    cls gls
+
+let hypSubst_LR = hypSubst true
+
+(* id:a=b |- (P a)
+ * HypSubst id.
+ *  id:a=b |- (P b)
+ *)
+let substHypInConcl l2r id gls = try_rewrite (hypSubst l2r id onConcl) gls
+let substHypInConcl_LR = substHypInConcl true
+
+(* id:a=b H:(P a) |- G
+   SubstHypInHyp id H.
+    id:a=b H:(P b) |- G
+*)
+(* |- (P b)
+   SubstConcl_RL a=b
+     |- (P a)
+     |- a=b
+*)
+let substConcl_RL = substConcl false
+
+(* id:(P b) |-G
+   SubstHyp_RL a=b id 
+      id:(P a) |- G
+      |- a=b  
+*)
+let substHyp l2r eqn id gls = try_rewrite (subst l2r eqn (Some id)) gls
+let substHyp_RL = substHyp false
+
+let hypSubst_RL = hypSubst false
+
+(* id:a=b |- (P b)
+ * HypSubst id.
+ * id:a=b |- (P a)
+ *)
+let substHypInConcl_RL = substHypInConcl false
+
+(* id:a=b H:(P b) |- G
+   SubstHypInHyp id H.
+    id:a=b H:(P a) |- G
+*)
+
+(* Substitutions tactics (JCF) *)
+
+let unfold_body x gl =
+  let hyps = pf_hyps gl in
+  let xval =
+    match Sign.lookup_named x hyps with
+        (_,Some xval,_) -> xval
+      | _ -> errorlabstrm "unfold_body"
+          (pr_id x ++ str" is not a defined hypothesis") in
+  let aft = afterHyp x gl in
+  let hl = List.fold_right
+    (fun (y,yval,_) cl -> (y,[],(InHyp,ref None)) :: cl) aft [] in
+  let xvar = mkVar x in
+  let rfun _ _ c = replace_term xvar xval c in
+  tclTHENLIST
+    [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
+     reduct_in_concl rfun] gl
+
+
+
+
+exception FoundHyp of (identifier * constr * bool)
+
+(* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *)
+let is_eq_x x (id,_,c) =
+  try
+    let (_,lhs,rhs) = snd (find_eq_data_decompose c) in
+    if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
+  with PatternMatchingFailure ->
+    ()
+
+let subst_one x gl = 
+  let hyps = pf_hyps gl in
+  let (_,xval,_) = pf_get_hyp gl x in
+  (* If x has a body, simply replace x with body and clear x *)
+  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
+  (* x is a variable: *)
+  let varx = mkVar x in
+  (* Find a non-recursive definition for x *)
+  let (hyp,rhs,dir) = 
+    try
+      let test hyp _ = is_eq_x varx hyp in
+      Sign.fold_named_context test ~init:() hyps;
+      errorlabstrm "Subst"
+        (str "cannot find any non-recursive equality over " ++ pr_id x)
+    with FoundHyp res -> res
+  in
+  (* The set of hypotheses using x *)
+  let depdecls = 
+    let test (id,_,c as dcl) = 
+      if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
+      else failwith "caught" in
+    List.rev (map_succeed test hyps) in
+  let dephyps = List.map (fun (id,_,_) -> id) depdecls in
+  (* Decides if x appears in conclusion *)
+  let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
+  (* The set of non-defined hypothesis: they must be abstracted,
+     rewritten and reintroduced *)
+  let abshyps =
+    map_succeed
+      (fun (id,v,_) -> if v=None then mkVar id else failwith "caught")
+      depdecls in
+  (* a tactic that either introduce an abstracted and rewritten hyp,
+     or introduce a definition where x was replaced *)
+  let introtac = function
+      (id,None,_) -> intro_using id
+    | (id,Some hval,htyp) ->
+        forward true (Name id) (mkCast(replace_term varx rhs hval,
+                                       replace_term varx rhs htyp)) in
+  let need_rewrite = dephyps <> [] || depconcl in
+  tclTHENLIST 
+    ((if need_rewrite then
+      [generalize abshyps;
+       (if dir then rewriteLR else rewriteRL) (mkVar hyp);
+       thin dephyps;
+       tclMAP introtac depdecls]
+    else
+      [thin dephyps;
+       tclMAP introtac depdecls]) @
+     [tclTRY (clear [x;hyp])]) gl
+
+let subst = tclMAP subst_one
+
+let subst_all gl =
+  let test (_,c) =
+    try
+      let (_,x,y) = snd (find_eq_data_decompose c) in
+      match kind_of_term x with Var x -> x | _ -> 
+      match kind_of_term y with Var y -> y | _ -> failwith "caught"
+    with PatternMatchingFailure -> failwith "caught"
+  in
+  let ids = map_succeed test (pf_hyps_types gl) in
+  let ids = list_uniquize ids in
+  subst ids gl
+
+(* Rewrite the first assumption for which the condition faildir does not fail 
+   and gives the direction of the rewrite *)
+
+let rewrite_assumption_cond faildir gl =
+   let rec arec = function
+      | [] -> error "No such assumption"
+      | (id,_,t)::rest -> 
+	  (try let dir = faildir t gl in 
+	       general_rewrite dir (mkVar id) gl
+	   with Failure _ | UserError _  ->  arec rest)
+   in arec (pf_hyps gl)
+
+
+let rewrite_assumption_cond_in faildir hyp gl =
+   let rec arec = function
+      | [] -> error "No such assumption"
+      | (id,_,t)::rest -> 
+	  (try let dir = faildir t gl in 
+	       general_rewrite_in dir hyp ((mkVar id),NoBindings) gl
+	   with Failure _ | UserError _ ->  arec rest)
+   in arec (pf_hyps gl)
+
+let cond_eq_term_left c t gl =
+  try
+    let (_,x,_) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then true else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let cond_eq_term_right c t gl = 
+  try
+    let (_,_,x) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then false else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let cond_eq_term c t gl = 
+  try
+    let (_,x,y) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then true 
+    else if pf_conv_x gl c y then false
+    else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let replace_term_left t = rewrite_assumption_cond (cond_eq_term_left t)
+
+let replace_term_right t = rewrite_assumption_cond (cond_eq_term_right t)
+   
+let replace_term t = rewrite_assumption_cond (cond_eq_term t)
+   
+let replace_term_in_left t = rewrite_assumption_cond_in (cond_eq_term_left t)
+
+let replace_term_in_right t = rewrite_assumption_cond_in (cond_eq_term_right t)
+   
+let replace_term_in t = rewrite_assumption_cond_in (cond_eq_term t)
diff --git a/tactics/equality.mli b/tactics/equality.mli
new file mode 100644
index 00000000..ab439c39
--- /dev/null
+++ b/tactics/equality.mli
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: equality.mli,v 1.26.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Evd
+open Environ
+open Proof_type
+open Tacmach
+open Hipattern
+open Pattern
+open Tacticals
+open Tactics
+open Tacexpr
+open Rawterm
+(*i*)
+
+val find_eq_pattern : sorts -> sorts -> constr
+
+val general_rewrite_bindings : bool -> constr with_bindings -> tactic
+val general_rewrite          : bool -> constr -> tactic
+val rewriteLR_bindings       : constr with_bindings -> tactic
+val rewriteRL_bindings       : constr with_bindings -> tactic
+
+val rewriteLR   : constr -> tactic
+val rewriteRL   : constr  -> tactic
+
+val conditional_rewrite : bool -> tactic -> constr with_bindings -> tactic
+val general_rewrite_in : bool -> identifier -> constr with_bindings -> tactic
+val conditional_rewrite_in :
+  bool -> identifier -> tactic -> constr with_bindings -> tactic
+
+val replace    : constr -> constr -> tactic
+val replace_in : identifier -> constr -> constr -> tactic
+
+val discr        : identifier -> tactic
+val discrConcl   : tactic
+val discrClause  : clause -> tactic
+val discrHyp     : identifier -> tactic
+val discrEverywhere     : tactic
+val discr_tac    : quantified_hypothesis option -> tactic
+val inj          : identifier -> tactic
+val injClause    : quantified_hypothesis option -> tactic
+
+val dEq : quantified_hypothesis option -> tactic
+val dEqThen : (int -> tactic) -> quantified_hypothesis option -> tactic
+
+val make_iterated_tuple : 
+  env -> evar_map -> (constr * constr) -> (constr * constr) 
+    -> constr * constr * constr
+
+val substHypInConcl : bool -> identifier -> tactic
+val substConcl : bool -> constr -> tactic
+val substHyp : bool -> constr -> identifier -> tactic
+
+val hypSubst_LR : identifier -> clause -> tactic
+val hypSubst_RL : identifier -> clause -> tactic
+
+val discriminable : env -> evar_map -> constr -> constr -> bool
+
+(* Subst *)
+
+val unfold_body : identifier -> tactic
+
+val subst : identifier list -> tactic
+val subst_all : tactic
+
+(* Replace term *)
+val replace_term_left : constr -> tactic
+val replace_term_right : constr -> tactic
+val replace_term : constr -> tactic
+val replace_term_in_left : constr -> identifier -> tactic
+val replace_term_in_right : constr -> identifier -> tactic
+val replace_term_in : constr -> identifier -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
new file mode 100644
index 00000000..34348834
--- /dev/null
+++ b/tactics/extraargs.ml4
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: extraargs.ml4,v 1.5.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Pcoq
+open Genarg
+
+(* Rewriting orientation *)
+
+let _ = Metasyntax.add_token_obj "<-"
+let _ = Metasyntax.add_token_obj "->"
+
+let pr_orient _prc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
+| [ "->" ] -> [ true ]
+| [ "<-" ] -> [ false ]
+| [ ] -> [ true ]
+END
+
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
new file mode 100644
index 00000000..60a1ddc5
--- /dev/null
+++ b/tactics/extraargs.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: extraargs.mli,v 1.3.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Tacexpr
+open Term
+open Proof_type
+open Topconstr
+
+val rawwit_orient : bool raw_abstract_argument_type
+val wit_orient : bool closed_abstract_argument_type
+val orient : bool Pcoq.Gram.Entry.e
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
new file mode 100644
index 00000000..1dbf84ab
--- /dev/null
+++ b/tactics/extratactics.ml4
@@ -0,0 +1,329 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: extratactics.ml4,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Pcoq
+open Genarg
+open Extraargs
+
+(* Equality *)
+open Equality
+
+TACTIC EXTEND Rewrite
+  [ "Rewrite" orient(b) constr_with_bindings(c) ] -> [general_rewrite_bindings b c]
+END
+
+TACTIC EXTEND RewriteIn
+ [ "Rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] ->
+ [general_rewrite_in b h c]
+END
+
+let h_rewriteLR x = h_rewrite true (x,Rawterm.NoBindings)
+
+TACTIC EXTEND Replace
+  [ "Replace" constr(c1) "with" constr(c2) ] -> [ replace c1 c2 ]
+END
+
+TACTIC EXTEND ReplaceIn
+  [ "Replace" constr(c1) "with" constr(c2) "in" hyp(h) ] ->
+    [ replace_in h c1 c2 ]
+END
+
+TACTIC EXTEND Replacetermleft
+  [ "Replace" "->" constr(c)  ] -> [ replace_term_left c ]
+END
+
+TACTIC EXTEND Replacetermright
+  [ "Replace" "<-" constr(c)  ] -> [ replace_term_right c ]
+END
+
+TACTIC EXTEND Replaceterm
+  [ "Replace" constr(c)  ] -> [ replace_term c ]
+END
+
+TACTIC EXTEND ReplacetermInleft
+  [ "Replace"  "->" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in_left c h ]
+END
+
+TACTIC EXTEND ReplacetermInright
+  [ "Replace"  "<-" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in_right c h ]
+END
+
+TACTIC EXTEND ReplacetermIn
+  [ "Replace" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in c h ]
+END
+
+TACTIC EXTEND DEq
+  [ "Simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ]
+END
+
+TACTIC EXTEND Discriminate
+  [ "Discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ]
+END
+
+let h_discrHyp id = h_discriminate (Some id)
+
+TACTIC EXTEND Injection
+  [ "Injection" quantified_hypothesis_opt(h) ] -> [ injClause h ]
+END
+
+let h_injHyp id = h_injection (Some id)
+
+TACTIC EXTEND ConditionalRewrite
+  [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) ]
+    -> [ conditional_rewrite b (snd tac) c ]
+END
+
+TACTIC EXTEND ConditionalRewriteIn
+  [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c)
+    "in" hyp(h) ]
+    -> [ conditional_rewrite_in b h (snd tac) c ]
+END
+
+TACTIC EXTEND DependentRewrite
+| [ "Dependent" "Rewrite" orient(b) hyp(id) ] -> [ substHypInConcl b id ]
+| [ "CutRewrite" orient(b) constr(eqn) ] -> [ substConcl b eqn ]
+| [ "CutRewrite" orient(b) constr(eqn) "in" hyp(id) ]
+      -> [ substHyp b eqn id ]
+END
+
+(* Contradiction *)
+open Contradiction
+
+TACTIC EXTEND Absurd
+ [ "Absurd" constr(c) ] -> [ absurd c ]
+END
+
+TACTIC EXTEND Contradiction
+ [ "Contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ]
+END
+
+(* AutoRewrite *)
+
+open Autorewrite
+TACTIC EXTEND AutorewriteV7
+  [ "AutoRewrite" "[" ne_preident_list(l) "]" ] ->
+    [ autorewrite Refiner.tclIDTAC l ]
+| [ "AutoRewrite" "[" ne_preident_list(l) "]" "using" tactic(t) ] ->
+    [ autorewrite (snd t) l ]
+END
+TACTIC EXTEND AutorewriteV8
+  [ "AutoRewrite" "with" ne_preident_list(l) ] ->
+    [ autorewrite Refiner.tclIDTAC l ]
+| [ "AutoRewrite" "with" ne_preident_list(l) "using" tactic(t) ] ->
+    [ autorewrite (snd t) l ]
+END
+
+let add_rewrite_hint name ort t lcsr =
+  let env = Global.env() and sigma = Evd.empty in
+  let f c = Constrintern.interp_constr sigma env c, ort, t in
+  add_rew_rules name (List.map f lcsr)
+
+(* V7 *)
+VERNAC COMMAND EXTEND HintRewriteV7
+  [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) ] ->
+  [ add_rewrite_hint b o (Tacexpr.TacId "") l ]
+| [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b)
+    "using" tactic(t) ] ->
+  [ add_rewrite_hint b o t l ]
+END
+
+(* V8 *)
+VERNAC COMMAND EXTEND HintRewriteV8
+  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] ->
+  [ add_rewrite_hint b o (Tacexpr.TacId "") l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
+    ":" preident(b) ] ->
+  [ add_rewrite_hint b o t l ]
+END
+
+
+(* Refine *)
+
+open Refine
+
+TACTIC EXTEND Refine
+  [ "Refine" castedopenconstr(c) ] -> [ refine c ]
+END
+
+let refine_tac = h_refine
+
+(* Setoid_replace *)
+
+open Setoid_replace
+
+TACTIC EXTEND SetoidReplace
+  [ "Setoid_replace" constr(c1) "with" constr(c2) ]
+  -> [ setoid_replace c1 c2 None]
+END
+
+TACTIC EXTEND SetoidRewrite
+  [ "Setoid_rewrite" orient(b) constr(c) ] -> [ general_s_rewrite b c ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid
+| [ "Add" "Setoid" constr(a) constr(aeq) constr(t) ] -> [ add_setoid a aeq t ]
+| [ "Add" "Morphism" constr(m) ":" ident(s) ] -> [ new_named_morphism s m ]
+END
+
+(* Inversion lemmas (Leminv) *)
+
+open Inv
+open Leminv
+
+VERNAC COMMAND EXTEND DeriveInversionClear
+  [ "Derive" "Inversion_clear" ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal n na id Term.mk_Prop false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ]
+  -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ]
+END
+
+open Term
+open Rawterm
+
+VERNAC COMMAND EXTEND DeriveInversion
+| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s false half_inv_tac ]
+
+| [ "Derive" "Inversion" ident(na) "with" constr(c) ]
+  -> [ add_inversion_lemma_exn na c (RProp Null) false half_inv_tac ]
+
+| [ "Derive" "Inversion" ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false half_inv_tac ]
+
+| [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal n na id Term.mk_Prop false half_inv_tac ]
+END
+
+VERNAC COMMAND EXTEND DeriveDependentInversion
+| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s true half_dinv_tac ]
+    END
+
+VERNAC COMMAND EXTEND DeriveDependentInversionClear
+| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
+END
+
+(* Subst *)
+
+TACTIC EXTEND Subst
+| [ "Subst" ne_var_list(l) ] -> [ subst l ]
+| [ "Subst" ] -> [ subst_all ]
+END
+
+(** Nijmegen "step" tactic for setoid rewriting *)
+
+open Tacticals
+open Tactics
+open Tactics
+open Libnames
+open Rawterm
+open Summary
+open Libobject
+open Lib
+
+(* Registered lemmas are expected to be of the form
+     x R y -> y == z -> x R z    (in the right table)
+     x R y -> x == z -> z R y    (in the left table)
+*)
+
+let transitivity_right_table = ref []
+let transitivity_left_table = ref []
+
+(* [step] tries to apply a rewriting lemma; then apply [tac] intended to
+   complete to proof of the last hypothesis (assumed to state an equality) *)
+
+let step left x tac =
+  let l =
+    List.map (fun lem ->
+      tclTHENLAST
+      (apply_with_bindings (constr_of_reference lem, ImplicitBindings [x]))
+        tac)
+      !(if left then transitivity_left_table else transitivity_right_table)
+  in
+  tclFIRST l
+
+(* Main function to push lemmas in persistent environment *)
+
+let cache_transitivity_lemma (_,(left,lem)) =
+  if left then  
+    transitivity_left_table  := lem :: !transitivity_left_table
+  else
+    transitivity_right_table := lem :: !transitivity_right_table
+  
+let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_global subst ref)
+
+let (inTransitivity,_) =
+  declare_object {(default_object "TRANSITIVITY-STEPS") with
+    cache_function = cache_transitivity_lemma;
+    open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
+    subst_function = subst_transitivity_lemma;
+    classify_function = (fun (_,o) -> Substitute o);       
+    export_function = (fun x -> Some x) }
+
+(* Synchronisation with reset *)
+
+let freeze () = !transitivity_left_table, !transitivity_right_table
+
+let unfreeze (l,r) = 
+  transitivity_left_table := l;
+  transitivity_right_table := r
+
+let init () = 
+  transitivity_left_table := [];
+  transitivity_right_table := []
+
+let _ = 
+  declare_summary "transitivity-steps"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init;
+      survive_module = false; 
+      survive_section = false }
+
+(* Main entry points *)
+
+let add_transitivity_lemma left ref =
+  add_anonymous_leaf (inTransitivity (left,Nametab.global ref))
+
+(* Vernacular syntax *)
+
+TACTIC EXTEND Stepl
+| ["Stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ]
+| ["Stepl" constr(c) ] -> [ step true c tclIDTAC ]
+END
+
+TACTIC EXTEND Stepr
+| ["Stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ]
+| ["Stepr" constr(c) ] -> [ step false c tclIDTAC ]
+END
+
+VERNAC COMMAND EXTEND AddStepl
+| [ "Declare" "Left" "Step" global(id) ] ->
+    [ add_transitivity_lemma true id ]
+END
+
+VERNAC COMMAND EXTEND AddStepr
+| [ "Declare" "Right" "Step" global(id) ] ->
+    [ add_transitivity_lemma false id ]
+END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
new file mode 100644
index 00000000..a714c8dd
--- /dev/null
+++ b/tactics/extratactics.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: extratactics.mli,v 1.3.10.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Names
+open Term
+open Proof_type
+open Rawterm
+
+val h_discrHyp : quantified_hypothesis -> tactic
+val h_injHyp : quantified_hypothesis -> tactic
+val h_rewriteLR : constr -> tactic
+
+val refine_tac : Genarg.open_constr -> tactic
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
new file mode 100644
index 00000000..f35c624b
--- /dev/null
+++ b/tactics/hiddentac.ml
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: hiddentac.ml,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Term
+open Proof_type
+open Tacmach
+
+open Rawterm
+open Refiner
+open Genarg
+open Tacexpr
+open Tactics
+open Util
+
+let inj_id id = (dummy_loc,id)
+
+(* Basic tactics *)
+let h_intro_move x y =
+  abstract_tactic (TacIntroMove (x, option_app inj_id y)) (intro_move x y)
+let h_intro x        = h_intro_move (Some x) None
+let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
+let h_assumption     = abstract_tactic TacAssumption assumption
+let h_exact c        = abstract_tactic (TacExact c) (exact_check c)
+let h_apply cb       = abstract_tactic (TacApply cb) (apply_with_bindings cb)
+let h_elim cb cbo    = abstract_tactic (TacElim (cb,cbo)) (elim cb cbo)
+let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
+let h_case cb        = abstract_tactic (TacCase cb) (general_case_analysis cb)
+let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
+let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
+let h_mutual_fix id n l =
+  abstract_tactic (TacMutualFix (id,n,l)) (mutual_fix id n l)
+let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
+let h_mutual_cofix id l =
+  abstract_tactic (TacMutualCofix (id,l)) (mutual_cofix id l)
+
+let h_cut c          = abstract_tactic (TacCut c) (cut c)
+let h_true_cut na c = abstract_tactic (TacTrueCut (na,c)) (true_cut na c)
+let h_forward b na c = abstract_tactic (TacForward (b,na,c)) (forward b na c)
+let h_generalize cl  = abstract_tactic (TacGeneralize cl) (generalize cl)
+let h_generalize_dep c = abstract_tactic (TacGeneralizeDep c)(generalize_dep c)
+let h_let_tac na c cl =
+  abstract_tactic (TacLetTac (na,c,cl)) (letin_tac true na c cl)
+let h_instantiate n c cls = 
+  abstract_tactic (TacInstantiate (n,c,cls))
+    (Evar_refiner.instantiate n c (simple_clause_of cls))
+
+(* Derived basic tactics *)
+let h_simple_induction h =
+  abstract_tactic (TacSimpleInduction h) (simple_induct h)
+let h_simple_destruct h  =
+  abstract_tactic (TacSimpleDestruct h) (simple_destruct h)
+let h_new_induction c e idl =
+  abstract_tactic (TacNewInduction (c,e,idl)) (new_induct c e idl)
+let h_new_destruct c e idl =
+  abstract_tactic (TacNewDestruct (c,e,idl)) (new_destruct c e idl)
+let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (new_hyp n d)
+let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
+
+(* Context management *)
+let h_clear l = abstract_tactic (TacClear l) (clear l)
+let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l)
+let h_move dep id1 id2 =
+  abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2)
+let h_rename id1 id2 =
+  abstract_tactic (TacRename (id1,id2)) (rename_hyp id1 id2)
+
+(* Constructors *)
+let h_left l          = abstract_tactic (TacLeft l) (left l)
+let h_right l         = abstract_tactic (TacLeft l) (right l)
+let h_split l         = abstract_tactic (TacSplit (false,l)) (split l)
+(* Moved to tacinterp because of dependence in Tacinterp.interp
+let h_any_constructor t =
+  abstract_tactic (TacAnyConstructor t) (any_constructor t)
+*)
+let h_constructor n l =
+  abstract_tactic (TacConstructor(AI n,l))(constructor_tac None n l)
+let h_one_constructor n = h_constructor n NoBindings
+let h_simplest_left   = h_left NoBindings
+let h_simplest_right  = h_right NoBindings
+
+(* Conversion *)
+let h_reduce r cl  = abstract_tactic (TacReduce (r,cl)) (reduce r cl)
+let h_change oc c cl  = abstract_tactic (TacChange (oc,c,cl)) (change oc c cl)
+
+(* Equivalence relations *)
+let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
+let h_symmetry c     = abstract_tactic (TacSymmetry c) (intros_symmetry c)
+let h_transitivity c =
+  abstract_tactic (TacTransitivity c) (intros_transitivity c)
+
+let h_simplest_apply c  = h_apply (c,NoBindings)
+let h_simplest_elim c   = h_elim (c,NoBindings) None
+let h_simplest_case   c = h_case (c,NoBindings)
+
+let h_intro_patterns l = abstract_tactic (TacIntroPattern l) (intro_patterns l)
+
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
new file mode 100644
index 00000000..816678ae
--- /dev/null
+++ b/tactics/hiddentac.mli
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: hiddentac.mli,v 1.19.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Tacmach
+open Genarg
+open Tacexpr
+open Rawterm
+(*i*)
+
+(* Tactics for the interpreter. They left a trace in the proof tree
+   when they are called. *)
+
+(* Basic tactics *)
+
+val h_intro_move      : identifier option -> identifier option -> tactic
+val h_intro           : identifier -> tactic
+val h_intros_until    : quantified_hypothesis -> tactic
+
+val h_assumption      : tactic
+val h_exact           : constr -> tactic
+
+val h_apply           : constr with_bindings -> tactic
+
+val h_elim            : constr with_bindings ->
+                        constr with_bindings option -> tactic
+val h_elim_type       : constr -> tactic
+val h_case            : constr with_bindings -> tactic
+val h_case_type       : constr -> tactic
+
+val h_mutual_fix      : identifier -> int ->
+                        (identifier * int * constr) list -> tactic
+val h_fix             : identifier option -> int -> tactic
+val h_mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val h_cofix           : identifier option -> tactic
+
+val h_cut             : constr -> tactic 
+val h_true_cut        : name -> constr -> tactic 
+val h_generalize      : constr list -> tactic 
+val h_generalize_dep  : constr -> tactic 
+val h_forward         : bool -> name -> constr -> tactic 
+val h_let_tac         : name -> constr -> Tacticals.clause -> tactic
+val h_instantiate     : int -> constr -> Tacticals.clause -> tactic
+
+(* Derived basic tactics *)
+
+val h_simple_induction   : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic
+val h_simple_destruct    : quantified_hypothesis -> tactic
+val h_new_induction   :
+  constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+val h_new_destruct    :
+  constr induction_arg -> constr with_bindings option -> 
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+val h_specialize      : int option -> constr with_bindings -> tactic
+val h_lapply          : constr -> tactic
+
+(* Automation tactic : see Auto *)
+
+
+(* Context management *)
+val h_clear           : identifier list -> tactic
+val h_clear_body      : identifier list -> tactic
+val h_move            : bool -> identifier -> identifier -> tactic
+val h_rename          : identifier -> identifier -> tactic
+
+
+(* Constructors *)
+(*
+val h_any_constructor : tactic -> tactic
+*)
+val h_constructor     : int -> constr bindings -> tactic
+val h_left            : constr bindings -> tactic
+val h_right           : constr bindings -> tactic
+val h_split           : constr bindings -> tactic
+
+val h_one_constructor : int -> tactic
+val h_simplest_left   : tactic
+val h_simplest_right  : tactic
+
+
+(* Conversion *)
+val h_reduce          : Tacred.red_expr -> Tacticals.clause -> tactic
+val h_change          :
+  constr occurrences option -> constr -> Tacticals.clause -> tactic
+
+(* Equivalence relations *)
+val h_reflexivity     : tactic
+val h_symmetry        : Tacticals.clause -> tactic
+val h_transitivity    : constr -> tactic
+
+val h_simplest_apply  : constr -> tactic 
+val h_simplest_elim   : constr -> tactic
+val h_simplest_case   : constr -> tactic
+
+val h_intro_patterns  : intro_pattern_expr list -> tactic
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
new file mode 100644
index 00000000..0ada5a06
--- /dev/null
+++ b/tactics/hipattern.ml
@@ -0,0 +1,366 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: hipattern.ml,v 1.29.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Reductionops
+open Inductiveops
+open Evd
+open Environ
+open Proof_trees
+open Clenv
+open Pattern
+open Matching
+open Coqlib
+open Declarations
+
+(* I implemented the following functions which test whether a term t
+   is an inductive but non-recursive type, a general conjuction, a
+   general disjunction, or a type with no constructors.
+
+   They are more general than matching with or_term, and_term, etc, 
+   since they do not depend on the name of the type. Hence, they 
+   also work on ad-hoc disjunctions introduced by the user.
+  
+  -- Eduardo (6/8/97). *)
+
+type 'a matching_function = constr -> 'a option
+
+type testing_function  = constr -> bool
+
+let mkmeta n = Nameops.make_ident "X" (Some n)
+let mkPMeta n = PMeta (Some (mkmeta n))
+let meta1 = mkmeta 1
+let meta2 = mkmeta 2
+let meta3 = mkmeta 3
+let meta4 = mkmeta 4
+
+let op2bool = function Some _ -> true | None -> false
+
+let match_with_non_recursive_type t = 
+  match kind_of_term t with 
+    | App _ -> 
+        let (hdapp,args) = decompose_app t in
+        (match kind_of_term hdapp with
+           | Ind ind -> 
+               if not (Global.lookup_mind (fst ind)).mind_finite then 
+		 Some (hdapp,args) 
+	       else 
+		 None 
+           | _ -> None)
+    | _ -> None
+
+let is_non_recursive_type t = op2bool (match_with_non_recursive_type t)
+
+(* A general conjunction type is a non-recursive inductive type with
+   only one constructor. *)
+
+let match_with_conjunction t =
+  let (hdapp,args) = decompose_app t in 
+  match kind_of_term hdapp with
+    | Ind ind -> 
+	let (mib,mip) = Global.lookup_inductive ind in
+	if (Array.length mip.mind_consnames = 1)
+	  && (not (mis_is_recursive (ind,mib,mip)))
+          && (mip.mind_nrealargs = 0)
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_conjunction t = op2bool (match_with_conjunction t)
+    
+(* A general disjunction type is a non-recursive inductive type all
+   whose constructors have a single argument. *)
+
+let match_with_disjunction t =
+  let (hdapp,args) = decompose_app t in 
+  match kind_of_term hdapp with
+    | Ind ind  ->
+        let car = mis_constr_nargs ind in
+	if array_for_all (fun ar -> ar = 1) car &&
+	   (let (mib,mip) = Global.lookup_inductive ind in
+            not (mis_is_recursive (ind,mib,mip)))
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_disjunction t = op2bool (match_with_disjunction t)
+
+let match_with_empty_type t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let nconstr = Array.length mip.mind_consnames in  
+	if nconstr = 0 then Some hdapp else None
+    | _ ->  None
+	  
+let is_empty_type t = op2bool (match_with_empty_type t)
+
+let match_with_unit_type t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind  -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let constr_types = mip.mind_nf_lc in 
+        let nconstr = Array.length mip.mind_consnames in
+        let zero_args c =
+          nb_prod c = mip.mind_nparams in  
+	if nconstr = 1 && array_for_all zero_args constr_types then 
+	  Some hdapp
+        else 
+	  None
+    | _ -> None
+
+let is_unit_type t = op2bool (match_with_unit_type t)
+
+(* Checks if a given term is an application of an
+   inductive binary relation R, so that R has only one constructor
+   establishing its reflexivity.  *)
+
+(* ["(A : ?)(x:A)(? A x x)"] and ["(x : ?)(? x x)"] *)
+let x = Name (id_of_string "x")
+let y = Name (id_of_string "y")
+let name_A = Name (id_of_string "A")
+let coq_refl_rel1_pattern =
+  PProd
+    (name_A, PMeta None,
+    PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 1|])))
+let coq_refl_rel2_pattern =
+  PProd (x, PMeta None, PApp (PMeta None, [|PRel 1; PRel 1|]))
+
+let coq_refl_reljm_pattern =
+PProd
+    (name_A, PMeta None,
+    PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 2;PRel 1|])))
+
+let match_with_equation t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let constr_types = mip.mind_nf_lc in 
+        let nconstr = Array.length mip.mind_consnames in
+	if nconstr = 1 &&
+           (is_matching coq_refl_rel1_pattern constr_types.(0) ||
+            is_matching coq_refl_rel2_pattern constr_types.(0) ||
+            is_matching coq_refl_reljm_pattern constr_types.(0)) 
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_equation t = op2bool (match_with_equation  t)
+
+(* ["(?1 -> ?2)"] *)
+let imp a b = PProd (Anonymous, a, b)
+let coq_arrow_pattern = imp (mkPMeta 1) (mkPMeta 2)
+let match_arrow_pattern t =
+  match matches coq_arrow_pattern t with
+    | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
+    | _ -> anomaly "Incorrect pattern matching" 
+
+let match_with_nottype t =
+  try
+    let (arg,mind) = match_arrow_pattern t in
+    if is_empty_type mind then Some (mind,arg) else None
+  with PatternMatchingFailure -> None  
+
+let is_nottype t = op2bool (match_with_nottype t)
+		     
+let match_with_forall_term c=
+  match kind_of_term c with
+    | Prod (nam,a,b) -> Some (nam,a,b)
+    | _            -> None
+
+let is_forall_term c = op2bool (match_with_forall_term c) 
+
+let match_with_imp_term c=
+  match kind_of_term c with
+    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
+    | _              -> None
+
+let is_imp_term c = op2bool (match_with_imp_term c) 
+
+let rec has_nodep_prod_after n c =
+  match kind_of_term c with
+    | Prod (_,_,b) -> 
+	( n>0 || not (dependent (mkRel 1) b)) 
+	&& (has_nodep_prod_after (n-1) b)
+    | _            -> true
+	  
+let has_nodep_prod = has_nodep_prod_after 0
+	
+let match_with_nodep_ind t =
+  let (hdapp,args) = decompose_app t in
+    match (kind_of_term hdapp) with
+      | Ind ind  -> 
+          let (mib,mip) = Global.lookup_inductive ind in
+	    if Array.length (mib.mind_packets)>1 then None else
+	      let nodep_constr = has_nodep_prod_after mip.mind_nparams in
+		if array_for_all nodep_constr mip.mind_nf_lc then
+		  let params=
+		    if mip.mind_nrealargs=0 then args else
+		      fst (list_chop mip.mind_nparams args) in
+		    Some (hdapp,params,mip.mind_nrealargs)
+		else 
+		  None
+      | _ -> None
+	  
+let is_nodep_ind t=op2bool (match_with_nodep_ind t)
+
+let match_with_sigma_type t=
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind  -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+          if (Array.length (mib.mind_packets)=1) &&
+	    (mip.mind_nrealargs=0) &&
+	    (Array.length mip.mind_consnames=1) &&
+	    has_nodep_prod_after (mip.mind_nparams+1) mip.mind_nf_lc.(0) then
+	      (*allowing only 1 existential*) 
+	      Some (hdapp,args)
+	  else 
+	    None
+    | _ -> None
+
+let is_sigma_type t=op2bool (match_with_sigma_type t)
+
+(***** Destructing patterns bound to some theory *)
+
+let rec first_match matcher = function
+  | [] -> raise PatternMatchingFailure
+  | (pat,build_set)::l ->
+      try (build_set (),matcher pat)
+      with PatternMatchingFailure -> first_match matcher l
+
+(*** Equality *)
+
+(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *)
+let coq_eq_pattern_gen eq = 
+  lazy (PApp(PRef (Lazy.force eq), [|mkPMeta 1;mkPMeta 2;mkPMeta 3|]))
+let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref
+(*let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref*)
+let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref
+
+let match_eq eqn eq_pat =
+  match matches (Lazy.force eq_pat) eqn with
+    | [(m1,t);(m2,x);(m3,y)] ->
+	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+	(t,x,y)
+    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+
+let equalities =
+  [coq_eq_pattern, build_coq_eq_data;
+(*   coq_eqT_pattern, build_coq_eqT_data;*)
+   coq_idT_pattern, build_coq_idT_data]
+
+let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *)
+  first_match (match_eq eqn) equalities
+
+open Tacmach
+open Tacticals
+
+let match_eq_nf gls eqn eq_pat =
+  match pf_matches gls (Lazy.force eq_pat) eqn with
+    | [(m1,t);(m2,x);(m3,y)] ->
+	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+	(t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y)
+    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+
+let dest_nf_eq gls eqn =
+  try
+    snd (first_match (match_eq_nf gls eqn) equalities)
+  with PatternMatchingFailure ->
+    error "Not an equality"
+
+(*** Sigma-types *)
+
+(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *)
+let coq_ex_pattern_gen ex =
+  lazy(PApp(PRef (Lazy.force ex), [|mkPMeta 1;mkPMeta 2;mkPMeta 3;mkPMeta 4|]))
+let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref
+let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref
+
+let match_sigma ex ex_pat =
+  match matches (Lazy.force ex_pat) ex with
+    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] as l ->
+	assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4);
+	(a,p,car,cdr)
+    | _ ->
+	anomaly "match_sigma: a successful sigma pattern should match 4 terms"
+
+let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
+  first_match (match_sigma ex) 
+    [coq_existS_pattern, build_sigma_set; 
+     coq_existT_pattern, build_sigma_type]
+
+(* Pattern "(sig ?1 ?2)" *)
+let coq_sig_pattern = 
+  lazy (PApp (PRef (Lazy.force coq_sig_ref), [| (mkPMeta 1); (mkPMeta 2) |]))
+
+let match_sigma t =
+  match matches (Lazy.force coq_sig_pattern) t with
+    | [(_,a); (_,p)] -> (a,p)
+    | _ -> anomaly "Unexpected pattern"
+
+let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t
+
+(*** Decidable equalities *)
+
+(* Pattern "(sumbool (eq ?1 ?2 ?3) ?4)" *)
+let coq_eqdec_partial_pattern =
+  lazy
+    (PApp
+       (PRef (Lazy.force coq_sumbool_ref),
+	[| Lazy.force coq_eq_pattern; (mkPMeta 4) |]))
+
+let match_eqdec_partial t =
+  match matches (Lazy.force coq_eqdec_partial_pattern) t with
+    | [_; (_,lhs); (_,rhs); _] -> (lhs,rhs)
+    | _ -> anomaly "Unexpected pattern"
+
+(* The expected form of the goal for the tactic Decide Equality *)
+
+(* Pattern "(x,y:?1){<?1>x=y}+{~(<?1>x=y)}" *)
+(* i.e. "(x,y:?1)(sumbool (eq ?1 x y) ~(eq ?1 x y))" *)
+let x = Name (id_of_string "x")
+let y = Name (id_of_string "y")
+let coq_eqdec_pattern =
+  lazy
+    (PProd (x, (mkPMeta 1), PProd (y, (mkPMeta 1), 
+    PApp (PRef (Lazy.force coq_sumbool_ref),
+	  [| PApp (PRef (Lazy.force coq_eq_ref),
+		   [| (mkPMeta 1); PRel 2; PRel 1 |]);
+	     PApp (PRef (Lazy.force coq_not_ref), 
+		   [|PApp (PRef (Lazy.force coq_eq_ref),
+ 			   [| (mkPMeta 1); PRel 2; PRel 1 |])|]) |]))))
+
+let match_eqdec t =
+  match matches (Lazy.force coq_eqdec_pattern) t with
+    | [(_,typ)] -> typ
+    | _ -> anomaly "Unexpected pattern"
+
+(* Patterns "~ ?" and "? -> False" *)
+let coq_not_pattern = lazy(PApp(PRef (Lazy.force coq_not_ref), [|PMeta None|]))
+let coq_imp_False_pattern =
+  lazy (imp (PMeta None) (PRef (Lazy.force coq_False_ref)))
+
+let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t
+let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
new file mode 100644
index 00000000..7e2aa8f2
--- /dev/null
+++ b/tactics/hipattern.mli
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: hipattern.mli,v 1.13.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Evd
+open Pattern
+open Proof_trees
+(*i*)
+
+(*s Given a term with second-order variables in it,
+   represented by Meta's, and possibly applied using SoApp
+   terms, this function will perform second-order, binding-preserving,
+   matching, in the case where the pattern is a pattern in the sense
+   of Dale Miller.
+
+   ALGORITHM:
+
+   Given a pattern, we decompose it, flattening casts and apply's,
+   recursing on all operators, and pushing the name of the binder each
+   time we descend a binder.
+
+   When we reach a first-order variable, we ask that the corresponding
+   term's free-rels all be higher than the depth of the current stack.
+
+   When we reach a second-order application, we ask that the
+   intersection of the free-rels of the term and the current stack be
+   contained in the arguments of the application *)
+
+val is_imp_term : constr -> bool
+
+(*s I implemented the following functions which test whether a term [t]
+   is an inductive but non-recursive type, a general conjuction, a
+   general disjunction, or a type with no constructors.
+
+   They are more general than matching with [or_term], [and_term], etc, 
+   since they do not depend on the name of the type. Hence, they 
+   also work on ad-hoc disjunctions introduced by the user.
+   (Eduardo, 6/8/97). *)
+
+type 'a matching_function = constr -> 'a option
+type testing_function = constr -> bool
+
+val match_with_non_recursive_type : (constr * constr list) matching_function
+val is_non_recursive_type         : testing_function 
+
+val match_with_disjunction : (constr * constr list) matching_function
+val is_disjunction         : testing_function 
+
+val match_with_conjunction : (constr * constr list) matching_function
+val is_conjunction         : testing_function 
+
+val match_with_empty_type  : constr matching_function
+val is_empty_type          : testing_function 
+
+val match_with_unit_type   : constr matching_function
+
+(* type with only one constructor and no arguments *)
+val is_unit_type           : testing_function 
+
+val match_with_equation    : (constr * constr list) matching_function
+val is_equation            : testing_function 
+
+val match_with_nottype     : (constr * constr) matching_function
+val is_nottype             : testing_function 
+
+val match_with_forall_term    : (name * constr * constr) matching_function
+val is_forall_term            : testing_function 
+
+val match_with_imp_term    : (constr * constr) matching_function
+val is_imp_term            : testing_function 
+
+(* I added these functions to test whether a type contains dependent
+  products or not, and if an inductive has constructors with dependent types
+ (excluding parameters). this is useful to check whether a conjunction is a
+ real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *)
+
+val has_nodep_prod_after   : int -> testing_function
+val has_nodep_prod         : testing_function
+
+val match_with_nodep_ind   : (constr * constr list * int) matching_function  
+val is_nodep_ind           : testing_function 
+
+val match_with_sigma_type   : (constr * constr list) matching_function	  
+val is_sigma_type           : testing_function 
+
+(***** Destructing patterns bound to some theory *)
+
+open Coqlib
+
+(* Match terms [(eq A t u)], [(eqT A t u)] or [(identityT A t u)] *)
+(* Returns associated lemmas and [A,t,u] *)
+val find_eq_data_decompose : constr -> 
+  coq_leibniz_eq_data * (constr * constr * constr)
+
+(* Match a term of the form [(existS A P t p)] or [(existT A P t p)] *)
+(* Returns associated lemmas and [A,P,t,p] *)
+val find_sigma_data_decompose : constr -> 
+  coq_sigma_data * (constr * constr * constr * constr)
+
+(* Match a term of the form [{x:A|P}], returns [A] and [P] *)
+val match_sigma : constr -> constr * constr
+
+val is_matching_sigma : constr -> bool
+
+(* Match a term of the form [{x=y}+{_}], returns [x] and [y] *)
+val match_eqdec_partial : constr -> constr * constr
+
+(* Match a term of the form [(x,y:t){x=y}+{~x=y}], returns [t] *)
+val match_eqdec : constr -> constr
+
+(* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
+open Proof_type
+open Tacmach
+val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr)
+
+(* Match a negation *)
+val is_matching_not : constr -> bool
+val is_matching_imp_False : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
new file mode 100644
index 00000000..54ce467c
--- /dev/null
+++ b/tactics/inv.ml
@@ -0,0 +1,564 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: inv.ml,v 1.53.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Global
+open Sign
+open Environ
+open Inductiveops
+open Printer
+open Reductionops
+open Retyping
+open Tacmach
+open Proof_type
+open Evar_refiner
+open Clenv
+open Tactics
+open Tacticals
+open Tactics
+open Elim
+open Equality
+open Typing
+open Pattern
+open Matching
+open Rawterm
+open Genarg
+open Tacexpr
+
+let collect_meta_variables c = 
+  let rec collrec acc c = match kind_of_term c with
+    | Meta mv -> mv::acc
+    | _ -> fold_constr collrec acc c
+  in 
+  collrec [] c
+
+let check_no_metas clenv ccl =
+  if occur_meta ccl then
+    let metas = List.map (fun n -> Metamap.find n clenv.namenv)
+		  (collect_meta_variables ccl) in
+    errorlabstrm "inversion" 
+      (str ("Cannot find an instantiation for variable"^
+	       (if List.length metas = 1 then " " else "s ")) ++
+	 prlist_with_sep pr_coma pr_id metas
+	 (* ajouter "in " ++ prterm ccl mais il faut le bon contexte *))
+
+let var_occurs_in_pf gl id =
+  let env = pf_env gl in
+  occur_var env id (pf_concl gl) or
+  List.exists (occur_var_in_decl env id) (pf_hyps gl)
+
+(* [make_inv_predicate (ity,args) C]
+  
+   is given the inductive type, its arguments, both the global
+   parameters and its local arguments, and is expected to produce a
+   predicate P such that if largs is the "local" part of the
+   arguments, then (P largs) will be convertible with a conclusion of
+   the form:
+
+   <A1>a1=a1-><A2>a2=a2 ... -> C
+
+   Algorithm: suppose length(largs)=n
+
+   (1) Push the entire arity, [xbar:Abar], carrying along largs and
+   the conclusion
+
+   (2) Pair up each ai with its respective Rel version: a1==(Rel n),
+   a2==(Rel n-1), etc.
+
+   (3) For each pair, ai,Rel j, if the Ai is dependent - that is, the
+   type of [Rel j] is an open term, then we construct the iterated
+   tuple, [make_iterated_tuple] does it, and use that for our equation
+
+   Otherwise, we just use <Ai>ai=Rel j
+
+ *)
+
+type inversion_status = Dep of constr option | NoDep
+
+let compute_eqn env sigma n i ai =
+  (ai,get_type_of env sigma ai),
+  (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))
+
+let make_inv_predicate env sigma indf realargs id status concl =
+  let nrealargs = List.length realargs in
+  let (hyps,concl) =
+    match status with
+      | NoDep ->
+	  (* We push the arity and leave concl unchanged *)
+	  let hyps_arity,_ = get_arity env indf in
+	  (hyps_arity,concl)
+      | Dep dflt_concl ->
+	  if not (occur_var env id concl) then
+	    errorlabstrm "make_inv_predicate"
+              (str "Current goal does not depend on " ++ pr_id id);
+          (* We abstract the conclusion of goal with respect to
+             realargs and c to * be concl in order to rewrite and have
+             c also rewritten when the case * will be done *)
+	  let pred =
+            match dflt_concl with
+              | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
+              | None ->
+		let sort = get_sort_of env sigma concl in
+		let p = make_arity env true indf sort in
+		abstract_list_all env sigma p concl (realargs@[mkVar id]) in
+	  let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
+	  (* We lift to make room for the equations *)
+	  (hyps,lift nrealargs bodypred)
+  in
+  let nhyps = List.length hyps in
+  let env' = push_rel_context hyps env in
+  let realargs' = List.map (lift nhyps) realargs in
+  let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in
+  (* Now the arity is pushed, and we need to construct the pairs
+   * ai,mkRel(n-i+1) *)
+  (* Now, we can recurse down this list, for each ai,(mkRel k) whether to
+     push <Ai>(mkRel k)=ai (when   Ai is closed).
+   In any case, we carry along the rest of pairs *)
+  let rec build_concl eqns n = function
+    | [] -> (prod_it concl eqns,n)
+    | ((ai,ati),(xi,ti))::restlist ->
+        let (lhs,eqnty,rhs) =
+          if closed0 ti then 
+	    (xi,ti,ai)
+          else 
+	    make_iterated_tuple env' sigma (ai,ati) (xi,ti)
+	in
+        let type_type_rhs = get_sort_of env sigma (type_of env sigma rhs) in
+        let sort = get_sort_of env sigma concl in 
+        let eq_term = find_eq_pattern type_type_rhs sort in
+        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in 
+	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
+  in
+  let (newconcl,neqns) = build_concl [] 0 pairs in
+  let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in
+  (* OK - this predicate should now be usable by res_elimination_then to
+     do elimination on the conclusion. *)
+  (predicate,neqns)
+
+(* The result of the elimination is a bunch of goals like:
+
+           |- (cibar:Cibar)Equands->C
+
+   where the cibar are either dependent or not.  We are fed a
+   signature, with "true" for every recursive argument, and false for
+   every non-recursive one.  So we need to do the
+   sign_branch_len(sign) intros, thinning out all recursive
+   assumptions.  This leaves us with exactly length(sign) assumptions.
+
+   We save their names, and then do introductions for all the equands
+   (there are some number of them, which is the other argument of the
+   tactic)
+
+   This gives us the #neqns equations, whose names we get also, and
+   the #length(sign) arguments.
+
+   Suppose that #nodep of these arguments are non-dependent.
+   Generalize and thin them.
+
+   This gives us #dep = #length(sign)-#nodep arguments which are
+   dependent.
+
+   Now, we want to take each of the equations, and do all possible
+   injections to get the left-hand-side to be a variable.  At the same
+   time, if we find a lhs/rhs pair which are different, we can
+   discriminate them to prove false and finish the branch.
+
+   Then, we thin away the equations, and do the introductions for the
+   #nodep arguments which we generalized before.
+ *)
+
+(* Called after the case-assumptions have been killed off, and all the
+   intros have been done.  Given that the clause in question is an
+   equality (if it isn't we fail), we are responsible for projecting
+   the equality, using Injection and Discriminate, and applying it to
+   the concusion *)
+
+(* Computes the subset of hypothesis in the local context whose
+   type depends on t (should be of the form (mkVar id)), then
+   it generalizes them, applies tac to rewrite all occurrencies of t,
+   and introduces generalized hypotheis.
+   Precondition: t=(mkVar id) *)
+    
+let rec dependent_hyps id idlist sign = 
+  let rec dep_rec =function
+    | [] -> []
+    | (id1,_,id1ty as d1)::l -> 
+	if occur_var (Global.env()) id id1ty
+        then d1 :: dep_rec l
+        else dep_rec l
+  in 
+  dep_rec idlist 
+
+let split_dep_and_nodep hyps gl =
+  List.fold_right 
+    (fun (id,_,_ as d) (l1,l2) ->
+       if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
+    hyps ([],[])
+
+open Coqlib
+
+(* Computation of dids is late; must have been done in rewrite_equations*)
+(* Will keep generalizing and introducing back and forth... *)
+(* Moreover, others hyps depending of dids should have been *)
+(* generalized; in such a way that [dids] can endly be cleared *)
+(* Consider for instance this case extracted from Well_Ordering.v
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  ============================
+   (Acc WO le_WO y)
+
+  Inversion H0 gives
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  a1 : A
+  f0 : (B a1) ->WO
+  v : (B a1)
+  H1 : (f0 v)=y
+  H3 : a1=a0
+  f1 : (B a0) ->WO
+  v0 : (B a0)
+  H4 : (existS A [a:A](B a) ->WO a0 f1)=(existS A [a:A](B a) ->WO a0 f)
+  ============================
+   (Acc WO le_WO (f1 v0))
+
+while, ideally, we would have expected
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f0 : (B a0)->WO
+  v : (B a0)
+  ============================
+   (Acc WO le_WO (f0 v))
+
+obtained from destruction with equalities
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  a1 : A
+  f0 : (B a1)->WO
+  v : (B a1)
+  H1 : (f0 v)=y
+  H2 : (sup a1 f0)=(sup a0 f)
+  ============================
+   (Acc WO le_WO (f0 v))
+
+by clearing initial hypothesis H0 and its dependency y, clearing H1
+(in fact H1 can be avoided using the same trick as for newdestruct),
+decomposing H2 to get a1=a0 and (a1,f0)=(a0,f), replacing a1 by a0
+everywhere and removing a1 and a1=a0 (in fact it would have been more
+regular to replace a0 by a1, avoiding f1 and v0 cannot replace f0 and v),
+finally removing H4 (here because f is not used, more generally after using
+eq_dep and replacing f by f0) [and finally rename a0, f0 into a,f].
+Summary: nine useless hypotheses!
+Nota: with Inversion_clear, only four useless hypotheses
+*)
+
+let generalizeRewriteIntros tac depids id gls = 
+  let dids = dependent_hyps id depids (pf_env gls) in
+  (tclTHENSEQ
+    [bring_hyps dids; tac; 
+     (* may actually fail to replace if dependent in a previous eq *)
+     intros_replacing (ids_of_named_context dids)])
+  gls
+
+let rec tclMAP_i n tacfun = function
+  | [] -> tclDO n (tacfun None)
+  | a::l -> 
+      if n=0 then error "Too much names"
+      else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
+
+let remember_first_eq id x = if !x = None then x := Some id
+
+(* invariant: ProjectAndApply is responsible for erasing the clause
+   which it is given as input
+   It simplifies the clause (an equality) to use it as a rewrite rule and then
+   erases the result of the simplification. *)
+(* invariant: ProjectAndApplyNoThining simplifies the clause (an equality) .
+   If it can discriminate then the goal is proved, if not tries to use it as
+   a rewrite rule. It erases the clause which is given as input *)
+
+let projectAndApply thin id eqname names depids gls =
+  let env = pf_env gls in
+  let clearer id =
+    if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC) in
+  let subst_hyp_LR id = tclTHEN (tclTRY(hypSubst_LR id onConcl)) (clearer id) in
+  let subst_hyp_RL id = tclTHEN (tclTRY(hypSubst_RL id onConcl)) (clearer id) in
+  let substHypIfVariable tac id gls =
+    let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in
+    match (kind_of_term t1, kind_of_term t2) with
+      | Var id1, _ -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 gls
+      | _, Var id2 -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 gls
+      | _ -> tac id gls
+  in
+  let deq_trailer id neqns =
+    tclTHENSEQ 
+      [(if names <> [] then clear [id] else tclIDTAC);
+       (tclMAP_i neqns (fun idopt ->
+	 tclTHEN
+	   (intro_move idopt None)
+	   (* try again to substitute and if still not a variable after *)
+	   (* decomposition, arbitrarily try to rewrite RL !? *)
+	   (tclTRY (onLastHyp (substHypIfVariable subst_hyp_RL))))
+	 names);
+       (if names = [] then clear [id] else tclIDTAC)]
+  in
+  substHypIfVariable
+    (* If no immediate variable in the equation, try to decompose it *)
+    (* and apply a trailer which again try to substitute *)
+    (fun id -> dEqThen (deq_trailer id) (Some (NamedHyp id)))
+    id
+    gls
+
+(* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer
+   soi-meme (proposition de Valerie). *)
+let rewrite_equations_gene othin neqns ba gl =
+  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
+  let rewrite_eqns =
+    match othin with
+      | Some thin ->
+          onLastHyp
+            (fun last ->
+              tclTHENSEQ
+                [tclDO neqns
+                     (tclTHEN intro
+                        (onLastHyp
+                           (fun id ->
+                              tclTRY 
+			        (projectAndApply thin id (ref None)
+				  [] depids))));
+                 onHyps (compose List.rev (afterHyp last)) bring_hyps;
+                 onHyps (afterHyp last)
+                   (compose clear ids_of_named_context)])
+      | None -> tclIDTAC
+  in
+  (tclTHENSEQ
+    [tclDO neqns intro;
+     bring_hyps nodepids;
+     clear (ids_of_named_context nodepids);
+     onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
+     onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+     rewrite_eqns;
+     tclMAP (fun (id,_,_ as d) ->
+               (tclORELSE (clear [id])
+                 (tclTHEN (bring_hyps [d]) (clear [id]))))
+       depids])
+  gl
+
+(* Introduction of the equations on arguments
+   othin: discriminates Simple Inversion, Inversion and Inversion_clear
+     None: the equations are introduced, but not rewritten
+     Some thin: the equations are rewritten, and cleared if thin is true *)
+
+let rec get_names allow_conj = function
+  | IntroWildcard ->
+      error "Discarding pattern not allowed for inversion equations"
+  | IntroOrAndPattern [l] -> 
+      if allow_conj then
+	if l = [] then (None,[]) else
+	  let l = List.map (fun id -> out_some (fst (get_names false id))) l in
+	  (Some (List.hd l), l)
+      else
+	error "Nested conjunctive patterns not allowed for inversion equations"
+  | IntroOrAndPattern l ->
+      error "Disjunctive patterns not allowed for inversion equations"
+  | IntroIdentifier id ->
+      (Some id,[id])
+
+let extract_eqn_names = function
+  | None -> None,[]
+  | Some x -> x
+
+let rewrite_equations othin neqns names ba gl =
+  let names = List.map (get_names true) names in
+  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
+  let rewrite_eqns =
+    let first_eq = ref None in
+    let update id = if !first_eq = None then first_eq := Some id in
+    match othin with
+      | Some thin ->
+          tclTHENSEQ
+            [onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
+             onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+	     tclMAP_i neqns (fun o ->
+	       let idopt,names = extract_eqn_names o in
+               (tclTHEN
+		 (intro_move idopt None)
+		 (onLastHyp (fun id ->
+		   tclTRY (projectAndApply thin id first_eq names depids)))))
+	       names;
+	     tclMAP (fun (id,_,_) gl ->
+	       intro_move None (if thin then None else !first_eq) gl)
+	       nodepids;
+	     tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids]
+      | None -> tclIDTAC
+  in
+  (tclTHENSEQ
+    [tclDO neqns intro;
+     bring_hyps nodepids;
+     clear (ids_of_named_context nodepids);
+     rewrite_eqns])
+  gl
+
+let interp_inversion_kind = function
+  | SimpleInversion -> None
+  | FullInversion -> Some false
+  | FullInversionClear -> Some true
+
+let rewrite_equations_tac (gene, othin) id neqns names ba =
+  let othin = interp_inversion_kind othin in
+  let tac =
+    if gene then rewrite_equations_gene othin neqns ba
+    else rewrite_equations othin neqns names ba in
+  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then 
+    tclTHEN tac (tclTRY (clear [id]))
+  else 
+    tac
+
+
+let raw_inversion inv_kind indbinding id status names gl =
+  let env = pf_env gl and sigma = project gl in
+  let c = mkVar id in
+  let (wc,kONT) = startWalk gl in
+  let t = strong_prodspine (pf_whd_betadeltaiota gl) (pf_type_of gl c) in
+  let indclause = mk_clenv_from wc (c,t) in
+  let indclause' = clenv_constrain_with_bindings indbinding indclause in
+  let newc = clenv_instance_template indclause' in
+  let ccl = clenv_instance_template_type indclause' in
+  check_no_metas indclause' ccl;
+  let IndType (indf,realargs) =
+    try find_rectype env sigma ccl
+    with Not_found ->
+      errorlabstrm "raw_inversion"
+	(str ("The type of "^(string_of_id id)^" is not inductive")) in
+  let (elim_predicate,neqns) =
+    make_inv_predicate env sigma indf realargs id status (pf_concl gl) in
+  let (cut_concl,case_tac) =
+    if status <> NoDep & (dependent c (pf_concl gl)) then 
+      Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
+      case_then_using 
+    else 
+      Reduction.beta_appvect elim_predicate (Array.of_list realargs),
+      case_nodep_then_using 
+  in
+  (tclTHENS
+     (true_cut Anonymous cut_concl)
+     [case_tac names 
+       (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
+       (Some elim_predicate) ([],[]) newc;
+      onLastHyp
+        (fun id ->
+           (tclTHEN
+              (apply_term (mkVar id)
+                 (list_tabulate (fun _ -> mkMeta(Clenv.new_meta())) neqns))
+              reflexivity))])
+  gl
+
+(* Error messages of the inversion tactics *)
+let not_found_message ids =
+  if List.length ids = 1 then
+    (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++
+      str" was not found in the current environment")
+  else 
+    (str "the variables [" ++ 
+      spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++
+      str" ] were not found in the current environment")
+
+let dep_prop_prop_message id =
+  errorlabstrm "Inv"
+    (str "Inversion on " ++ pr_id id ++
+       str " would needs dependent elimination Prop-Prop")
+ 
+let not_inductive_here id =
+  errorlabstrm "mind_specif_of_mind"
+    (str "Cannot recognize an inductive predicate in " ++ pr_id id ++
+       str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.")
+
+(* Noms d'errreurs obsolètes ?? *)
+let wrap_inv_error id = function
+  | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s
+  | UserError("mind_specif_of_mind",_)  -> not_inductive_here id
+  | UserError (a,b)  -> errorlabstrm "Inv" b
+  | Invalid_argument (*"it_list2"*) "List.fold_left2" -> dep_prop_prop_message id
+  | Not_found  ->  errorlabstrm "Inv" (not_found_message [id]) 
+  | e -> raise e
+
+(* The most general inversion tactic *)
+let inversion inv_kind status names id gls =
+  try (raw_inversion inv_kind [] id status names) gls
+  with e -> wrap_inv_error id e
+
+(* Specializing it... *)
+
+let inv_gen gene thin status names =
+  try_intros_until (inversion (gene,thin) status names)
+
+open Tacexpr
+
+let inv k = inv_gen false k NoDep
+
+let half_inv_tac id  = inv SimpleInversion None (NamedHyp id)
+let inv_tac id       = inv FullInversion None (NamedHyp id)
+let inv_clear_tac id = inv FullInversionClear None (NamedHyp id)
+
+let dinv k c = inv_gen false k (Dep c)
+
+let half_dinv_tac id  = dinv SimpleInversion None None (NamedHyp id)
+let dinv_tac id       = dinv FullInversion None None (NamedHyp id)
+let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
+
+(* InvIn will bring the specified clauses into the conclusion, and then
+ * perform inversion on the named hypothesis.  After, it will intro them
+ * back to their places in the hyp-list. *)
+
+let invIn k names ids id gls =
+  let hyps = List.map (pf_get_hyp gls) ids in
+  let nb_prod_init = nb_prod (pf_concl gls) in
+  let intros_replace_ids gls =
+    let nb_of_new_hyp =
+      nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init)
+    in 
+    if nb_of_new_hyp < 1 then 
+      intros_replacing ids gls
+    else 
+      tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls
+  in
+  try 
+    (tclTHENSEQ
+      [bring_hyps hyps;
+       inversion (false,k) NoDep names id; 
+       intros_replace_ids])
+    gls
+  with e -> wrap_inv_error id e
+
+let invIn_gen k names idl = try_intros_until (invIn k names idl)
+
+let inv_clause k names = function
+  | [] -> inv k names
+  | idl -> invIn_gen k names idl
diff --git a/tactics/inv.mli b/tactics/inv.mli
new file mode 100644
index 00000000..e19d8232
--- /dev/null
+++ b/tactics/inv.mli
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: inv.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Tacmach
+open Genarg
+open Tacexpr
+open Rawterm
+(*i*)
+
+type inversion_status = Dep of constr option | NoDep
+
+val inv_gen :
+  bool -> inversion_kind -> inversion_status ->
+    intro_pattern_expr option -> quantified_hypothesis -> tactic
+val invIn_gen :
+  inversion_kind -> intro_pattern_expr option -> identifier list -> 
+    quantified_hypothesis -> tactic
+
+val inv_clause :
+  inversion_kind -> intro_pattern_expr option -> identifier list ->
+    quantified_hypothesis -> tactic
+
+val inv : inversion_kind -> intro_pattern_expr option ->
+  quantified_hypothesis -> tactic
+
+val dinv : inversion_kind -> constr option -> intro_pattern_expr option ->
+  quantified_hypothesis -> tactic
+
+val half_inv_tac : identifier -> tactic
+val inv_tac : identifier -> tactic
+val inv_clear_tac : identifier -> tactic
+val half_dinv_tac : identifier -> tactic
+val dinv_tac : identifier -> tactic
+val dinv_clear_tac : identifier -> tactic
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
new file mode 100644
index 00000000..1be465f5
--- /dev/null
+++ b/tactics/leminv.ml
@@ -0,0 +1,318 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: leminv.ml,v 1.41.2.1 2004/07/16 19:30:54 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Evd
+open Printer
+open Reductionops
+open Declarations
+open Entries
+open Inductiveops
+open Environ
+open Tacmach
+open Proof_trees
+open Proof_type
+open Pfedit
+open Evar_refiner
+open Clenv
+open Declare
+open Tacticals
+open Tactics
+open Inv
+open Vernacexpr
+open Safe_typing
+open Decl_kinds
+
+let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments"
+
+let no_inductive_inconstr env constr =
+  (str "Cannot recognize an inductive predicate in " ++ 
+     prterm_env env constr ++
+     str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++
+     spc () ++ str "or of the type of constructors" ++ spc () ++
+     str "is hidden by constant definitions.")
+
+(* Inversion stored in lemmas *)
+
+(* ALGORITHM:
+
+   An inversion stored in a lemma is computed from a term-pattern, in
+   a signature, as follows:
+
+   Suppose we have an inductive relation, (I abar), in a signature Gamma:
+
+       Gamma |- (I abar)
+
+   Then we compute the free-variables of abar.  Suppose that Gamma is
+   thinned out to only include these.
+
+   [We need technically to require that all free-variables of the
+    types of the free variables of abar are themselves free-variables
+    of abar.  This needs to be checked, but it should not pose a
+    problem - it is hard to imagine cases where it would not hold.]
+
+   Now, we pose the goal:
+
+       (P:(Gamma)Prop)(Gamma)(I abar)->(P vars[Gamma]).
+
+   We execute the tactic:
+
+   REPEAT Intro THEN (OnLastHyp (Inv NONE false o outSOME))
+
+   This leaves us with some subgoals.  All the assumptions after "P"
+   in these subgoals are new assumptions.  I.e. if we have a subgoal,
+
+       P:(Gamma)Prop, Gamma, Hbar:Tbar |- (P ybar)
+
+   then the assumption we needed to have was
+
+      (Hbar:Tbar)(P ybar)
+
+   So we construct all the assumptions we need, and rebuild the goal
+   with these assumptions.  Then, we can re-apply the same tactic as
+   above, but instead of stopping after the inversion, we just apply
+   the respective assumption in each subgoal.
+
+ *)
+ 
+let thin_ids env (hyps,vars) =
+  fst
+    (List.fold_left
+       (fun ((ids,globs) as sofar) (id,c,a) ->
+          if List.mem id globs then
+	    match c with
+	      | None -> (id::ids,(global_vars env a)@globs)
+	      | Some body ->
+                  (id::ids,(global_vars env body)@(global_vars env a)@globs)
+          else sofar)
+       ([],vars) hyps)
+
+(* returns the sub_signature of sign corresponding to those identifiers that
+ * are not global. *)
+(*
+let get_local_sign sign =
+  let lid = ids_of_sign sign in
+  let globsign = Global.named_context() in
+  let add_local id res_sign = 
+    if not (mem_sign globsign id) then 
+      add_sign (lookup_sign id sign) res_sign
+    else 
+      res_sign
+  in 
+  List.fold_right add_local lid nil_sign
+*)
+(* returs the identifier of lid that was the latest declared in sign.
+ * (i.e. is the identifier id of lid such that 
+ * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) >
+ * for any id'<>id in lid).
+ * it returns both the pair (id,(sign_prefix id sign)) *)
+(*
+let max_prefix_sign lid sign =
+  let rec max_rec (resid,prefix) = function
+    | [] -> (resid,prefix)
+    | (id::l) -> 
+	let pre = sign_prefix id sign in  
+	if sign_length pre > sign_length prefix then 
+          max_rec (id,pre) l
+        else 
+	  max_rec (resid,prefix) l
+  in
+  match lid with 
+    | [] -> nil_sign
+    | id::l -> snd (max_rec (id, sign_prefix id sign) l)
+*)
+let rec add_prods_sign env sigma t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (na,c1,b) ->
+	let id = id_of_name_using_hdchar env t na in
+	let b'= subst1 (mkVar id) b in
+        add_prods_sign (push_named (id,None,c1) env) sigma b'
+    | LetIn (na,c1,t1,b) ->
+	let id = id_of_name_using_hdchar env t na in
+	let b'= subst1 (mkVar id) b in
+        add_prods_sign (push_named (id,Some c1,t1) env) sigma b'
+    | _ -> (env,t)
+
+(* [dep_option] indicates wether the inversion lemma is dependent or not.
+   If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then
+   the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) 
+   where P:(x_bar:T_bar)(H:(I x_bar))[sort].
+   The generalisation of such a goal at the moment of the dependent case should
+   be easy.
+
+   If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the
+   variables occurring in [I], then the stated goal will be:
+    (x_bar:T_bar)(I t_bar)->(P x_bar) 
+   where P: P:(x_bar:T_bar)[sort].
+*)
+
+let compute_first_inversion_scheme env sigma ind sort dep_option =
+  let indf,realargs = dest_ind_type ind in
+  let allvars = ids_of_context env in
+  let p = next_ident_away (id_of_string "P") allvars in
+  let pty,goal =
+    if dep_option  then
+      let pty = make_arity env true indf sort in
+      let goal = 
+	mkProd
+	  (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1]))
+      in
+      pty,goal
+    else
+      let i = mkAppliedInd ind in
+      let ivars = global_vars env i in
+      let revargs,ownsign =
+	fold_named_context
+	  (fun env (id,_,_ as d) (revargs,hyps) ->
+             if List.mem id ivars then 
+	       ((mkVar id)::revargs,add_named_decl d hyps)
+	     else 
+	       (revargs,hyps))
+          env ~init:([],[]) 
+      in
+      let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in
+      let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in
+      (pty,goal)
+  in
+  let npty = nf_betadeltaiota env sigma pty in
+  let extenv = push_named (p,None,npty) env in
+  extenv, goal
+
+(* [inversion_scheme sign I]
+
+   Given a local signature, [sign], and an instance of an inductive
+   relation, [I], inversion_scheme will prove the associated inversion
+   scheme on sort [sort]. Depending on the value of [dep_option] it will
+   build a dependent lemma or a non-dependent one *)
+
+let inversion_scheme env sigma t sort dep_option inv_op =
+  let (env,i) = add_prods_sign env sigma t in
+  let ind =
+    try find_rectype env sigma i
+    with Not_found ->
+      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) 
+  in
+  let (invEnv,invGoal) =
+    compute_first_inversion_scheme env sigma ind sort dep_option 
+  in
+  assert 
+    (list_subset 
+       (global_vars env invGoal) 
+       (ids_of_named_context (named_context invEnv)));
+  (*
+    errorlabstrm "lemma_inversion"
+    (str"Computed inversion goal was not closed in initial signature");
+  *)
+  let invSign = named_context invEnv in
+  let pfs = mk_pftreestate (mk_goal invSign invGoal) in
+  let pfs = solve_pftreestate (tclTHEN intro (onLastHyp inv_op)) pfs in
+  let (pfterm,meta_types) = extract_open_pftreestate pfs in
+  let global_named_context = Global.named_context () in
+  let ownSign =
+    fold_named_context
+      (fun env (id,_,_ as d) sign ->
+         if mem_named_context id global_named_context then sign
+	 else add_named_decl d sign)
+      invEnv ~init:empty_named_context 
+  in
+  let (_,ownSign,mvb) =
+    List.fold_left
+      (fun (avoid,sign,mvb) (mv,mvty) ->
+         let h = next_ident_away (id_of_string "H") avoid in
+	 (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb))
+      (ids_of_context invEnv, ownSign, [])
+      meta_types 
+  in
+  let invProof = 
+    it_mkNamedLambda_or_LetIn (local_strong (whd_meta mvb) pfterm) ownSign 
+  in
+  invProof
+
+let add_inversion_lemma name env sigma t sort dep inv_op =
+  let invProof = inversion_scheme env sigma t sort dep inv_op in
+  let _ = 
+    declare_constant name
+    (DefinitionEntry { const_entry_body = invProof;
+                     const_entry_type = None;
+                     const_entry_opaque = false }, 
+     IsProof Lemma)
+  in ()
+
+(* open Pfedit *)
+
+(* inv_op = Inv (derives de complete inv. lemma)
+ * inv_op = InvNoThining (derives de semi inversion lemma) *)
+
+let inversion_lemma_from_goal n na id sort dep_option inv_op =
+  let pts = get_pftreestate() in
+  let gl = nth_goal_of_pftreestate n pts in
+  let t = pf_get_hyp_typ gl id in
+  let env = pf_env gl and sigma = project gl in
+  let fv = global_vars env t in
+(* Pourquoi ??? 
+  let thin_ids = thin_ids (hyps,fv) in
+  if not(list_subset thin_ids fv) then
+    errorlabstrm "lemma_inversion"
+      (str"Cannot compute lemma inversion when there are" ++ spc () ++
+	 str"free variables in the types of an inductive" ++ spc () ++
+	 str"which are not free in its instance"); *)
+  add_inversion_lemma na env sigma t sort dep_option inv_op
+   
+let add_inversion_lemma_exn na com comsort bool tac =
+  let env = Global.env () and sigma = Evd.empty in
+  let c = Constrintern.interp_type sigma env com in
+  let sort = Pretyping.interp_sort comsort in
+  try
+    add_inversion_lemma na env sigma c sort bool tac
+  with 
+    |   UserError ("Case analysis",s) -> (* référence à Indrec *)
+	  errorlabstrm "Inv needs Nodep Prop Set" s
+
+(* ================================= *)
+(* Applying a given inversion lemma  *)
+(* ================================= *)
+
+let lemInv id c gls =
+  try
+    let (wc,kONT) = startWalk gls in
+    let clause = mk_clenv_type_of wc c in
+    let clause = clenv_constrain_with_bindings [(-1,mkVar id)] clause in
+    elim_res_pf kONT clause true gls
+  with 
+    |  UserError (a,b) -> 
+	 errorlabstrm "LemInv" 
+	   (str "Cannot refine current goal with the lemma " ++ 
+	      prterm_env (Global.env()) c) 
+
+let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
+
+let lemInvIn id c ids gls =
+  let hyps = List.map (pf_get_hyp gls) ids in
+  let intros_replace_ids gls =
+    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in 
+    if nb_of_new_hyp < 1  then 
+      intros_replacing ids gls
+    else 
+      (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls
+  in 
+  ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
+    (intros_replace_ids)) gls)
+
+let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
+
+let lemInv_clause id c = function
+  | [] -> lemInv_gen id c
+  | l -> lemInvIn_gen id c l
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
new file mode 100644
index 00000000..6617edf2
--- /dev/null
+++ b/tactics/leminv.mli
@@ -0,0 +1,19 @@
+
+open Names
+open Term
+open Rawterm
+open Proof_type
+open Topconstr
+
+val lemInv_gen : quantified_hypothesis -> constr -> tactic
+val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic
+
+val lemInv_clause : 
+  quantified_hypothesis -> constr -> identifier list -> tactic
+
+val inversion_lemma_from_goal :
+  int -> identifier -> identifier -> sorts -> bool ->
+    (identifier -> tactic) -> unit
+val add_inversion_lemma_exn :
+  identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) ->
+    unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
new file mode 100644
index 00000000..bd4fb60e
--- /dev/null
+++ b/tactics/nbtermdn.ml
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: nbtermdn.ml,v 1.7.16.1 2004/07/16 19:30:54 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Libobject
+open Library
+open Pattern
+
+(* Named, bounded-depth, term-discrimination nets.
+   Implementation:
+   Term-patterns are stored in discrimination-nets, which are
+   themselves stored in a hash-table, indexed by the first label.
+   They are also stored by name in a table on-the-side, so that we can
+   override them if needed. *)
+
+(* The former comments are from Chet.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+
+type ('na,'a) t = {
+  mutable table : ('na,constr_pattern * 'a) Gmap.t;
+  mutable patterns : (constr_label option,'a Btermdn.t) Gmap.t }
+
+type ('na,'a) frozen_t = 
+    ('na,constr_pattern * 'a) Gmap.t
+    * (constr_label option,'a Btermdn.t) Gmap.t
+
+let create () =
+  { table = Gmap.empty;
+    patterns = Gmap.empty }
+
+let get_dn dnm hkey =
+  try Gmap.find hkey dnm with Not_found -> Btermdn.create ()
+
+let add dn (na,(pat,valu)) =
+  let hkey = option_app fst (Termdn.constr_pat_discr pat) in 
+  dn.table <- Gmap.add na (pat,valu) dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Btermdn.add (get_dn dnm hkey) (pat,valu)) dnm
+    
+let rmv dn na =
+  let (pat,valu) = Gmap.find na dn.table in
+  let hkey = option_app fst (Termdn.constr_pat_discr pat) in 
+  dn.table <- Gmap.remove na dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Btermdn.rmv (get_dn dnm hkey) (pat,valu)) dnm
+
+let in_dn dn na = Gmap.mem na dn.table
+			  
+let remap ndn na (pat,valu) =
+  rmv ndn na;
+  add ndn (na,(pat,valu))
+
+let lookup dn valu =
+  let hkey = option_app fst (Termdn.constr_val_discr valu) in 
+  try Btermdn.lookup (Gmap.find hkey  dn.patterns) valu with Not_found -> []
+
+let app f dn = Gmap.iter f dn.table
+		       
+let dnet_depth = Btermdn.dnet_depth
+		   
+let freeze dn = (dn.table, dn.patterns)
+
+let unfreeze (fnm,fdnm) dn =
+  dn.table <- fnm;
+  dn.patterns <- fdnm
+
+let empty dn = 
+  dn.table <- Gmap.empty;
+  dn.patterns <- Gmap.empty
+
+let to2lists dn = 
+  (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
+
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
new file mode 100644
index 00000000..90656619
--- /dev/null
+++ b/tactics/nbtermdn.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: nbtermdn.mli,v 1.8.16.1 2004/07/16 19:30:54 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+
+(* Named, bounded-depth, term-discrimination nets. *)
+
+type ('na,'a) t
+type ('na,'a) frozen_t
+
+val create : unit -> ('na,'a) t
+
+val add : ('na,'a) t -> ('na * (constr_pattern * 'a)) -> unit
+val rmv : ('na,'a) t -> 'na -> unit
+val in_dn : ('na,'a) t -> 'na -> bool
+val remap : ('na,'a) t -> 'na -> (constr_pattern * 'a) -> unit
+
+val lookup : ('na,'a) t -> constr -> (constr_pattern * 'a) list
+val app : ('na -> (constr_pattern * 'a) -> unit) -> ('na,'a) t -> unit
+
+val dnet_depth : int ref
+
+val freeze : ('na,'a) t -> ('na,'a) frozen_t
+val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit
+val empty : ('na,'a) t -> unit
+val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * 
+                             (constr_label option * 'a Btermdn.t) list
diff --git a/tactics/refine.ml b/tactics/refine.ml
new file mode 100644
index 00000000..4a2fb01b
--- /dev/null
+++ b/tactics/refine.ml
@@ -0,0 +1,346 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: refine.ml,v 1.34.2.2 2004/07/16 19:30:54 herbelin Exp $ *)
+
+(* JCF -- 6 janvier 1998  EXPERIMENTAL *)
+
+(*
+ *  L'idée est, en quelque sorte, d'avoir de "vraies" métavariables
+ *  dans Coq, c'est-à-dire de donner des preuves incomplètes -- mais
+ *  où les trous sont typés -- et que les sous-buts correspondants
+ *  soient engendrés pour finir la preuve.
+ *
+ *  Exemple : 
+ *    J'ai le but
+ *        (x:nat) { y:nat | (minus y x) = x }
+ *    et je donne la preuve incomplète
+ *        [x:nat](exist nat [y:nat]((minus y x)=x) (plus x x) ?)
+ *    ce qui engendre le but
+ *        (minus (plus x x) x)=x
+ *)
+
+(*  Pour cela, on procède de la manière suivante :
+ *
+ *  1. Un terme de preuve incomplet est un terme contenant des variables
+ *     existentielles Evar i.e. "?" en syntaxe concrète.
+ *     La résolution de ces variables n'est plus nécessairement totale
+ *     (ise_resolve called with fail_evar=false) et les variables
+ *     existentielles restantes sont remplacées par des méta-variables
+ *     castées par leur types (celui est connu : soit donné, soit trouvé
+ *     pendant la phase de résolution).
+ *
+ *  2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au
+ *     permier niveau et pour chacune d'elles, si nécessaire, on donne
+ *     à son tour un terme de preuve incomplet pour la résoudre.
+ *     Exemple: le terme (f a ? [x:nat](e ?)) donne
+ *         (f a ?1 ?2) avec ?2 => [x:nat]?3 et ?3 => (e ?4)
+ *         ?1 et ?4 donneront des buts
+ *
+ *  3. On écrit ensuite une tactique tcc qui engendre les sous-buts
+ *     à partir d'une preuve incomplète.
+ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Tacmach
+open Sign
+open Environ
+open Reduction
+open Typing
+open Tactics
+open Tacticals
+open Printer
+
+type term_with_holes = TH of constr * metamap * sg_proofs
+and  sg_proofs       = (term_with_holes option) list
+
+(* pour debugger *)
+
+let rec pp_th (TH(c,mm,sg)) =
+  (str"TH=[ " ++ hov 0 (prterm c ++ fnl () ++
+			      (* pp_mm mm ++ fnl () ++ *)
+			   pp_sg sg) ++ str "]")
+and pp_mm l =
+  hov 0 (prlist_with_sep (fun _ -> (fnl ())) 
+	   (fun (n,c) -> (int n ++ str" --> " ++ prterm c)) l)
+and pp_sg sg =
+  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
+	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
+     
+(*  compute_metamap : constr -> 'a evar_map -> term_with_holes
+ *  réalise le 2. ci-dessus
+ *
+ *  Pour cela, on renvoie une meta_map qui indique pour chaque meta-variable
+ *  si elle correspond à un but (None) ou si elle réduite à son tour
+ *  par un terme de preuve incomplet (Some c).
+ *
+ *  On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1"
+ *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y 
+ *  a de meta-variables dans c. On suppose de plus que l'ordre dans la
+ *  meta_map correspond à celui des buts qui seront engendrés par le refine.
+ *)
+
+let replace_by_meta env gmm = function
+  | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp
+  | (TH (c,mm,_)) as th ->
+      let n = Clenv.new_meta() in
+      let m = mkMeta n in
+      (* quand on introduit une mv on calcule son type *)
+      let ty = match kind_of_term c with
+	| Lambda (Name id,c1,c2) when isCast c2 ->
+	    mkNamedProd id c1 (snd (destCast c2))
+	| Lambda (Anonymous,c1,c2) when isCast c2 ->
+	    mkArrow c1 (snd (destCast c2))
+	| _ -> (* (App _ | Case _) -> *)
+	    Retyping.get_type_of_with_meta env Evd.empty (gmm@mm) c
+	(*
+	| Fix ((_,j),(v,_,_)) ->
+	    v.(j) (* en pleine confiance ! *)
+	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" 
+        *)
+      in
+      mkCast (m,ty),[n,ty],[Some th]
+
+exception NoMeta
+
+let replace_in_array env gmm a =
+  if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then
+    raise NoMeta;
+  let a' = Array.map (function
+			| (TH (c,mm,[])) -> c,mm,[]
+			| th -> replace_by_meta env gmm th) a 
+  in
+  let v' = Array.map (fun (x,_,_) -> x) a' in
+  let mm = Array.fold_left (@) [] (Array.map (fun (_,x,_) -> x) a') in
+  let sgp = Array.fold_left (@) [] (Array.map (fun (_,_,x) -> x) a') in
+  v',mm,sgp
+    
+let fresh env n =
+  let id = match n with Name x -> x | _ -> id_of_string "_" in
+  next_global_ident_away true id (ids_of_named_context (named_context env))
+
+let rec compute_metamap env gmm c = match kind_of_term c with
+  (* le terme est directement une preuve *)
+  | (Const _ | Evar _ | Ind _ | Construct _ |
+    Sort _ | Var _ | Rel _) -> 
+      TH (c,[],[])
+  (* le terme est une mv => un but *)
+  | Meta n ->
+      (* 
+      Pp.warning (Printf.sprintf ("compute_metamap: MV(%d) sans type !\n") n);
+      let ty = Retyping.get_type_of_with_meta env Evd.empty lmeta c in 
+      *)
+      TH (c,[],[None])
+  | Cast (m,ty) when isMeta m -> 
+      TH (c,[destMeta m,ty],[None])
+
+  (* abstraction => il faut décomposer si le terme dessous n'est pas pur
+   *    attention : dans ce cas il faut remplacer (Rel 1) par (Var x)
+   *    où x est une variable FRAICHE *)
+  | Lambda (name,c1,c2) ->
+      let v = fresh env name in
+      let env' = push_named (v,None,c1) env in
+      begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with
+	(* terme de preuve complet *)
+	| TH (_,_,[]) -> TH (c,[],[])
+	(* terme de preuve incomplet *)    
+	| th ->
+	    let m,mm,sgp = replace_by_meta env' gmm th in
+	    TH (mkLambda (Name v,c1,m), mm, sgp)
+      end
+
+  | LetIn (name, c1, t1, c2) ->
+      if occur_meta c1 then 
+	error "Refine: body of let-in cannot contain existentials";
+      let v = fresh env name in
+      let env' = push_named (v,Some c1,t1) env in
+      begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with
+	(* terme de preuve complet *)
+	| TH (_,_,[]) -> TH (c,[],[])
+	(* terme de preuve incomplet *)    
+	| th ->
+	    let m,mm,sgp = replace_by_meta env' gmm th in
+	    TH (mkLetIn (Name v,c1,t1,m), mm, sgp)
+      end
+
+  (* 4. Application *)
+  | App (f,v) ->
+      let a = Array.map (compute_metamap env gmm) (Array.append [|f|] v) in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env gmm a in
+          let v'' = Array.sub v' 1 (Array.length v) in
+          TH (mkApp(v'.(0), v''),mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+  | Case (ci,p,cc,v) ->
+      (* bof... *)
+      let nbr = Array.length v in
+      let v = Array.append [|p;cc|] v in
+      let a = Array.map (compute_metamap env gmm) v in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env gmm a in
+	  let v'' = Array.sub v' 2 nbr in
+	  TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+  (* 5. Fix. *)
+  | Fix ((ni,i),(fi,ai,v)) ->
+      (* TODO: use a fold *)
+      let vi = Array.map (fresh env) fi in
+      let fi' = Array.map (fun id -> Name id) vi in
+      let env' = push_named_rec_types (fi',ai,v) env in
+      let a = Array.map
+		(compute_metamap env' gmm)
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+      in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env' gmm a in
+	  let fix = mkFix ((ni,i),(fi',ai,v')) in
+	  TH (fix,mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+	      
+  (* Cast. Est-ce bien exact ? *)
+  | Cast (c,t) -> compute_metamap env gmm c
+      (*let TH (c',mm,sgp) = compute_metamap sign c in
+	TH (mkCast (c',t),mm,sgp) *)
+      
+  (* Produit. Est-ce bien exact ? *)
+  | Prod (_,_,_) ->
+      if occur_meta c then
+	error "Refine: proof term contains metas in a product"
+      else
+      	TH (c,[],[])
+
+  (* Cofix. *)
+  | CoFix (i,(fi,ai,v)) ->
+      let vi = Array.map (fresh env) fi in
+      let fi' = Array.map (fun id -> Name id) vi in
+      let env' = push_named_rec_types (fi',ai,v) env in
+      let a = Array.map
+		(compute_metamap env' gmm)
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+      in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env' gmm a in
+	  let cofix = mkCoFix (i,(fi',ai,v')) in
+	  TH (cofix,mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+
+(*  tcc_aux : term_with_holes -> tactic
+ * 
+ *  Réalise le 3. ci-dessus
+ *)
+
+let rec tcc_aux subst (TH (c,mm,sgp) as th) gl =
+  let c = substl subst c in
+  match (kind_of_term c,sgp) with
+    (* mv => sous-but : on ne fait rien *)
+    | Meta _ , _ ->
+	tclIDTAC gl
+
+    | Cast (c,_), _ when isMeta c ->
+	tclIDTAC gl
+	  
+    (* terme pur => refine *)
+    | _,[] ->
+	refine c gl
+	
+    (* abstraction => intro *)
+    | Lambda (Name id,_,m), _ when isMeta (strip_outer_cast m) ->
+	begin match sgp with
+	  | [None] -> introduction id gl
+	  | [Some th] ->
+              tclTHEN (introduction id)
+                (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl
+	  | _ -> assert false
+	end
+	
+    | Lambda _, _ ->
+	anomaly "invalid lambda passed to function tcc_aux"
+
+    (* let in *)
+    | LetIn (Name id,c1,t1,c2), _ when isMeta (strip_outer_cast c2) ->
+	let c = pf_concl gl in
+	let newc = mkNamedLetIn id c1 t1 c in
+	tclTHEN 
+	  (change_in_concl None newc) 
+	  (match sgp with 
+	     | [None] -> introduction id
+	     | [Some th] ->
+                 tclTHEN (introduction id)
+                   (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th))
+	     | _ -> assert false) 
+	  gl
+
+    | LetIn _, _ ->
+	anomaly "invalid let-in passed to function tcc_aux"
+
+    (* fix => tactique Fix *)
+    | Fix ((ni,_),(fi,ai,_)) , _ ->
+	let out_name = function
+	  | Name id -> id
+          | _ -> error "recursive functions must have names !"
+	in
+	let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in
+	tclTHENS
+	  (mutual_fix (out_name fi.(0)) (succ ni.(0))
+	    (List.tl (Array.to_list fixes)))
+	  (List.map (function
+		       | None -> tclIDTAC 
+		       | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+    (* cofix => tactique CoFix *)
+    | CoFix (_,(fi,ai,_)) , _ ->
+	let out_name = function
+	  | Name id -> id
+          | _ -> error "recursive functions must have names !"
+	in
+	let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in
+	tclTHENS
+	  (mutual_cofix (out_name fi.(0)) (List.tl (Array.to_list cofixes)))
+	  (List.map (function
+		       | None -> tclIDTAC 
+		       | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+    (* sinon on fait refine du terme puis appels rec. sur les sous-buts.
+     * c'est le cas pour App et MutCase. *)
+    | _ ->
+	tclTHENS
+	  (refine c)
+	  (List.map
+            (function None -> tclIDTAC | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+(* Et finalement la tactique refine elle-même : *)
+
+let refine oc gl =
+  let sigma = project gl in
+  let env = pf_env gl in
+  let (gmm,c) = Clenv.exist_to_meta sigma oc in
+  let th = compute_metamap env gmm c in
+  tcc_aux [] th gl
+
diff --git a/tactics/refine.mli b/tactics/refine.mli
new file mode 100644
index 00000000..e053aea6
--- /dev/null
+++ b/tactics/refine.mli
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: refine.mli,v 1.7.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+open Term
+open Tacmach
+
+val refine : Pretyping.open_constr -> tactic
diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml
new file mode 100644
index 00000000..74b062e0
--- /dev/null
+++ b/tactics/setoid_replace.ml
@@ -0,0 +1,686 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: setoid_replace.ml,v 1.31.2.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Tacmach
+open Proof_type
+open Libobject
+open Reductionops
+open Term
+open Termops
+open Names
+open Entries
+open Libnames
+open Nameops
+open Util
+open Pp
+open Printer
+open Environ
+open Tactics 
+open Tacticals
+open Vernacexpr
+open Safe_typing
+open Nametab
+open Decl_kinds
+open Constrintern
+
+type setoid =
+    { set_a : constr;
+      set_aeq : constr;
+      set_th : constr
+    }
+
+type morphism =
+    { lem : constr;
+      profil : bool list;
+      arg_types : constr list;
+      lem2 : constr option
+    }
+
+let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
+
+let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s
+
+let global_constant dir s =Coqlib.gen_constant "Setoid_replace" ("Init"::dir) s
+
+let current_constant id =
+  try
+    global_reference id
+  with Not_found ->
+    anomaly ("Setoid: cannot find "^(string_of_id id))
+
+(* Setoid_theory *)
+
+let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory")
+
+let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl")
+let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym")
+let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans")
+
+let coq_fleche = lazy(constant ["Setoid"] "fleche")
+
+(* Coq constants *)
+
+let coqeq = lazy(global_constant ["Logic"] "eq")
+
+let coqconj = lazy(global_constant ["Logic"] "conj")
+let coqand = lazy(global_constant ["Logic"] "and")
+let coqproj1 = lazy(global_constant ["Logic"] "proj1")
+let coqproj2 = lazy(global_constant ["Logic"] "proj2")
+
+(************************* Table of declared setoids **********************)
+
+
+(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let setoid_table = ref Gmap.empty
+
+let setoid_table_add (s,th) = setoid_table := Gmap.add s th !setoid_table
+let setoid_table_find s = Gmap.find s !setoid_table
+let setoid_table_mem s = Gmap.mem s !setoid_table
+
+let subst_setoid subst setoid = 
+  let set_a' = subst_mps subst setoid.set_a in
+  let set_aeq' = subst_mps subst setoid.set_aeq in
+  let set_th' = subst_mps subst setoid.set_th in
+    if set_a' == setoid.set_a
+      && set_aeq' == setoid.set_aeq
+      && set_th' == setoid.set_th
+    then
+      setoid
+    else
+      { set_a = set_a' ;
+	set_aeq = set_aeq' ;
+	set_th = set_th' ;
+      }
+      
+let equiv_list () = List.map (fun x -> x.set_aeq) (Gmap.rng !setoid_table)
+
+let _ = 
+  Summary.declare_summary "setoid-table"
+    { Summary.freeze_function = (fun () -> !setoid_table);
+      Summary.unfreeze_function = (fun t -> setoid_table := t);
+      Summary.init_function = (fun () -> setoid_table := Gmap .empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* Declare a new type of object in the environment : "setoid-theory". *)
+
+let (setoid_to_obj, obj_to_setoid)=
+  let cache_set (_,(s, th)) = setoid_table_add (s,th)
+  and subst_set (_,subst,(s,th as obj)) =
+    let s' = subst_mps subst s in
+    let th' = subst_setoid subst th in
+      if s' == s && th' == th then obj else
+	(s',th')
+  and export_set x = Some x 
+  in 
+    declare_object {(default_object "setoid-theory") with
+		      cache_function = cache_set;
+		      open_function = (fun i o -> if i=1 then cache_set o);
+		      subst_function = subst_set;
+		      classify_function = (fun (_,x) -> Substitute x);
+		      export_function = export_set}
+
+(******************************* Table of declared morphisms ********************)
+
+(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
+
+let morphism_table = ref Gmap.empty
+
+let morphism_table_add (m,c) = morphism_table := Gmap.add m c !morphism_table
+let morphism_table_find m = Gmap.find m !morphism_table
+let morphism_table_mem m = Gmap.mem m !morphism_table
+
+let subst_morph subst morph = 
+  let lem' = subst_mps subst morph.lem in
+  let arg_types' = list_smartmap (subst_mps subst) morph.arg_types in
+  let lem2' = option_smartmap (subst_mps subst) morph.lem2 in
+    if lem' == morph.lem
+      && arg_types' == morph.arg_types
+      && lem2' == morph.lem2
+    then
+      morph
+    else
+      { lem = lem' ;
+	profil = morph.profil ;
+	arg_types = arg_types' ;
+	lem2 = lem2' ;
+      }
+
+
+let _ = 
+  Summary.declare_summary "morphism-table"
+    { Summary.freeze_function = (fun () -> !morphism_table);
+      Summary.unfreeze_function = (fun t -> morphism_table := t);
+      Summary.init_function = (fun () -> morphism_table := Gmap .empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* Declare a new type of object in the environment : "morphism-definition". *)
+
+let (morphism_to_obj, obj_to_morphism)=
+  let cache_set (_,(m, c)) = morphism_table_add (m, c)
+  and subst_set (_,subst,(m,c as obj)) = 
+    let m' = subst_mps subst m in
+    let c' = subst_morph subst c in
+      if m' == m && c' == c then obj else
+	(m',c')
+  and export_set x = Some x 
+  in 
+    declare_object {(default_object "morphism-definition") with
+		      cache_function = cache_set;
+		      open_function = (fun i o -> if i=1 then cache_set o);
+		      subst_function = subst_set;
+		      classify_function = (fun (_,x) -> Substitute x);
+		      export_function = export_set}
+
+(************************** Adding a setoid to the database *********************)
+
+(* Find the setoid theory associated with a given type A.
+This implies that only one setoid theory can be declared for
+a given type A. *)
+
+let find_theory a =
+  try 
+    setoid_table_find a 
+  with Not_found ->
+    errorlabstrm "Setoid" 
+      (str "No Declared Setoid Theory for " ++
+	 prterm a ++ fnl () ++
+	 str "Use Add Setoid to declare it")
+    
+(* Add a Setoid to the database after a type verification. *)
+
+let eq_lem_common_sign env a eq =
+  let na = named_hd env a Anonymous in
+  let ne = named_hd env eq Anonymous in
+  [(ne,None,mkApp (eq, [|(mkRel 3);(mkRel 2)|]));
+   (ne,None,mkApp (eq, [|(mkRel 4);(mkRel 3)|]));
+   (na,None,a);(na,None,a);(na,None,a);(na,None,a)]
+
+(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->(eq a c)->(eq b d) *)
+let eq_lem_proof env a eq sym trans = 
+  let sign = eq_lem_common_sign env a eq in
+  let ne = named_hd env eq Anonymous in
+  let sign = (ne,None,mkApp (eq, [|(mkRel 6);(mkRel 4)|]))::sign in
+  let ccl = mkApp (eq, [|(mkRel 6);(mkRel 4)|]) in
+  let body =
+    mkApp (trans,
+      [|(mkRel 6);(mkRel 7);(mkRel 4);
+        (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|]));
+	  (mkApp (trans,
+	    [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|]) in
+  let p = it_mkLambda_or_LetIn body sign in
+  let t = it_mkProd_or_LetIn ccl sign in
+  (p,t)
+
+(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->((eq a c)<->(eq b d)) *)
+let eq_lem2_proof env a eq sym trans =
+  let sign = eq_lem_common_sign env a eq in
+  let ccl1 =
+    mkArrow
+      (mkApp (eq, [|(mkRel 6);(mkRel 4)|]))
+      (mkApp (eq, [|(mkRel 6);(mkRel 4)|])) in
+  let ccl2 =
+    mkArrow
+      (mkApp (eq, [|(mkRel 5);(mkRel 3)|]))
+      (mkApp (eq, [|(mkRel 7);(mkRel 5)|])) in
+  let ccl = mkApp (Lazy.force coqand, [|ccl1;ccl2|]) in
+  let body =
+    mkApp ((Lazy.force coqconj),
+    [|ccl1;ccl2;
+      lambda_create env
+	(mkApp (eq, [|(mkRel 6);(mkRel 4)|]),
+	(mkApp (trans,
+	  [|(mkRel 6);(mkRel 7);(mkRel 4);
+	    (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|]));
+	    (mkApp (trans,
+	      [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|])));
+      lambda_create env
+        (mkApp (eq, [|(mkRel 5);(mkRel 3)|]),
+        (mkApp (trans,
+          [|(mkRel 7);(mkRel 6);(mkRel 5);(mkRel 3);
+            (mkApp (trans,
+              [|(mkRel 6);(mkRel 4);(mkRel 5);(mkRel 1);
+                (mkApp (sym, [|(mkRel 5);(mkRel 4);(mkRel 2)|]))|]))|])))|])
+  in
+  let p = it_mkLambda_or_LetIn body sign in
+  let t = it_mkProd_or_LetIn ccl sign in
+  (p,t)
+
+let gen_eq_lem_name =
+  let i = ref 0 in
+    function () -> 
+      incr i;
+      make_ident "setoid_eq_ext" (Some !i)
+
+let add_setoid a aeq th =
+  if setoid_table_mem a 
+  then errorlabstrm "Add Setoid"
+    (str "A Setoid Theory is already declared for " ++ prterm a)
+  else let env = Global.env () in
+    if (is_conv env Evd.empty (Typing.type_of env Evd.empty th)
+	  (mkApp ((Lazy.force coq_Setoid_Theory), [| a; aeq |])))
+    then (Lib.add_anonymous_leaf 
+	    (setoid_to_obj 
+	       (a, { set_a = a;
+		     set_aeq = aeq;
+		     set_th = th}));
+	  let sym = mkApp ((Lazy.force coq_seq_sym), [|a; aeq; th|]) in
+	  let trans = mkApp ((Lazy.force coq_seq_trans), [|a; aeq; th|]) in
+	  let (eq_morph, eq_morph_typ) = eq_lem_proof env a aeq sym trans in
+	  let (eq_morph2, eq_morph2_typ) = eq_lem2_proof env a aeq sym trans in
+	    Options.if_verbose ppnl (prterm a ++str " is registered as a setoid");
+	    let eq_ext_name = gen_eq_lem_name () in 
+	    let eq_ext_name2 = gen_eq_lem_name () in 
+	    let _ = Declare.declare_constant eq_ext_name
+		      ((DefinitionEntry {const_entry_body = eq_morph; 
+		                       const_entry_type = Some eq_morph_typ;
+                                       const_entry_opaque = true}),
+		       IsProof Lemma) in
+	    let _ = Declare.declare_constant eq_ext_name2
+		      ((DefinitionEntry {const_entry_body = eq_morph2; 
+				       const_entry_type = Some eq_morph2_typ;
+                                       const_entry_opaque = true}),
+		       IsProof Lemma) in
+	    let eqmorph = (current_constant eq_ext_name) in
+	    let eqmorph2 = (current_constant eq_ext_name2) in
+	      (Lib.add_anonymous_leaf
+		 (morphism_to_obj (aeq, 
+				   { lem = eqmorph;
+				     profil = [true; true];
+				     arg_types = [a;a];
+				     lem2 = (Some eqmorph2)})));
+	      Options.if_verbose ppnl (prterm aeq ++str " is registered as a morphism"))
+    else errorlabstrm "Add Setoid" (str "Not a valid setoid theory")
+
+(* The vernac command "Add Setoid" *)
+let add_setoid a aeq th =
+  add_setoid (constr_of a) (constr_of aeq) (constr_of th)
+
+(***************** Adding a morphism to the database ****************************)
+
+(* We maintain a table of the currently edited proofs of morphism lemma
+   in order to add them in the morphism_table when the user does Save *)
+
+let edited = ref Gmap.empty
+
+let new_edited id m profil = 
+  edited := Gmap.add id (m,profil)  !edited
+
+let is_edited id =
+  Gmap.mem id !edited
+
+let no_more_edited id =
+  edited := Gmap.remove id !edited
+
+let what_edited id =
+  Gmap.find id !edited
+
+let check_is_dependent t n =
+  let rec aux t i n =
+    if (i<n)
+    then (dependent (mkRel i) t) || (aux t (i+1) n)
+    else false
+  in aux t 0 n
+
+let gen_lem_name m = match kind_of_term m with 
+  | Var id -> add_suffix id "_ext"
+  | Const kn -> add_suffix (id_of_label (label kn)) "_ext"
+  | Ind (kn, i) -> add_suffix (id_of_label (label kn)) ((string_of_int i)^"_ext")
+  | Construct ((kn,i),j) -> add_suffix
+      (id_of_label (label kn)) ((string_of_int i)^(string_of_int j)^"_ext")
+  | _ -> errorlabstrm "New Morphism" (str "The term " ++ prterm m ++ str "is not a known name")
+
+let gen_lemma_tail m lisset body n =
+  let l = (List.length lisset) in
+  let a1 = Array.create l (mkRel 0) in
+  let a2 = Array.create l (mkRel 0) in
+  let rec aux i n = function
+    | true::q -> 
+	a1.(i) <- (mkRel n);
+	a2.(i) <- (mkRel (n-1));
+	aux (i+1) (n-2) q
+    | false::q ->
+	a1.(i) <- (mkRel n);
+	a2.(i) <- (mkRel n);
+	aux (i+1) (n-1) q
+    | [] -> () in 
+    aux 0 n lisset;
+    if (eq_constr body mkProp)
+    then mkArrow (mkApp (m,a1)) (lift 1 (mkApp (m, a2)))
+    else if (setoid_table_mem body)
+    then mkApp ((setoid_table_find body).set_aeq, [|(mkApp (m, a1)); (mkApp (m, a2))|])
+    else mkApp ((Lazy.force coqeq), [|body; (mkApp (m, a1)); (mkApp (m, a2))|])
+
+let gen_lemma_middle m larg lisset body n =
+  let rec aux la li i n = match (la, li) with
+    | ([], []) -> gen_lemma_tail m lisset body n
+    | (t::q, true::lq) -> 
+	mkArrow (mkApp ((setoid_table_find t).set_aeq, 
+			[|(mkRel i); (mkRel (i-1))|])) (aux q lq (i-1) (n+1))
+    | (t::q, false::lq) -> aux q lq (i-1) n
+    | _ -> assert false
+  in aux larg lisset n n
+
+let gen_compat_lemma env m body larg lisset = 
+  let rec aux la li n = match (la, li) with
+    | (t::q, true::lq) -> 
+	prod_create env (t,(prod_create env (t, (aux q lq (n+2)))))
+    | (t::q, false::lq) -> 
+	prod_create env (t, (aux q lq (n+1)))
+    | ([],[]) -> gen_lemma_middle m larg lisset body n
+    | _ -> assert false
+  in aux larg lisset 0
+
+let new_morphism m id hook =
+  if morphism_table_mem m
+  then errorlabstrm "New Morphism"
+    (str "The term " ++ prterm m ++ str " is already declared as a morphism")
+  else 
+    let env = Global.env() in
+    let typeofm = (Typing.type_of env Evd.empty m) in
+    let typ = (nf_betaiota typeofm) in  (* nf_bdi avant, mais bug *)
+    let (argsrev, body) = (decompose_prod typ) in
+    let args = (List.rev argsrev) in
+      if (args=[])
+      then errorlabstrm "New Morphism"
+	(str "The term " ++ prterm m ++ str " is not a product")
+      else if (check_is_dependent typ (List.length args))
+      then  errorlabstrm "New Morphism"
+	(str "The term " ++ prterm m ++ str " should not be a dependent product")
+      else (
+	let args_t = (List.map snd args) in
+	let poss = (List.map setoid_table_mem args_t) in
+	let lem = (gen_compat_lemma env m body args_t poss) in
+	new_edited id m poss;
+	Pfedit.start_proof id (IsGlobal (Proof Lemma)) 
+	  (Declare.clear_proofs (Global.named_context ()))
+	  lem hook;
+	(Options.if_verbose msg (Pfedit.pr_open_subgoals ())))
+
+let rec sub_bool l1 n = function
+  | [] -> []
+  | true::q -> ((List.hd l1), n)::(sub_bool (List.tl l1) (n-2) q)
+  | false::q -> (sub_bool (List.tl l1) (n-1) q)
+
+let gen_lemma_iff_tail m mext larg lisset n k =
+  let a1 = Array.create k (mkRel 0) in
+  let a2 = Array.create k (mkRel 0) in
+  let nb = List.length lisset in
+  let b1 = Array.create nb (mkRel 0) in
+  let b2 = Array.create nb (mkRel 0) in
+  let rec aux i j = function
+    |[] -> ()
+    |true::q ->
+       (a1.(i) <- (mkRel j);
+	a1.(i+1) <- (mkRel (j-1));
+	a2.(i) <- (mkRel (j-1));
+	a2.(i+1) <- (mkRel j);
+	aux (i+2) (j-2) q)
+    |false::q ->
+       (a1.(i) <- (mkRel j);
+	a2.(i) <- (mkRel j);
+	aux (i+1) (j-1) q) in
+  let rec aux2 i j = function
+    | (t,p)::q -> 
+	let th = (setoid_table_find t).set_th
+	and equiv = (setoid_table_find t).set_aeq in
+	  a1.(i) <- (mkRel j);
+	  a2.(i) <- mkApp ((Lazy.force coq_seq_sym),
+			   [|t; equiv; th; (mkRel p); (mkRel (p-1)); (mkRel j)|]);
+	  aux2 (i+1) (j-1) q
+    | [] -> () in
+  let rec aux3 i j = function
+    | true::q -> 
+	b1.(i) <- (mkRel j);
+	b2.(i) <- (mkRel (j-1));
+	aux3 (i+1) (j-2) q
+    | false::q ->
+	b1.(i) <- (mkRel j);
+	b2.(i) <- (mkRel j);
+	aux3 (i+1) (j-1) q
+    | [] -> () in 
+    aux 0 k lisset;
+    aux2 n (k-n) (sub_bool larg k lisset);
+    aux3 0 k lisset;
+    mkApp ((Lazy.force coqconj),
+	   [|(mkArrow (mkApp (m,b1)) (lift 1 (mkApp (m, b2))));
+	     (mkArrow (mkApp (m,b2)) (lift 1 (mkApp (m, b1))));
+	     (mkApp (mext, a1));(mkApp (mext, a2))|])
+
+let gen_lemma_iff_middle env m mext larg lisset n =
+  let rec aux la li i k = match (la, li) with
+    | ([], []) -> gen_lemma_iff_tail m mext larg lisset n k
+    | (t::q, true::lq) -> 
+	lambda_create env ((mkApp ((setoid_table_find t).set_aeq, [|(mkRel i); (mkRel (i-1))|])),
+			   (aux q lq (i-1) (k+1)))
+    | (t::q, false::lq) -> aux q lq (i-1) k
+    | _ -> assert false
+  in aux larg lisset n n
+
+let gen_lem_iff env m mext larg lisset =
+  let rec aux la li n = match (la, li) with
+    | (t::q, true::lq) -> 
+	lambda_create env (t,(lambda_create env (t, (aux q lq (n+2)))))
+    | (t::q, false::lq) -> 
+	lambda_create env (t, (aux q lq (n+1)))
+    | ([],[]) -> gen_lemma_iff_middle env m mext larg lisset n
+    | _ -> assert false
+  in aux larg lisset 0
+
+let add_morphism lem_name (m,profil) =
+  if morphism_table_mem m
+  then errorlabstrm "New Morphism"
+    (str "The term " ++ prterm m ++ str " is already declared as a morpism")
+  else 
+    let env = Global.env() in
+    let mext = (current_constant lem_name) in
+    let typeofm = (Typing.type_of env Evd.empty m) in
+    let typ = (nf_betaiota typeofm) in
+    let (argsrev, body) = (decompose_prod typ) in
+    let args = List.rev argsrev in
+    let args_t = (List.map snd args) in
+    let poss = (List.map setoid_table_mem args_t) in
+    let _ = assert (poss=profil) in
+      (if (eq_constr body mkProp)
+       then
+	 (let lem_2 = gen_lem_iff env m mext args_t poss in
+	  let lem2_name = add_suffix lem_name "2" in
+	  let _ = Declare.declare_constant lem2_name
+		    ((DefinitionEntry {const_entry_body = lem_2; 
+				     const_entry_type = None;
+                                     const_entry_opaque = true}),
+		     IsProof Lemma) in
+	  let lem2 = (current_constant lem2_name) in
+	    (Lib.add_anonymous_leaf
+	       (morphism_to_obj (m, 
+				 { lem = mext;
+				   profil = poss;
+				   arg_types = args_t;
+				   lem2 = (Some lem2)})));
+	    Options.if_verbose message ((string_of_id lem2_name) ^ " is defined"))
+       else
+	 (Lib.add_anonymous_leaf
+	    (morphism_to_obj (m, 
+			      { lem = mext;
+				profil = poss;
+				arg_types = args_t;
+				lem2 = None}))));
+      Options.if_verbose ppnl (prterm m ++str " is registered as a morphism")   
+let morphism_hook stre ref =
+  let pf_id = id_of_global ref in
+  if (is_edited pf_id)
+  then 
+    (add_morphism pf_id (what_edited pf_id); no_more_edited pf_id)
+
+let new_named_morphism id m = new_morphism (constr_of m) id morphism_hook
+
+(****************************** The tactic itself *******************************)
+
+type constr_with_marks =
+  | MApp of constr_with_marks array 
+  | Toreplace
+  | Tokeep
+  | Mimp of constr_with_marks * constr_with_marks
+
+let is_to_replace = function
+  | Tokeep -> false
+  | Toreplace -> true
+  | MApp _ -> true
+  | Mimp _ -> true
+
+let get_mark a = 
+  Array.fold_left (||) false (Array.map is_to_replace a)
+
+let rec mark_occur t in_c =
+  if (eq_constr t in_c) then Toreplace else
+    match kind_of_term in_c with
+      | App (c,al) -> 
+	  let a = Array.map (mark_occur t) al
+	  in if (get_mark a) then (MApp a) else Tokeep
+      | Prod (_, c1, c2) -> 
+	  if (dependent (mkRel 1) c2)
+	  then Tokeep
+	  else 
+	    let c1m = mark_occur t c1 in
+	    let c2m = mark_occur t c2 in
+	      if ((is_to_replace c1m)||(is_to_replace c2m))
+	      then (Mimp (c1m, c2m))
+	      else Tokeep
+      | _ -> Tokeep
+
+let create_args ca ma bl c1 c2 = 
+  let rec aux i = function
+    | [] -> []
+    | true::q -> 
+	if (is_to_replace ma.(i)) 
+	then (replace_term c1 c2 ca.(i))::ca.(i)::(aux (i+1) q)
+	else ca.(i)::ca.(i)::(aux (i+1) q)
+    | false::q -> ca.(i)::(aux (i+1) q)
+  in
+    aux 0 bl
+
+
+let res_tac c a hyp =
+  let sa = setoid_table_find a in
+  let fin = match hyp with
+    | None -> Auto.full_trivial
+    | Some h -> 
+	tclORELSE (tclTHEN (tclTRY (apply h)) (tclFAIL 0 "")) 
+	(tclORELSE (tclTHEN (tclTRY (tclTHEN (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|]))) (apply h))) (tclFAIL 0 ""))
+	   Auto.full_trivial) in
+    tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th;c|])))) (tclFAIL 0 ""))
+      (tclORELSE assumption
+	 (tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|])))) assumption)
+	    fin))
+
+let id_res_tac c a = 
+  let sa = setoid_table_find a in
+    (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th; c|]))))
+
+(* An exception to catchs errors *)
+
+exception Nothing_found of constr;;
+
+let rec create_tac_list i a al c1 c2 hyp args_t = function
+  | [] -> []
+  | false::q -> create_tac_list (i+1) a al c1 c2 hyp args_t q
+  | true::q -> 
+      if (is_to_replace a.(i))
+      then (zapply false al.(i) a.(i) c1 c2 hyp)::(create_tac_list (i+1) a al c1 c2 hyp args_t q)
+      else (id_res_tac al.(i) (List.nth args_t i))::(create_tac_list (i+1) a al c1 c2 hyp args_t q)
+(*      else tclIDTAC::(create_tac_list (i+1) a al c1 c2 hyp q) *)
+
+and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with
+  | ((App (c,al)),(MApp a)) -> (
+      try 
+	let m = morphism_table_find c in
+	let args = Array.of_list (create_args al a m.profil c1 c2) in
+	  if is_r
+	  then tclTHENS (apply (mkApp (m.lem, args)))
+	    ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC])
+ 	  else (match m.lem2 with
+		  | None -> 
+		      tclTHENS (apply (mkApp (m.lem, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)
+		  | Some xom -> 
+		      tclTHENS (apply (mkApp (xom, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil))
+      with Not_found -> errorlabstrm "Setoid_replace" 
+	  (str "The term " ++ prterm c ++ str " has not been declared as a morphism"))
+  | ((Prod (_,hh, cc)),(Mimp (hhm, ccm))) ->
+      let al = [|hh; cc|] in
+      let a = [|hhm; ccm|] in
+      let fleche_constr = (Lazy.force coq_fleche) in
+      let fleche_cp = destConst fleche_constr in
+      let new_concl = (mkApp (fleche_constr, al)) in
+	if is_r 
+	then
+	  let m = morphism_table_find fleche_constr in
+	  let args = Array.of_list (create_args al a m.profil c1 c2) in  
+	    tclTHEN (change_in_concl None new_concl)
+	      (tclTHENS (apply (mkApp (m.lem, args)))
+		 ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[unfold_constr (ConstRef fleche_cp)]))
+(*		 ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC])) *)
+	else (zapply is_r new_concl (MApp a) c1 c2 hyp)
+(*      let args = Array.of_list (create_args [|hh; cc|] [|hhm; ccm|] [true;true] c1 c2) in
+	if is_r
+	then tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext), args)))
+	  ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC])
+	else tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext2), args)))
+	  ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC])
+*)
+  | (_, Toreplace) -> 
+      if is_r 
+      then (match hyp with
+	      | None -> errorlabstrm "Setoid_replace"
+		  (str "You should use the tactic Replace here")
+	      | Some h ->
+		  let hypt = pf_type_of glll h in
+		  let (heq, hargs) = decompose_app hypt in
+		  let rec get_last_two = function
+		    | [c1;c2] -> (c1, c2)
+		    | x::y::z -> get_last_two (y::z)
+		    | _ -> assert false in
+		  let (hc1,hc2) = get_last_two hargs in
+		    if c1 = hc1
+		    then 				     
+		      apply (mkApp (Lazy.force coqproj2,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|]))
+		    else 
+		      apply (mkApp (Lazy.force coqproj1,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|]))
+	   )
+      else (res_tac gl (pf_type_of glll gl) hyp) (* tclORELSE Auto.full_trivial tclIDTAC *)
+  | (_, Tokeep) -> (match hyp with 
+		      | None -> errorlabstrm "Setoid_replace"
+			  (str "No replacable occurence of " ++ prterm c1 ++ str " found")
+		      | Some _ ->errorlabstrm "Setoid_replace"
+			  (str "No rewritable occurence of " ++ prterm c1 ++ str " found"))
+  | _ -> anomaly ("Bug in Setoid_replace")) glll
+
+let setoid_replace c1 c2 hyp gl =
+  let but = (pf_concl gl) in
+    (zapply true but (mark_occur c1 but) c1 c2 hyp) gl
+
+let general_s_rewrite lft2rgt c gl =
+  let ctype = pf_type_of gl c in
+  let (equiv, args) = decompose_app ctype in
+  let rec get_last_two = function
+    | [c1;c2] -> (c1, c2)
+    | x::y::z -> get_last_two (y::z)
+    | _ -> error "The term provided is not an equivalence" in 
+  let (c1,c2) = get_last_two args in
+    if lft2rgt
+    then setoid_replace c1 c2 (Some c) gl
+    else setoid_replace c2 c1 (Some c) gl
+
+let setoid_rewriteLR = general_s_rewrite true
+
+let setoid_rewriteRL = general_s_rewrite false
diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli
new file mode 100644
index 00000000..565ae169
--- /dev/null
+++ b/tactics/setoid_replace.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: setoid_replace.mli,v 1.3.6.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Term
+open Proof_type
+open Topconstr
+
+val equiv_list : unit -> constr list
+
+val setoid_replace : constr -> constr -> constr option -> tactic
+
+val setoid_rewriteLR : constr -> tactic
+
+val setoid_rewriteRL : constr -> tactic
+
+val general_s_rewrite : bool -> constr -> tactic
+
+val add_setoid : constr_expr -> constr_expr -> constr_expr -> unit
+
+val new_named_morphism : Names.identifier -> constr_expr -> unit
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
new file mode 100644
index 00000000..2080b5dc
--- /dev/null
+++ b/tactics/tacinterp.ml
@@ -0,0 +1,2236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tacinterp.ml,v 1.84.2.4 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Constrintern
+open Closure
+open RedFlags
+open Declarations
+open Entries
+open Dyn
+open Libobject
+open Pattern
+open Matching
+open Pp
+open Rawterm
+open Sign
+open Tacred
+open Util
+open Names
+open Nameops
+open Libnames
+open Nametab
+open Pfedit
+open Proof_type
+open Refiner
+open Tacmach
+open Tactic_debug
+open Topconstr
+open Ast
+open Term
+open Termops
+open Tacexpr
+open Safe_typing
+open Typing
+open Hiddentac
+open Genarg
+open Decl_kinds
+
+let strip_meta id = (* For Grammar v7 compatibility *)
+  let s = string_of_id id in
+  if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
+  else id
+
+let error_syntactic_metavariables_not_allowed loc =
+  user_err_loc 
+    (loc,"out_ident",
+     str "Syntactic metavariables allowed only in quotations")
+
+let skip_metaid = function
+  | AI x -> x
+  | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc
+
+type ltac_type =
+  | LtacFun of ltac_type
+  | LtacBasic
+  | LtacTactic
+
+(* Values for interpretation *)
+type value =
+  | VTactic of loc * tactic  (* For mixed ML/Ltac tactics (e.g. Tauto) *)
+  | VRTactic of (goal list sigma * validation) (* For Match results *)
+                                               (* Not a true value *)
+  | VFun of (identifier*value) list * identifier option list * glob_tactic_expr
+  | VVoid
+  | VInteger of int
+  | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
+                        (* bound as in "Intro H" but which may be bound *)
+                        (* later, as in "tac" in "Intro H; tac" *)
+  | VConstr of constr   (* includes idents known bound and references *)
+  | VConstr_context of constr
+  | VRec of value ref
+
+let locate_tactic_call loc = function
+  | VTactic (_,t) -> VTactic (loc,t)
+  | v -> v
+
+let locate_error_in_file dir = function
+  | Stdpp.Exc_located (loc,e) -> Error_in_file ("",(true,dir,loc),e)
+  | e -> Error_in_file ("",(true,dir,dummy_loc),e)
+
+let catch_error loc tac g =
+  try tac g
+  with e when loc <> dummy_loc ->
+    match e with
+      |	Stdpp.Exc_located (_,e) -> raise (Stdpp.Exc_located (loc,e))
+      |	e -> raise (Stdpp.Exc_located (loc,e))
+
+(* Signature for interpretation: val_interp and interpretation functions *)
+type interp_sign =
+  { lfun : (identifier * value) list;
+    debug : debug_info }
+
+let check_is_value = function
+  | VRTactic _ -> (* These are goals produced by Match *)
+   error "Immediate match producing tactics not allowed in local definitions"
+  | _ -> ()
+
+(* For tactic_of_value *)
+exception NotTactic
+
+(* Gives the constr corresponding to a Constr_context tactic_arg *)
+let constr_of_VConstr_context = function
+  | VConstr_context c -> c
+  | _ ->
+    errorlabstrm "constr_of_VConstr_context" (str "not a context variable")
+
+(* Displays a value *)
+let pr_value env = function
+  | VVoid -> str "()"
+  | VInteger n -> int n
+  | VIntroPattern ipat -> pr_intro_pattern ipat
+  | VConstr c -> Printer.prterm_env env c
+  | VConstr_context c -> Printer.prterm_env env c
+  | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "<fun>"
+
+(* Transforms a named_context into a (string * constr) list *)
+let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
+
+(* Transforms an id into a constr if possible, or fails *)
+let constr_of_id env id = 
+  construct_reference (Environ.named_context env) id
+
+(* To embed several objects in Coqast.t *)
+let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t),
+     (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) =
+  create "tactic"
+
+let ((value_in : value -> Dyn.t),
+     (value_out : Dyn.t -> value)) = create "value"
+
+let tacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
+let tacticOut = function
+  | TacArg (TacDynamic (_,d)) ->
+    if (tag d) = "tactic" then
+      tactic_out d
+    else
+      anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
+  | ast ->
+    anomalylabstrm "tacticOut"
+      (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
+
+let valueIn t = TacDynamic (dummy_loc,value_in t)
+let valueOut = function
+  | TacDynamic (_,d) ->
+    if (tag d) = "value" then
+      value_out d
+    else
+      anomalylabstrm "valueOut" (str "Dynamic tag should be value")
+  | ast ->
+    anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
+
+(* To embed constr in Coqast.t *)
+let constrIn t = CDynamic (dummy_loc,Pretyping.constr_in t)
+let constrOut = function
+  | CDynamic (_,d) ->
+    if (Dyn.tag d) = "constr" then
+      Pretyping.constr_out d
+    else
+      anomalylabstrm "constrOut" (str "Dynamic tag should be constr")
+  | ast ->
+    anomalylabstrm "constrOut" (str "Not a Dynamic ast")
+let loc = dummy_loc
+
+(* Table of interpretation functions *)
+let interp_tab =
+  (Hashtbl.create 17 : (string , interp_sign -> Coqast.t -> value) Hashtbl.t)
+
+(* Adds an interpretation function *)
+let interp_add (ast_typ,interp_fun) =
+  try
+    Hashtbl.add interp_tab ast_typ interp_fun
+  with
+      Failure _ ->
+        errorlabstrm "interp_add"
+          (str "Cannot add the interpretation function for " ++ str ast_typ ++            str " twice")
+
+(* Adds a possible existing interpretation function *)
+let overwriting_interp_add (ast_typ,interp_fun) =
+  if Hashtbl.mem interp_tab ast_typ then
+  begin
+    Hashtbl.remove interp_tab ast_typ;
+    warning ("Overwriting definition of tactic interpreter command " ^ ast_typ)
+  end;
+  Hashtbl.add interp_tab ast_typ interp_fun
+
+(* Finds the interpretation function corresponding to a given ast type *)
+let look_for_interp = Hashtbl.find interp_tab
+
+(* Globalizes the identifier *)
+
+let find_reference env qid =
+  (* We first look for a variable of the current proof *)
+  match repr_qualid qid with
+    | (d,id) when repr_dirpath d = [] & List.mem id (ids_of_context env)
+	-> VarRef id
+    | _ -> Nametab.locate qid
+
+let coerce_to_reference env = function
+  | VConstr c ->
+      (try reference_of_constr c
+      with Not_found -> invalid_arg_loc (loc, "Not a reference"))
+  | v -> errorlabstrm "coerce_to_reference"
+      (str "The value" ++ spc () ++ pr_value env v ++ 
+       str "cannot be coerced to a reference")
+
+(* turns a value into an evaluable reference *)
+let error_not_evaluable s =
+  errorlabstrm "evalref_of_ref" 
+    (str "Cannot coerce" ++ spc ()  ++ s ++ spc () ++
+     str "to an evaluable reference")
+
+let coerce_to_evaluable_ref env c =
+  let ev = match c with
+    | VConstr c when isConst c -> EvalConstRef (destConst c)
+    | VConstr c when isVar c -> EvalVarRef (destVar c)
+    | VIntroPattern (IntroIdentifier id)
+        when Environ.evaluable_named id env -> EvalVarRef id
+    | _ -> error_not_evaluable (pr_value env c)
+  in
+  if not (Tacred.is_evaluable env ev) then
+    error_not_evaluable (pr_value env c);
+  ev
+
+let coerce_to_inductive = function
+  | VConstr c when isInd c -> destInd c
+  | x ->
+      try
+	let r = match x with
+	  | VConstr c -> reference_of_constr c
+	  | _ -> failwith "" in
+	errorlabstrm "coerce_to_inductive"
+          (Printer.pr_global r ++ str " is not an inductive type")
+      with _ ->
+	errorlabstrm "coerce_to_inductive"
+          (str "Found an argument which should be an inductive type")
+
+
+(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
+let atomic_mactab = ref Idmap.empty
+let add_primitive_tactic s tac =
+  (if not !Options.v7 then
+    let id = id_of_string s in
+    atomic_mactab := Idmap.add id tac !atomic_mactab)
+
+let _ =
+  if not !Options.v7 then
+    (let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in
+    List.iter
+      (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t)))
+      [ "red", TacReduce(Red false,nocl);
+        "hnf", TacReduce(Hnf,nocl);
+        "simpl", TacReduce(Simpl None,nocl);
+        "compute", TacReduce(Cbv all_flags,nocl);
+        "intro", TacIntroMove(None,None);
+        "intros", TacIntroPattern [];
+        "assumption", TacAssumption;
+        "cofix", TacCofix None;
+        "trivial", TacTrivial None;
+        "auto", TacAuto(None,None);
+        "left", TacLeft NoBindings;
+        "right", TacRight NoBindings;
+        "split", TacSplit(false,NoBindings);
+        "constructor", TacAnyConstructor None;
+        "reflexivity", TacReflexivity;
+        "symmetry", TacSymmetry nocl
+      ];
+    List.iter
+      (fun (s,t) -> add_primitive_tactic s t)
+      [ "idtac",TacId "";
+        "fail", TacFail(ArgArg 0,"");
+        "fresh", TacArg(TacFreshId None)
+      ])
+ 
+let lookup_atomic id = Idmap.find id !atomic_mactab
+let is_atomic id = Idmap.mem id !atomic_mactab
+let is_atomic_kn kn =
+  let (_,_,l) = repr_kn kn in
+  is_atomic (id_of_label l)
+
+(* Summary and Object declaration *)
+let mactab = ref Gmap.empty
+
+let lookup r = Gmap.find r !mactab
+
+let _ =
+  let init () = mactab := Gmap.empty in
+  let freeze () = !mactab in
+  let unfreeze fs = mactab := fs in
+  Summary.declare_summary "tactic-definition"
+    { Summary.freeze_function   = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function     = init;
+      Summary.survive_module = false;
+      Summary.survive_section   = false }
+
+(* Interpretation of extra generic arguments *)
+type glob_sign = {
+  ltacvars : identifier list * identifier list;
+     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
+  ltacrecvars : (identifier * ltac_constant) list;
+     (* ltac recursive names *)
+  gsigma : Evd.evar_map;
+  genv : Environ.env }
+
+type interp_genarg_type =
+  (glob_sign -> raw_generic_argument -> glob_generic_argument) *
+  (interp_sign -> goal sigma -> glob_generic_argument -> 
+    closed_generic_argument) *
+  (Names.substitution -> glob_generic_argument -> glob_generic_argument)
+
+let extragenargtab =
+  ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
+let add_interp_genarg id f =
+  extragenargtab := Gmap.add id f !extragenargtab
+let lookup_genarg id = 
+  try Gmap.find id !extragenargtab
+  with Not_found -> failwith ("No interpretation function found for entry "^id)
+
+let lookup_genarg_glob   id = let (f,_,_) = lookup_genarg id in f
+let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
+let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
+
+(* Unboxes VRec *)
+let unrec = function
+  | VRec v -> !v
+  | a -> a
+
+(*****************)
+(* Globalization *)
+(*****************)
+
+(* We have identifier <| global_reference <| constr *)
+
+let find_ident id sign = 
+  List.mem id (fst sign.ltacvars) or 
+  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+
+let find_recvar qid sign = List.assoc qid sign.ltacrecvars
+
+(* a "var" is a ltac var or a var introduced by an intro tactic *)
+let find_var id sign = List.mem id (fst sign.ltacvars)
+
+(* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *)
+let find_ctxvar id sign = List.mem id (snd sign.ltacvars)
+
+(* a "ltacvar" is an ltac var (Let-In/Fun/...) *)
+let find_ltacvar id sign = find_var id sign & not (find_ctxvar id sign)
+
+let find_hyp id sign =
+  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+
+(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
+(* be fresh in which case it is binding later on *)
+let intern_ident l ist id =
+  (* We use identifier both for variables and new names; thus nothing to do *)
+  if not (find_ident id ist) then l:=(id::fst !l,id::snd !l);
+  id
+
+let intern_name l ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (intern_ident l ist id)
+
+let vars_of_ist (lfun,_,_,env) =
+  List.fold_left (fun s id -> Idset.add id s)
+    (vars_of_env env) lfun
+
+let get_current_context () =
+    try Pfedit.get_current_goal_context ()
+    with e when Logic.catchable_exception e -> 
+      (Evd.empty, Global.env())
+
+let strict_check = ref false
+
+let adjust_loc loc = if !strict_check then dummy_loc else loc
+
+(* Globalize a name which must be bound -- actually just check it is bound *)
+let intern_hyp ist (loc,id as locid) =
+  let (_,env) = get_current_context () in
+  if not !strict_check then
+    locid
+  else if find_ident id ist then
+    (dummy_loc,id)
+  else
+    Pretype_errors.error_var_not_found_loc loc id
+
+let intern_hyp_or_metaid ist id = intern_hyp ist (skip_metaid id)
+
+let intern_int_or_var ist = function
+  | ArgVar locid as x -> ArgVar (intern_hyp ist locid)
+  | ArgArg n as x -> x
+
+let intern_inductive ist = function
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
+  | r -> ArgArg (Nametab.global_inductive r)
+
+exception NotSyntacticRef
+
+let locate_reference qid =
+  match Nametab.extended_locate qid with
+    | TrueGlobal ref -> ref
+    | SyntacticDef kn -> 
+	match Syntax_def.search_syntactic_definition loc kn with
+	  | Rawterm.RRef (_,ref) -> ref
+	  | _ -> raise NotSyntacticRef
+
+let intern_global_reference ist = function
+  | Ident (loc,id) as r when find_var id ist -> ArgVar (loc,id)
+  | r -> 
+      let loc,qid = qualid_of_reference r in
+      try ArgArg (loc,locate_reference qid)
+      with _ -> 
+	error_global_not_found_loc loc qid
+
+let intern_tac_ref ist = function
+  | Ident (loc,id) when find_ltacvar id ist -> ArgVar (loc,id)
+  | Ident (loc,id) ->
+      ArgArg (loc,
+         try find_recvar id ist 
+         with Not_found -> locate_tactic (make_short_qualid id))
+  | r -> 
+      let (loc,qid) = qualid_of_reference r in
+      ArgArg (loc,locate_tactic qid)
+
+let intern_tactic_reference ist r =
+  try intern_tac_ref ist r
+  with Not_found -> 
+    let (loc,qid) = qualid_of_reference r in
+    error_global_not_found_loc loc qid
+
+let intern_constr_reference strict ist = function
+  | Ident (_,id) when (not strict & find_hyp id ist) or find_ctxvar id ist ->
+      RVar (loc,id), None
+  | r ->
+      let loc,qid = qualid_of_reference r in
+      RRef (loc,locate_reference qid), if strict then None else Some (CRef r)
+
+let intern_reference strict ist = function
+  | Ident (loc,id) when is_atomic id -> Tacexp (lookup_atomic id)
+  | r ->
+      (try Reference (intern_tac_ref ist r)
+      with Not_found ->
+        (try
+          ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+        with Not_found ->
+          (match r with
+            | Ident (loc,id) when not strict -> 
+		IntroPattern (IntroIdentifier id)
+            | _ ->
+                let (loc,qid) = qualid_of_reference r in
+                error_global_not_found_loc loc qid)))
+
+let rec intern_intro_pattern lf ist = function
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (intern_case_intro_pattern lf ist l)
+  | IntroWildcard ->
+      IntroWildcard
+  | IntroIdentifier id ->
+      IntroIdentifier (intern_ident lf ist id)
+
+and intern_case_intro_pattern lf ist =
+  List.map (List.map (intern_intro_pattern lf ist))
+
+let intern_quantified_hypothesis ist x =
+  (* We use identifier both for variables and quantified hyps (no way to
+     statically check the existence of a quantified hyp); thus nothing to do *)
+  x
+
+let intern_constr {ltacvars=lfun; gsigma=sigma; genv=env} c =
+  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
+  let c' = 
+    warn (Constrintern.interp_rawconstr_gen false sigma env 
+      false (fst lfun,[])) c in
+  begin if Options.do_translate () then try
+      (* Try to infer old case and type annotations *)
+      let _ = Pretyping.understand_gen_tcc sigma env [] None c' in 
+      (* msgerrnl (str "Typage tactique OK");*)
+      ()
+    with e -> (*msgerrnl (str "Warning: can't type tactic");*) () end;
+  (c',if !strict_check then None else Some c)
+
+(* Globalize bindings *)
+let intern_binding ist (loc,b,c) =
+  (loc,intern_quantified_hypothesis ist b,intern_constr ist c)
+
+let intern_bindings ist = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
+
+let intern_constr_with_bindings ist (c,bl) =
+  (intern_constr ist c, intern_bindings ist bl)
+
+let intern_clause_pattern ist (l,occl) =
+  let rec check = function
+    | (hyp,l) :: rest -> (intern_hyp ist (skip_metaid hyp),l)::(check rest)
+    | [] -> []
+  in (l,check occl)
+
+  (* TODO: catch ltac vars *)
+let intern_induction_arg ist = function
+  | ElimOnConstr c -> ElimOnConstr (intern_constr ist c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent (loc,id) as x ->
+      if !strict_check then
+	(* If in a defined tactic, no intros-until *)
+	ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id))))
+      else
+	ElimOnIdent (loc,id)
+
+(* Globalizes a reduction expression *)
+let intern_evaluable ist = function
+  | Ident (loc,id) as r when find_ltacvar id ist -> ArgVar (loc,id)
+  | Ident (_,id) when
+      (not !strict_check & find_hyp id ist) or find_ctxvar id ist ->
+      ArgArg (EvalVarRef id, None)
+  | r ->
+      let loc,qid = qualid_of_reference r in
+      try
+	let e = match locate_reference qid with
+	  | ConstRef c -> EvalConstRef c
+	  | VarRef c -> EvalVarRef c
+	  | _ -> error_not_evaluable (pr_reference r) in
+        let short_name = match r with
+	  | Ident (loc,id) when not !strict_check -> Some (loc,id)
+	  | _ -> None in
+        ArgArg (e,short_name)
+      with
+	| NotSyntacticRef -> error_not_evaluable (pr_reference r)
+	| Not_found ->
+	match r with 
+	  | Ident (loc,id) when not !strict_check ->
+	      ArgArg (EvalVarRef id, Some (loc,id))
+	  | _ -> error_global_not_found_loc loc qid
+
+let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
+
+let intern_flag ist red =
+  { red with rConst = List.map (intern_evaluable ist) red.rConst }
+
+let intern_constr_occurrence ist (l,c) = (l,intern_constr ist c)
+
+let intern_redexp ist = function
+  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
+  | Fold l -> Fold (List.map (intern_constr ist) l)
+  | Cbv f -> Cbv (intern_flag ist f)
+  | Lazy f -> Lazy (intern_flag ist f)
+  | Pattern l -> Pattern (List.map (intern_constr_occurrence ist) l)
+  | Simpl o -> Simpl (option_app (intern_constr_occurrence ist) o)
+  | (Red _ | Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s, intern_constr ist c)
+
+let intern_inversion_strength lf ist = function
+  | NonDepInversion (k,idl,ids) ->
+      NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl,
+      option_app (intern_intro_pattern lf ist) ids)
+  | DepInversion (k,copt,ids) ->
+      DepInversion (k, option_app (intern_constr ist) copt,
+      option_app (intern_intro_pattern lf ist) ids)
+  | InversionUsing (c,idl) ->
+      InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl)
+
+(* Interprets an hypothesis name *)
+let intern_hyp_location ist (id,occs,hl) =
+  (intern_hyp ist (skip_metaid id), occs, hl)
+
+(* Reads a pattern *)
+let intern_pattern evc env lfun = function
+  | Subterm (ido,pc) ->
+      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      ido, metas, Subterm (ido,pat)
+  | Term pc ->
+      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      None, metas, Term pat
+
+let intern_constr_may_eval ist = function
+  | ConstrEval (r,c) -> ConstrEval (intern_redexp ist r,intern_constr ist c)
+  | ConstrContext (locid,c) ->
+      ConstrContext (intern_hyp ist locid,intern_constr ist c)
+  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
+  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
+
+(* Reads the hypotheses of a Match Context rule *)
+let rec intern_match_context_hyps evc env lfun = function
+  | (Hyp ((_,na) as locna,mp))::tl ->
+      let ido, metas1, pat = intern_pattern evc env lfun mp in
+      let lfun, metas2, hyps = intern_match_context_hyps evc env lfun tl in
+      let lfun' = name_cons na (option_cons ido lfun) in
+      lfun', metas1@metas2, Hyp (locna,pat)::hyps
+  | [] -> lfun, [], []
+
+(* Utilities *)
+let rec filter_some = function
+  | None :: l -> filter_some l
+  | Some a :: l -> a :: filter_some l
+  | [] -> []
+
+let extract_names lrc =
+  List.fold_right 
+    (fun ((loc,name),_) l ->
+      if List.mem name l then
+	user_err_loc
+	  (loc, "intern_tactic", str "This variable is bound several times");
+      name::l)
+    lrc []
+
+let extract_let_names lrc =
+  List.fold_right 
+    (fun ((loc,name),_,_) l ->
+      if List.mem name l then
+	user_err_loc
+	  (loc, "glob_tactic", str "This variable is bound several times");
+      name::l)
+    lrc []
+
+
+let clause_app f = function
+    { onhyps=None; onconcl=b;concl_occs=nl } ->
+      { onhyps=None; onconcl=b; concl_occs=nl }
+  | { onhyps=Some l; onconcl=b;concl_occs=nl } ->
+      { onhyps=Some(List.map f l); onconcl=b;concl_occs=nl}
+
+(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
+let rec intern_atomic lf ist x =
+  match (x:raw_atomic_tactic_expr) with 
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
+  | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
+  | TacIntroMove (ido,ido') ->
+      TacIntroMove (option_app (intern_ident lf ist) ido,
+          option_app (intern_hyp ist) ido')
+  | TacAssumption -> TacAssumption
+  | TacExact c -> TacExact (intern_constr ist c)
+  | TacApply cb -> TacApply (intern_constr_with_bindings ist cb)
+  | TacElim (cb,cbo) ->
+      TacElim (intern_constr_with_bindings ist cb,
+               option_app (intern_constr_with_bindings ist) cbo)
+  | TacElimType c -> TacElimType (intern_constr ist c)
+  | TacCase cb -> TacCase (intern_constr_with_bindings ist cb)
+  | TacCaseType c -> TacCaseType (intern_constr ist c)
+  | TacFix (idopt,n) -> TacFix (option_app (intern_ident lf ist) idopt,n)
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_constr ist c) in
+      TacMutualFix (intern_ident lf ist id, n, List.map f l)
+  | TacCofix idopt -> TacCofix (option_app (intern_ident lf ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (intern_ident lf ist id,intern_constr ist c) in
+      TacMutualCofix (intern_ident lf ist id, List.map f l)
+  | TacCut c -> TacCut (intern_constr ist c)
+  | TacTrueCut (na,c) ->
+      TacTrueCut (intern_name lf ist na, intern_constr ist c)
+  | TacForward (b,na,c) ->
+      TacForward (b,intern_name lf ist na,intern_constr ist c)
+  | TacGeneralize cl -> TacGeneralize (List.map (intern_constr ist) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
+  | TacLetTac (na,c,cls) ->
+      let na = intern_name lf ist na in
+      TacLetTac (na,intern_constr ist c,
+                 (clause_app (intern_hyp_location ist) cls))
+  | TacInstantiate (n,c,cls) -> 
+      TacInstantiate (n,intern_constr ist c,
+		      (clause_app (intern_hyp_location ist) cls))
+
+  (* Automation tactics *)
+  | TacTrivial l -> TacTrivial l
+  | TacAuto (n,l) -> TacAuto (n,l)
+  | TacAutoTDB n -> TacAutoTDB n
+  | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id)
+  | TacDestructConcl -> TacDestructConcl
+  | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
+  | TacDAuto (n,p) -> TacDAuto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction (h,ids) ->
+      TacSimpleInduction (intern_quantified_hypothesis ist h,ids)
+  | TacNewInduction (c,cbo,(ids,ids')) ->
+      TacNewInduction (intern_induction_arg ist c,
+               option_app (intern_constr_with_bindings ist) cbo,
+               (option_app (intern_intro_pattern lf ist) ids,ids'))
+  | TacSimpleDestruct h ->
+      TacSimpleDestruct (intern_quantified_hypothesis ist h)
+  | TacNewDestruct (c,cbo,(ids,ids')) ->
+      TacNewDestruct (intern_induction_arg ist c,
+               option_app (intern_constr_with_bindings ist) cbo,
+	       (option_app (intern_intro_pattern lf ist) ids,ids'))
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = intern_quantified_hypothesis ist h1 in
+      let h2 = intern_quantified_hypothesis ist h2 in
+      TacDoubleInduction (h1,h2)
+  | TacDecomposeAnd c -> TacDecomposeAnd (intern_constr ist c)
+  | TacDecomposeOr c -> TacDecomposeOr (intern_constr ist c)
+  | TacDecompose (l,c) -> let l = List.map (intern_inductive ist) l in
+      TacDecompose (l,intern_constr ist c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,intern_constr_with_bindings ist l)
+  | TacLApply c -> TacLApply (intern_constr ist c)
+
+  (* Context management *)
+  | TacClear l -> TacClear (List.map (intern_hyp_or_metaid ist) l)
+  | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
+  | TacMove (dep,id1,id2) ->
+    TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2)
+  | TacRename (id1,id2) -> TacRename (intern_hyp_or_metaid ist id1, intern_hyp_or_metaid ist id2)
+
+  (* Constructors *)
+  | TacLeft bl -> TacLeft (intern_bindings ist bl)
+  | TacRight bl -> TacRight (intern_bindings ist bl)
+  | TacSplit (b,bl) -> TacSplit (b,intern_bindings ist bl)
+  | TacAnyConstructor t -> TacAnyConstructor (option_app (intern_tactic ist) t)
+  | TacConstructor (n,bl) -> TacConstructor (n, intern_bindings ist bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      TacReduce (intern_redexp ist r, clause_app (intern_hyp_location ist) cl)
+  | TacChange (occl,c,cl) ->
+      TacChange (option_app (intern_constr_occurrence ist) occl,
+        intern_constr ist c, clause_app (intern_hyp_location ist) cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity -> TacReflexivity
+  | TacSymmetry idopt -> 
+      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
+  | TacTransitivity c -> TacTransitivity (intern_constr ist c)
+
+  (* Equality and inversion *)
+  | TacInversion (inv,hyp) ->
+      TacInversion (intern_inversion_strength lf ist inv,
+        intern_quantified_hypothesis ist hyp)
+
+  (* For extensions *)
+  | TacExtend (loc,opn,l) ->
+      let _ = lookup_tactic opn in
+      TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l)
+  | TacAlias (loc,s,l,(dir,body)) ->
+      let (l1,l2) = ist.ltacvars in
+      let ist' = { ist with ltacvars = ((List.map fst l)@l1,l2) } in
+      let l = List.map (fun (id,a) -> (strip_meta id,intern_genarg ist a)) l in
+      try TacAlias (loc,s,l,(dir,intern_tactic ist' body))
+      with e -> raise (locate_error_in_file (string_of_dirpath dir) e)
+
+and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr)
+
+and intern_tactic_seq ist = function
+  (* Traducteur v7->v8 *)
+  | TacAtom (_,TacReduce (Unfold [_,Ident (_,id)],_))
+      when string_of_id id = "INZ" & !Options.translate_syntax
+        -> ist.ltacvars, (TacId "")
+  (* Fin traducteur v7->v8 *)
+
+  | TacAtom (loc,t) ->
+      let lf = ref ist.ltacvars in
+      let t = intern_atomic lf ist t in
+      !lf, TacAtom (adjust_loc loc, t)
+  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
+  | TacLetRecIn (lrc,u) ->
+      let names = extract_names lrc in
+      let (l1,l2) = ist.ltacvars in
+      let ist = { ist with ltacvars = (names@l1,l2) } in
+      let lrc = List.map (fun (n,b) -> (n,intern_tactic_fun ist b)) lrc in
+      ist.ltacvars, TacLetRecIn (lrc,intern_tactic ist u)
+  | TacLetIn (l,u) ->
+      let l = List.map
+        (fun (n,c,b) ->
+          (n,option_app (intern_tactic ist) c, intern_tacarg !strict_check ist b)) l in
+      let (l1,l2) = ist.ltacvars in
+      let ist' = { ist with ltacvars = ((extract_let_names l)@l1,l2) } in
+      ist.ltacvars, TacLetIn (l,intern_tactic ist' u)
+  | TacMatchContext (lr,lmr) ->
+      ist.ltacvars, TacMatchContext(lr, intern_match_rule ist lmr)
+  | TacMatch (c,lmr) ->
+      ist.ltacvars, TacMatch (intern_tactic ist c,intern_match_rule ist lmr)
+  | TacId _ as x -> ist.ltacvars, x
+  | TacFail (n,x) -> ist.ltacvars, TacFail (intern_int_or_var ist n,x)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
+  | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
+  | TacThen (t1,t2) ->
+      let lfun', t1 = intern_tactic_seq ist t1 in
+      let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in
+      lfun'', TacThen (t1,t2)
+  | TacThens (t,tl) ->
+      let lfun', t = intern_tactic_seq ist t in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun',
+      TacThens (t, List.map (intern_tactic { ist with ltacvars = lfun' }) tl)
+  | TacDo (n,tac) -> 
+      ist.ltacvars, TacDo (intern_int_or_var ist n,intern_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_tactic ist tac)
+  | TacOrelse (tac1,tac2) ->
+      ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l)
+  | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
+
+and intern_tactic_fun ist (var,body) = 
+  let (l1,l2) = ist.ltacvars in
+  let lfun' = List.rev_append (filter_some var) l1 in
+  (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
+
+and intern_tacarg strict ist = function
+  | TacVoid -> TacVoid
+  | Reference r -> intern_reference strict ist r
+  | IntroPattern ipat -> 
+      let lf = ref([],[]) in (*How to know what names the intropattern binds?*)
+      IntroPattern (intern_intro_pattern lf ist ipat)
+  | Integer n -> Integer n
+  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
+  | MetaIdArg (loc,s) ->
+      (* $id can occur in Grammar tactic... *)
+      let id = id_of_string s in
+      if find_ltacvar id ist or Options.do_translate()
+      then Reference (ArgVar (adjust_loc loc,strip_meta id))
+      else error_syntactic_metavariables_not_allowed loc
+  | TacCall (loc,f,l) ->
+      TacCall (loc,
+        intern_tactic_reference ist f,
+        List.map (intern_tacarg !strict_check ist) l)
+  | TacFreshId _ as x -> x
+  | Tacexp t -> Tacexp (intern_tactic ist t)
+  | TacDynamic(loc,t) as x ->
+      (match tag t with
+	| "tactic" | "value" | "constr" -> x
+	| s -> anomaly_loc (loc, "",
+                 str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and intern_match_rule ist = function
+  | (All tc)::tl ->
+      All (intern_tactic ist tc) :: (intern_match_rule ist tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
+      let lfun',metas1,hyps = intern_match_context_hyps sigma env lfun rl in
+      let ido,metas2,pat = intern_pattern sigma env lfun mp in
+      let metas = list_uniquize (metas1@metas2) in
+      let ist' = { ist with ltacvars = (metas@(option_cons ido lfun'),l2) } in
+      Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
+  | [] -> []
+
+and intern_genarg ist x =
+  match genarg_tag x with
+  | BoolArgType -> in_gen globwit_bool (out_gen rawwit_bool x)
+  | IntArgType -> in_gen globwit_int (out_gen rawwit_int x)
+  | IntOrVarArgType ->
+      in_gen globwit_int_or_var
+        (intern_int_or_var ist (out_gen rawwit_int_or_var x))
+  | StringArgType ->
+      in_gen globwit_string (out_gen rawwit_string x)
+  | PreIdentArgType ->
+      in_gen globwit_pre_ident (out_gen rawwit_pre_ident x)
+  | IntroPatternArgType ->
+      let lf = ref ([],[]) in
+      (* how to know which names are bound by the intropattern *)
+      in_gen globwit_intro_pattern
+        (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
+  | IdentArgType ->
+      let lf = ref ([],[]) in
+      in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x))
+  | HypArgType ->
+      in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x))
+  | RefArgType ->
+      in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x))
+  | SortArgType ->
+      in_gen globwit_sort (out_gen rawwit_sort x)
+  | ConstrArgType ->
+      in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen globwit_constr_may_eval 
+        (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen globwit_quant_hyp
+        (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen globwit_red_expr (intern_redexp ist (out_gen rawwit_red_expr x))
+  | TacticArgType ->
+      in_gen globwit_tactic (intern_tactic ist (out_gen rawwit_tactic x))
+  | CastedOpenConstrArgType ->
+      in_gen globwit_casted_open_constr 
+        (intern_constr ist (out_gen rawwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen globwit_constr_with_bindings
+        (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen globwit_bindings
+        (intern_bindings ist (out_gen rawwit_bindings x))
+  | List0ArgType _ -> app_list0 (intern_genarg ist) x
+  | List1ArgType _ -> app_list1 (intern_genarg ist) x
+  | OptArgType _ -> app_opt (intern_genarg ist) x
+  | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x
+  | ExtraArgType s -> lookup_genarg_glob s ist x
+
+(************* End globalization ************)
+
+(***************************************************************************)
+(* Evaluation/interpretation *)
+
+(* Associates variables with values and gives the remaining variables and
+   values *)
+let head_with_value (lvar,lval) =
+  let rec head_with_value_rec lacc = function
+    | ([],[]) -> (lacc,[],[])
+    | (vr::tvr,ve::tve) ->
+      (match vr with
+      |	None -> head_with_value_rec lacc (tvr,tve)
+      | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
+    | (vr,[]) -> (lacc,vr,[])
+    | ([],ve) -> (lacc,[],ve)
+  in
+    head_with_value_rec [] (lvar,lval)
+
+(* Gives a context couple if there is a context identifier *)
+let give_context ctxt = function
+  | None -> []
+  | Some id -> [id,VConstr_context ctxt]
+
+(* Reads a pattern by substituing vars of lfun *)
+let eval_pattern lfun c = 
+  let lvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lfun in
+  instantiate_pattern lvar c
+
+let read_pattern evc env lfun = function
+  | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc)
+  | Term pc -> Term (eval_pattern lfun pc)
+
+(* Reads the hypotheses of a Match Context rule *)
+let cons_and_check_name id l =
+  if List.mem id l then
+    user_err_loc (loc,"read_match_context_hyps",
+      str ("Hypothesis pattern-matching variable "^(string_of_id id)^
+      " used twice in the same pattern"))
+  else id::l
+
+let rec read_match_context_hyps evc env lfun lidh = function
+  | (Hyp ((loc,na) as locna,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Hyp (locna,read_pattern evc env lfun mp)::
+	(read_match_context_hyps evc env lfun lidh' tl)
+  | [] -> []
+
+(* Reads the rules of a Match Context or a Match *)
+let rec read_match_rule evc env lfun = function
+  | (All tc)::tl -> (All tc)::(read_match_rule evc env lfun tl)
+  | (Pat (rl,mp,tc))::tl ->
+      Pat (read_match_context_hyps evc env lfun [] rl,
+      read_pattern evc env lfun mp,tc)
+       ::(read_match_rule evc env lfun tl)
+  | [] -> []
+
+(* For Match Context and Match *)
+exception No_match
+exception Not_coherent_metas
+exception Eval_fail of string
+
+let is_failure = function
+  | FailError _ | Stdpp.Exc_located (_,FailError _) -> true
+  | _ -> false
+
+let is_match_catchable = function
+  | No_match | Eval_fail _ -> true
+  | e -> is_failure e or Logic.catchable_exception e
+
+(* Verifies if the matched list is coherent with respect to lcm *)
+let rec verify_metas_coherence gl lcm = function
+  | (num,csr)::tl ->
+    if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then
+      (num,csr)::(verify_metas_coherence gl lcm tl)
+    else
+      raise Not_coherent_metas
+  | [] -> []
+
+(* Tries to match a pattern and a constr *)
+let apply_matching pat csr =
+  try
+    (matches pat csr)
+  with
+     PatternMatchingFailure -> raise No_match
+
+(* Tries to match one hypothesis pattern with a list of hypotheses *)
+let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) =
+  let get_id_couple id = function
+(*    | Name idpat -> [idpat,VIdentifier id]*)
+    | Name idpat -> [idpat,VConstr (mkVar id)]
+    | Anonymous -> [] in
+  let rec apply_one_mhyp_context_rec nocc = function
+    | (id,hyp)::tl as hyps ->
+      (match pat with
+      | Term t ->
+        (try
+          let lmeta = verify_metas_coherence gl lmatch (matches t hyp) in
+          (get_id_couple id hypname,lmeta,(id,hyp),(tl,0))
+        with
+	| PatternMatchingFailure | Not_coherent_metas ->
+            apply_one_mhyp_context_rec 0 tl)
+      | Subterm (ic,t) ->
+        (try
+          let (lm,ctxt) = sub_match nocc t hyp in
+          let lmeta = verify_metas_coherence gl lmatch lm in
+          ((get_id_couple id hypname)@(give_context ctxt ic),
+	   lmeta,(id,hyp),(hyps,nocc + 1))
+         with
+         | NextOccurrence _ ->
+             apply_one_mhyp_context_rec 0 tl
+         | Not_coherent_metas ->
+             apply_one_mhyp_context_rec (nocc + 1) hyps))
+    | [] ->
+        db_hyp_pattern_failure ist.debug env (hypname,pat);
+        raise No_match
+      in
+  apply_one_mhyp_context_rec nocc lhyps
+
+let constr_to_id loc = function
+  | VConstr c when isVar c -> destVar c
+  | _ -> invalid_arg_loc (loc, "Not an identifier")
+
+let constr_to_qid loc c =
+  try shortest_qualid_of_global Idset.empty (reference_of_constr c)
+  with _ -> invalid_arg_loc (loc, "Not a global reference")
+
+(* Debug reference *)
+let debug = ref DebugOff
+
+(* Sets the debugger mode *)
+let set_debug pos = debug := pos
+
+(* Gives the state of debug *)
+let get_debug () = !debug
+
+(* Interprets an identifier which must be fresh *)
+let interp_ident ist id =
+  try match List.assoc id ist.lfun with
+  | VIntroPattern (IntroIdentifier id) -> id
+  | VConstr c as v when isVar c ->
+      (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
+      (* c is then expected not to belong to the proof context *)
+      (* would be checkable if env were known from interp_ident *)
+      destVar c
+  | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ 
+         str ") should have been bound to an identifier")
+  with Not_found -> id
+
+let interp_intro_pattern_var ist id =
+  try match List.assoc id ist.lfun with
+  | VIntroPattern ipat -> ipat
+  | VConstr c as v when isVar c ->
+      (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
+      (* c is then expected not to belong to the proof context *)
+      (* would be checkable if env were known from interp_ident *)
+      IntroIdentifier (destVar c)
+  | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ 
+         str ") should have been bound to an introduction pattern")
+  with Not_found -> IntroIdentifier id
+
+let interp_int lfun (loc,id) =
+  try match List.assoc id lfun with
+  | VInteger n -> n
+  | _ -> user_err_loc(loc,"interp_int",str "should be bound to an integer")
+  with Not_found -> user_err_loc (loc,"interp_int",str "Unbound variable")
+
+let interp_int_or_var ist = function
+  | ArgVar locid -> interp_int ist.lfun locid
+  | ArgArg n -> n
+
+let constr_of_value env = function
+  | VConstr csr -> csr
+  | VIntroPattern (IntroIdentifier id) -> constr_of_id env id
+  | _ -> raise Not_found
+
+let is_variable env id =
+  List.mem id (ids_of_named_context (Environ.named_context env))
+
+let variable_of_value env = function
+  | VConstr c as v when isVar c -> destVar c
+  | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
+  | _ -> raise Not_found
+
+(* Extract a variable from a value, if any *)
+let id_of_Identifier = variable_of_value
+
+(* Extract a constr from a value, if any *)
+let constr_of_VConstr = constr_of_value
+
+(* Interprets an variable *)
+let interp_var ist gl (loc,id) =
+  (* Look first in lfun for a value coercible to a variable *)
+  try 
+    let v = List.assoc id ist.lfun in
+    try variable_of_value (pf_env gl) v
+    with Not_found ->
+      errorlabstrm "coerce_to_variable"
+      (str "Cannot coerce" ++ spc () ++ pr_value (pf_env gl) v ++ spc () ++
+      str "to a variable")
+  with Not_found -> 
+  (* Then look if bound in the proof context at calling time *)
+  if is_variable (pf_env gl) id then id
+  else
+    user_err_loc (loc,"eval_variable",pr_id id ++ str " not found")
+
+(* Interprets an existing hypothesis (i.e. a declared variable) *)
+let interp_hyp = interp_var
+
+let interp_name ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (interp_ident ist id)
+
+let interp_clause_pattern ist gl (l,occl) =
+  let rec check acc = function
+    | (hyp,l) :: rest ->
+	let hyp = interp_hyp ist gl hyp in
+	if List.mem hyp acc then
+	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice");
+	(hyp,l)::(check (hyp::acc) rest)
+    | [] -> []
+  in (l,check [] occl)
+
+(* Interprets a qualified name *)
+let interp_reference ist env = function
+  | ArgArg (_,r) -> r
+  | ArgVar (loc,id) -> coerce_to_reference env (unrec (List.assoc id ist.lfun))
+
+let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
+
+let interp_inductive ist = function
+  | ArgArg r -> r
+  | ArgVar (_,id) -> coerce_to_inductive (unrec (List.assoc id ist.lfun))
+
+let interp_evaluable ist env = function
+  | ArgArg (r,Some (loc,id)) ->
+      (* Maybe [id] has been introduced by Intro-like tactics *)
+      (try match Environ.lookup_named id env with
+        | (_,Some _,_) -> EvalVarRef id
+        | _ -> error_not_evaluable (pr_id id)
+      with Not_found ->
+	match r with
+	  | EvalConstRef _ -> r
+	  | _ -> Pretype_errors.error_var_not_found_loc loc id)
+  | ArgArg (r,None) -> r
+  | ArgVar (_,id) -> 
+      coerce_to_evaluable_ref env (unrec (List.assoc id ist.lfun))
+
+(* Interprets an hypothesis name *)
+let interp_hyp_location ist gl (id,occs,hl) = (interp_hyp ist gl id,occs,hl)
+
+let interp_clause ist gl { onhyps=ol; onconcl=b; concl_occs=occs } =
+  { onhyps=option_app(List.map (interp_hyp_location ist gl)) ol;
+    onconcl=b;
+    concl_occs=occs }
+
+(* Interpretation of constructions *)
+
+(* Extract the constr list from lfun *)
+let rec constr_list_aux env = function
+  | (id,v)::tl -> 
+      let (l1,l2) = constr_list_aux env tl in
+      (try ((id,constr_of_value env v)::l1,l2)
+       with Not_found -> 
+	 let ido = match v with
+	   | VIntroPattern (IntroIdentifier id0) -> Some id0
+	   | _ -> None in
+	 (l1,(id,ido)::l2))
+  | [] -> ([],[])
+
+let constr_list ist env = constr_list_aux env ist.lfun
+
+(*Extract the identifier list from lfun: join all branches (what to do else?)*)
+let rec intropattern_ids = function
+  | IntroIdentifier id -> [id]
+  | IntroOrAndPattern ll -> 
+      List.flatten (List.map intropattern_ids (List.flatten ll))
+  | IntroWildcard -> []
+
+let rec extract_ids = function
+  | (id,VIntroPattern ipat)::tl -> intropattern_ids ipat @ extract_ids tl
+  | _::tl -> extract_ids tl
+  | [] -> []
+
+let retype_list sigma env lst =
+  List.fold_right (fun (x,csr) a ->
+    try (x,Retyping.get_judgment_of env sigma csr)::a with
+    | Anomaly _ -> a) lst []
+
+let interp_casted_constr ocl ist sigma env (c,ce) =
+  let (l1,l2) = constr_list ist env in
+  let tl1 = retype_list sigma env l1 in
+  let csr = 
+    match ce with
+    | None ->
+	Pretyping.understand_gen_ltac sigma env (tl1,l2) ocl c
+      (* If at toplevel (ce<>None), the error can be due to an incorrect
+         context at globalization time: we retype with the now known
+         intros/lettac/inversion hypothesis names *)
+    | Some c -> interp_constr_gen sigma env (l1,l2) c ocl
+  in
+  db_constr ist.debug env csr;
+  csr
+
+let interp_constr ist sigma env c =
+  interp_casted_constr None ist sigma env c
+
+(* Interprets an open constr expression casted by the current goal *)
+let pf_interp_casted_openconstr ist gl (c,ce) =
+  let sigma = project gl in
+  let env = pf_env gl in
+  let (ltacvars,l) = constr_list ist env in
+  let typs = retype_list sigma env ltacvars in
+  let ocl = Some (pf_concl gl) in
+  match ce with
+  | None ->
+      Pretyping.understand_gen_tcc sigma env typs ocl c
+    (* If at toplevel (ce<>None), the error can be due to an incorrect
+       context at globalization time: we retype with the now known
+       intros/lettac/inversion hypothesis names *)
+  | Some c -> interp_openconstr_gen sigma env (ltacvars,l) c ocl
+
+(* Interprets a constr expression *)
+let pf_interp_constr ist gl =
+  interp_constr ist (project gl) (pf_env gl)
+
+(* Interprets a constr expression casted by the current goal *)
+let pf_interp_casted_constr ist gl c =
+  interp_casted_constr (Some(pf_concl gl)) ist (project gl) (pf_env gl) c
+
+(* Interprets a reduction expression *)
+let interp_unfold ist env (l,qid) =
+  (l,interp_evaluable ist env qid)
+
+let interp_flag ist env red =
+  { red with rConst = List.map (interp_evaluable ist env) red.rConst }
+
+let interp_pattern ist sigma env (l,c) = (l,interp_constr ist sigma env c)
+
+let pf_interp_pattern ist gl = interp_pattern ist (project gl) (pf_env gl)
+
+let redexp_interp ist sigma env = function
+  | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
+  | Fold l -> Fold (List.map (interp_constr ist sigma env) l)
+  | Cbv f -> Cbv (interp_flag ist env f)
+  | Lazy f -> Lazy (interp_flag ist env f)
+  | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l)
+  | Simpl o -> Simpl (option_app (interp_pattern ist sigma env) o)
+  | (Red _ |  Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s,interp_constr ist sigma env c)
+
+let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl)
+
+let interp_may_eval f ist gl = function
+  | ConstrEval (r,c) ->
+      let redexp = pf_redexp_interp ist gl  r in
+      pf_reduction_of_redexp gl redexp (f ist gl c)
+  | ConstrContext ((loc,s),c) ->
+      (try
+	let ic = f ist gl c
+	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
+	subst_meta [special_meta,ic] ctxt
+      with
+	| Not_found ->
+	    user_err_loc (loc, "interp_may_eval",
+	    str "Unbound context identifier" ++ pr_id s))
+  | ConstrTypeOf c -> pf_type_of gl (f ist gl c)
+  | ConstrTerm c -> f ist gl c
+
+(* Interprets a constr expression possibly to first evaluate *)
+let interp_constr_may_eval ist gl c =
+  let csr = interp_may_eval pf_interp_constr ist gl c in
+  begin
+    db_constr ist.debug (pf_env gl) csr;
+    csr
+  end
+
+let rec interp_intro_pattern ist = function
+  | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist l)
+  | IntroWildcard -> IntroWildcard
+  | IntroIdentifier id -> interp_intro_pattern_var ist id
+
+and interp_case_intro_pattern ist =
+  List.map (List.map (interp_intro_pattern ist))
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let interp_quantified_hypothesis ist = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      try match List.assoc id ist.lfun with
+	| VInteger n -> AnonHyp n
+	| VIntroPattern (IntroIdentifier id) -> NamedHyp id
+	| _ -> raise Not_found
+      with Not_found -> NamedHyp id
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let interp_declared_or_quantified_hypothesis ist gl = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      try match List.assoc id ist.lfun with
+	| VInteger n -> AnonHyp n
+	| v -> NamedHyp (variable_of_value (pf_env gl) v)
+      with Not_found -> NamedHyp id
+
+let interp_induction_arg ist gl = function
+  | ElimOnConstr c -> ElimOnConstr (pf_interp_constr ist gl c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent (loc,id) ->
+      if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id)
+      else ElimOnConstr
+	(pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))))
+
+let interp_binding ist gl (loc,b,c) =
+  (loc,interp_quantified_hypothesis ist b,pf_interp_constr ist gl c)
+
+let interp_bindings ist gl = function
+| NoBindings -> NoBindings
+| ImplicitBindings l -> ImplicitBindings (List.map (pf_interp_constr ist gl) l)
+| ExplicitBindings l -> ExplicitBindings (List.map (interp_binding ist gl) l)
+
+let interp_constr_with_bindings ist gl (c,bl) =
+  (pf_interp_constr ist gl c, interp_bindings ist gl bl)
+
+(* Interprets an l-tac expression into a value *)
+let rec val_interp ist gl (tac:glob_tactic_expr) =
+
+  let value_interp ist = match tac with
+  (* Immediate evaluation *)
+  | TacFun (it,body) -> VFun (ist.lfun,it,body)
+  | TacLetRecIn (lrc,u) -> letrec_interp ist gl lrc u
+  | TacLetIn (l,u) ->
+      let addlfun = interp_letin ist gl l in
+      val_interp { ist with lfun=addlfun@ist.lfun } gl u
+  | TacMatchContext (lr,lmr) -> interp_match_context ist gl lr lmr 
+  | TacMatch (c,lmr) -> interp_match ist gl c lmr
+  | TacArg a -> interp_tacarg ist gl a
+  (* Delayed evaluation *)
+  | t -> VTactic (dummy_loc,eval_tactic ist t)
+
+  in check_for_interrupt (); 
+    match ist.debug with
+    | DebugOn lev ->
+	debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v})
+    | _ -> value_interp ist
+
+and eval_tactic ist = function
+  | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl
+  | TacFun (it,body) -> assert false
+  | TacLetRecIn (lrc,u) -> assert false
+  | TacLetIn (l,u) -> assert false
+  | TacMatchContext _ -> assert false
+  | TacMatch (c,lmr) -> assert false
+  | TacId s -> tclIDTAC_MESSAGE s
+  | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) s
+  | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
+  | TacAbstract (tac,s) -> Tactics.tclABSTRACT s (interp_tactic ist tac)
+  | TacThen (t1,t2) -> tclTHEN (interp_tactic ist t1) (interp_tactic ist t2)
+  | TacThens (t,tl) ->
+      tclTHENS (interp_tactic ist t) (List.map (interp_tactic ist) tl)
+  | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTry tac -> tclTRY (interp_tactic ist tac)
+  | TacInfo tac -> tclINFO (interp_tactic ist tac)
+  | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
+  | TacOrelse (tac1,tac2) ->
+        tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l)
+  | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
+  | TacArg a -> assert false
+
+and interp_ltac_reference isapplied ist gl = function
+  | ArgVar (loc,id) -> unrec (List.assoc id ist.lfun)
+  | ArgArg (loc,r) ->
+      let v = val_interp {lfun=[];debug=ist.debug} gl (lookup r) in
+      if isapplied then v else locate_tactic_call loc v
+
+and interp_tacarg ist gl = function
+  | TacVoid -> VVoid
+  | Reference r -> interp_ltac_reference false ist gl r
+  | Integer n -> VInteger n
+  | IntroPattern ipat -> VIntroPattern ipat
+  | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
+  | MetaIdArg (loc,id) -> assert false
+  | TacCall (loc,f,l) ->
+      let fv = interp_ltac_reference true ist gl f
+      and largs = List.map (interp_tacarg ist gl) l in
+      List.iter check_is_value largs;
+      interp_app ist gl fv largs loc
+  | TacFreshId idopt -> 
+      let s = match idopt with None -> "H" | Some s -> s in
+      let id = Tactics.fresh_id (extract_ids ist.lfun) (id_of_string s) gl in
+      VIntroPattern (IntroIdentifier id)
+  | Tacexp t -> val_interp ist gl t
+  | TacDynamic(_,t) ->
+      let tg = (tag t) in
+      if tg = "tactic" then
+        let f = (tactic_out t) in 
+        val_interp ist gl
+          (intern_tactic {
+            ltacvars = (List.map fst ist.lfun,[]); ltacrecvars = [];
+            gsigma = project gl; genv = pf_env gl }
+            (f ist))
+      else if tg = "value" then
+        value_out t
+      else if tg = "constr" then
+        VConstr (Pretyping.constr_out t)
+      else
+        anomaly_loc (loc, "Tacinterp.val_interp",
+          (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
+
+(* Interprets an application node *)
+and interp_app ist gl fv largs loc =
+  match fv with
+    | VFun(olfun,var,body) ->
+      let (newlfun,lvar,lval)=head_with_value (var,largs) in
+      if lvar=[] then
+	let v = val_interp { ist with lfun=newlfun@olfun } gl body in
+        if lval=[] then locate_tactic_call loc v
+	else interp_app ist gl v lval loc
+      else
+        VFun(newlfun@olfun,lvar,body)
+    | _ ->
+	user_err_loc (loc, "Tacinterp.interp_app",
+          (str"Illegal tactic application"))
+
+(* Gives the tactic corresponding to the tactic value *)
+and tactic_of_value vle g =
+  match vle with
+  | VRTactic res -> res
+  | VTactic (loc,tac) -> catch_error loc tac g
+  | VFun _ -> error "A fully applied tactic is expected"
+  | _ -> raise NotTactic
+
+(* Evaluation with FailError catching *)
+and eval_with_fail ist tac goal =
+  try
+    (match val_interp ist goal tac with
+    | VTactic (loc,tac) -> VRTactic (catch_error loc tac goal)
+    | a -> a)
+  with
+    | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) ->
+	raise (Eval_fail s)
+    | Stdpp.Exc_located (s',FailError (lvl,s)) ->
+	raise (Stdpp.Exc_located (s',FailError (lvl - 1, s)))
+    | FailError (lvl,s) ->
+	raise (FailError (lvl - 1, s))
+
+(* Interprets recursive expressions *)
+and letrec_interp ist gl lrc u =
+  let lref = Array.to_list (Array.make (List.length lrc) (ref VVoid)) in
+  let lenv =
+    List.fold_right2 (fun ((loc,name),_) vref l -> (name,VRec vref)::l)
+      lrc lref [] in
+  let lve = List.map (fun ((loc,name),(var,body)) ->
+                          (name,VFun(lenv@ist.lfun,var,body))) lrc in
+  begin
+    List.iter2 (fun vref (_,ve) -> vref:=ve) lref lve;
+    val_interp { ist with lfun=lve@ist.lfun } gl u
+  end
+
+(* Interprets the clauses of a LetIn *)
+and interp_letin ist gl = function
+  | [] -> []
+  | ((loc,id),None,t)::tl -> 
+      let v = interp_tacarg ist gl t in
+      check_is_value v;
+      (id,v):: (interp_letin ist gl tl)
+  | ((loc,id),Some com,tce)::tl ->
+    let env = pf_env gl in
+    let typ = constr_of_value env (val_interp ist gl com)
+    and v = interp_tacarg ist gl tce in
+    let csr = 
+      try
+	constr_of_value env v
+      with Not_found ->
+      try
+	let t = tactic_of_value v in
+	let ndc = Environ.named_context env in
+	start_proof id IsLocal ndc typ (fun _ _ -> ());
+	by t;
+	let (_,({const_entry_body = pft},_,_)) = cook_proof () in
+	delete_proof (dummy_loc,id);
+        pft
+      with | NotTactic ->
+	delete_proof (dummy_loc,id);
+	errorlabstrm "Tacinterp.interp_letin"
+          (str "Term or fully applied tactic expected in Let")
+    in (id,VConstr (mkCast (csr,typ)))::(interp_letin ist gl tl)
+
+(* Interprets the Match Context expressions *)
+and interp_match_context ist g lr lmr =
+  let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps =
+    try
+      let (lgoal,ctxt) = sub_match nocc c csr in
+      let lctxt = give_context ctxt id in
+      if mhyps = [] then
+	let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in
+        eval_with_fail { ist with lfun=lgoal@lctxt@ist.lfun } mt goal
+      else
+        apply_hyps_context ist env goal mt lgoal mhyps hyps
+    with
+    | e when is_failure e -> raise e
+    | NextOccurrence _ -> raise No_match
+    | e when is_match_catchable e ->
+      apply_goal_sub ist env goal (nocc + 1) (id,c) csr mt mhyps hyps in
+  let rec apply_match_context ist env goal nrs lex lpt = 
+    begin
+    if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
+    match lpt with
+    | (All t)::tl ->
+      begin
+        db_mc_pattern_success ist.debug;
+        try eval_with_fail ist t goal
+         with e when is_match_catchable e ->
+           apply_match_context ist env goal (nrs+1) (List.tl lex) tl
+      end
+    | (Pat (mhyps,mgoal,mt))::tl ->
+      let hyps = make_hyps (pf_hyps goal) in
+      let hyps = if lr then List.rev hyps else hyps in
+      let mhyps = List.rev mhyps (* Sens naturel *) in
+      let concl = pf_concl goal in
+      (match mgoal with
+      |	Term mg ->
+        (try
+           (let lgoal = apply_matching mg concl in
+            begin
+            db_matched_concl ist.debug (pf_env goal) concl;
+            if mhyps = [] then
+            begin
+              db_mc_pattern_success ist.debug;
+	      let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in
+              eval_with_fail {ist with lfun=lgoal@ist.lfun} mt goal
+            end
+            else
+              apply_hyps_context ist env goal mt lgoal mhyps hyps
+            end)
+        with 
+        | e when is_match_catchable e ->
+          begin 
+            (match e with
+            | No_match -> db_matching_failure ist.debug
+            | Eval_fail s -> db_eval_failure ist.debug s
+            | _ -> db_logic_failure ist.debug e);
+            apply_match_context ist env goal (nrs+1) (List.tl lex) tl
+          end)
+      |	Subterm (id,mg) ->
+        (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps
+         with e when is_match_catchable e ->
+           apply_match_context ist env goal (nrs+1) (List.tl lex) tl))
+    | _ ->
+      errorlabstrm "Tacinterp.apply_match_context" (str
+        "No matching clauses for match goal")
+        (v 0 (str "No matching clauses for match goal" ++
+        (if ist.debug=DebugOff then
+           fnl() ++ str "(use \"Debug On\" for more info)"
+         else mt())))
+    end in
+  let env = pf_env g in
+  apply_match_context ist env g 0 lmr
+    (read_match_rule (project g) env (fst (constr_list ist env)) lmr)
+
+(* Tries to match the hypotheses in a Match Context *)
+and apply_hyps_context ist env goal mt lgmatch mhyps hyps =
+  let rec apply_hyps_context_rec lfun lmatch lhyps_rest current = function
+    | Hyp ((_,hypname),mhyp)::tl as mhyps ->
+        let (lids,lm,hyp_match,next) =
+          apply_one_mhyp_context ist env goal lmatch (hypname,mhyp) current in
+        db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
+        begin 
+	  try
+            let nextlhyps = list_except hyp_match lhyps_rest in
+            apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps
+	      (nextlhyps,0) tl
+          with
+          | e when is_failure e -> raise e
+	  | e when is_match_catchable e -> 
+	      apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps
+        end
+    | [] ->
+	let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in
+        db_mc_pattern_success ist.debug;
+        eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} mt goal
+  in
+  apply_hyps_context_rec [] lgmatch hyps (hyps,0) mhyps
+
+  (* Interprets extended tactic generic arguments *)
+and interp_genarg ist goal x =
+  match genarg_tag x with
+  | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
+  | IntArgType -> in_gen wit_int (out_gen globwit_int x)
+  | IntOrVarArgType ->
+      in_gen wit_int_or_var
+        (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
+  | StringArgType ->
+      in_gen wit_string (out_gen globwit_string x)
+  | PreIdentArgType ->
+      in_gen wit_pre_ident (out_gen globwit_pre_ident x)
+  | IntroPatternArgType ->
+      in_gen wit_intro_pattern
+        (interp_intro_pattern ist (out_gen globwit_intro_pattern x))
+  | IdentArgType ->
+      in_gen wit_ident (interp_ident ist (out_gen globwit_ident x))
+  | HypArgType ->
+      in_gen wit_var (mkVar (interp_hyp ist goal (out_gen globwit_var x)))
+  | RefArgType ->
+      in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x))
+  | SortArgType ->
+      in_gen wit_sort
+        (destSort 
+	  (pf_interp_constr ist goal 
+	    (RSort (dummy_loc,out_gen globwit_sort x), None)))
+  | ConstrArgType ->
+      in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen wit_constr_may_eval (interp_constr_may_eval ist goal (out_gen globwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen wit_quant_hyp
+        (interp_declared_or_quantified_hypothesis ist goal
+          (out_gen globwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen wit_red_expr (pf_redexp_interp ist goal (out_gen globwit_red_expr x))
+  | TacticArgType -> in_gen wit_tactic (out_gen globwit_tactic x)
+  | CastedOpenConstrArgType ->
+      in_gen wit_casted_open_constr 
+        (pf_interp_casted_openconstr ist goal (out_gen globwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen wit_constr_with_bindings
+        (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen wit_bindings
+        (interp_bindings ist goal (out_gen globwit_bindings x))
+  | List0ArgType _ -> app_list0 (interp_genarg ist goal) x
+  | List1ArgType _ -> app_list1 (interp_genarg ist goal) x
+  | OptArgType _ -> app_opt (interp_genarg ist goal) x
+  | PairArgType _ -> app_pair (interp_genarg ist goal) (interp_genarg ist goal) x
+  | ExtraArgType s -> lookup_interp_genarg s ist goal x
+
+(* Interprets the Match expressions *)
+and interp_match ist g constr lmr =
+  let rec apply_sub_match ist nocc (id,c) csr mt =
+    try 
+      let (lm,ctxt) = sub_match nocc c csr in
+      let lctxt = give_context ctxt id in
+      let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+      val_interp {ist with lfun=lm@lctxt@ist.lfun} g mt
+    with | NextOccurrence _ -> raise No_match
+  in
+  let rec apply_match ist csr = function
+    | (All t)::_ ->
+        (try val_interp ist g t
+         with e when is_match_catchable e -> apply_match ist csr [])
+    | (Pat ([],Term c,mt))::tl ->
+        (try
+	  let lm = apply_matching c csr in
+	  let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+          val_interp
+            { ist with lfun=lm@ist.lfun } g mt
+         with e when is_match_catchable e -> apply_match ist csr tl)
+    | (Pat ([],Subterm (id,c),mt))::tl ->
+        (try
+          apply_sub_match ist 0 (id,c) csr mt
+         with | No_match ->
+	   apply_match ist csr tl)
+    | _ ->
+      errorlabstrm "Tacinterp.apply_match" (str
+        "No matching clauses for match") in
+  let env = pf_env g in
+  let csr =
+    try constr_of_value env (val_interp ist g constr)
+    with Not_found ->
+      errorlabstrm "Tacinterp.apply_match" 
+        (str "Argument of match does not evaluate to a term") in
+  let ilr = read_match_rule (project g) env (fst (constr_list ist env)) lmr in
+  apply_match ist csr ilr
+
+(* Interprets tactic expressions : returns a "tactic" *)
+and interp_tactic ist tac gl =
+  try tactic_of_value (val_interp ist gl tac) gl
+  with | NotTactic ->
+    errorlabstrm "Tacinterp.interp_tactic" (str
+      "Must be a command or must give a tactic value")
+
+(* Interprets a primitive tactic *)
+and interp_atomic ist gl = function
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      h_intro_patterns (List.map (interp_intro_pattern ist) l)
+  | TacIntrosUntil hyp ->
+      h_intros_until (interp_quantified_hypothesis ist hyp)
+  | TacIntroMove (ido,ido') ->
+      h_intro_move (option_app (interp_ident ist) ido)
+      (option_app (interp_hyp ist gl) ido')
+  | TacAssumption -> h_assumption
+  | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
+  | TacApply cb -> h_apply (interp_constr_with_bindings ist gl cb)
+  | TacElim (cb,cbo) ->
+      h_elim (interp_constr_with_bindings ist gl cb)
+                (option_app (interp_constr_with_bindings ist gl) cbo)
+  | TacElimType c -> h_elim_type (pf_interp_constr ist gl c)
+  | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb)
+  | TacCaseType c -> h_case_type (pf_interp_constr ist gl c)
+  | TacFix (idopt,n) -> h_fix (option_app (interp_ident ist) idopt) n
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (interp_ident ist id,n,pf_interp_constr ist gl c) in
+      h_mutual_fix (interp_ident ist id) n (List.map f l)
+  | TacCofix idopt -> h_cofix (option_app (interp_ident ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (interp_ident ist id,pf_interp_constr ist gl c) in
+      h_mutual_cofix (interp_ident ist id) (List.map f l)
+  | TacCut c -> h_cut (pf_interp_constr ist gl c)
+  | TacTrueCut (na,c) ->
+      h_true_cut (interp_name ist na) (pf_interp_constr ist gl c)
+  | TacForward (b,na,c) ->
+      h_forward b (interp_name ist na) (pf_interp_constr ist gl c)
+  | TacGeneralize cl -> h_generalize (List.map (pf_interp_constr ist gl) cl)
+  | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
+  | TacLetTac (na,c,clp) ->
+      let clp = interp_clause ist gl clp in
+      h_let_tac (interp_name ist na) (pf_interp_constr ist gl c) clp
+  | TacInstantiate (n,c,ido) -> h_instantiate n (pf_interp_constr ist gl c)
+      (clause_app (interp_hyp_location ist gl) ido)
+
+  (* Automation tactics *)
+  | TacTrivial l -> Auto.h_trivial l
+  | TacAuto (n, l) -> Auto.h_auto n l
+  | TacAutoTDB n -> Dhyp.h_auto_tdb n
+  | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
+  | TacDestructConcl -> Dhyp.h_destructConcl
+  | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
+  | TacDAuto (n,p) -> Auto.h_dauto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction (h,ids) ->
+      let h =
+        if !Options.v7 then interp_declared_or_quantified_hypothesis ist gl h
+        else interp_quantified_hypothesis ist h in
+      h_simple_induction (h,ids)
+  | TacNewInduction (c,cbo,(ids,ids')) ->
+      h_new_induction (interp_induction_arg ist gl c)
+        (option_app (interp_constr_with_bindings ist gl) cbo)
+        (option_app (interp_intro_pattern ist) ids,ids')
+  | TacSimpleDestruct h ->
+      h_simple_destruct (interp_quantified_hypothesis ist h)
+  | TacNewDestruct (c,cbo,(ids,ids')) -> 
+      h_new_destruct (interp_induction_arg ist gl c)
+        (option_app (interp_constr_with_bindings ist gl) cbo)
+        (option_app (interp_intro_pattern ist) ids,ids')
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = interp_quantified_hypothesis ist h1 in
+      let h2 = interp_quantified_hypothesis ist h2 in
+      Elim.h_double_induction h1 h2
+  | TacDecomposeAnd c -> Elim.h_decompose_and (pf_interp_constr ist gl c)
+  | TacDecomposeOr c -> Elim.h_decompose_or (pf_interp_constr ist gl c)
+  | TacDecompose (l,c) ->
+      let l = List.map (interp_inductive ist) l in
+      Elim.h_decompose l (pf_interp_constr ist gl c)
+  | TacSpecialize (n,l) ->
+      h_specialize n (interp_constr_with_bindings ist gl l)
+  | TacLApply c -> h_lapply (pf_interp_constr ist gl c)
+
+  (* Context management *)
+  | TacClear l -> h_clear (List.map (interp_hyp ist gl) l)
+  | TacClearBody l -> h_clear_body (List.map (interp_hyp ist gl) l)
+  | TacMove (dep,id1,id2) ->
+      h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2)
+  | TacRename (id1,id2) ->
+      h_rename (interp_hyp ist gl id1) (interp_ident ist (snd id2))
+
+  (* Constructors *)
+  | TacLeft bl -> h_left (interp_bindings ist gl bl)
+  | TacRight bl -> h_right (interp_bindings ist gl bl)
+  | TacSplit (_,bl) -> h_split (interp_bindings ist gl bl)
+  | TacAnyConstructor t ->
+      abstract_tactic (TacAnyConstructor t)
+        (Tactics.any_constructor (option_app (interp_tactic ist) t))
+  | TacConstructor (n,bl) ->
+      h_constructor (skip_metaid n) (interp_bindings ist gl bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      h_reduce (pf_redexp_interp ist gl r) (interp_clause ist gl cl)
+  | TacChange (occl,c,cl) ->
+      h_change (option_app (pf_interp_pattern ist gl) occl)
+        (pf_interp_constr ist gl c) (interp_clause ist gl cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity -> h_reflexivity
+  | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
+  | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c)
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,ids),hyp) ->
+      Inv.dinv k (option_app (pf_interp_constr ist gl) c)
+        (option_app (interp_intro_pattern ist) ids)
+        (interp_declared_or_quantified_hypothesis ist gl hyp)
+  | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
+      Inv.inv_clause k 
+        (option_app (interp_intro_pattern ist) ids)
+        (List.map (interp_hyp ist gl) idl)
+        (interp_declared_or_quantified_hypothesis ist gl hyp)
+  | TacInversion (InversionUsing (c,idl),hyp) ->
+      Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
+        (pf_interp_constr ist gl c)
+        (List.map (interp_hyp ist gl) idl)
+
+  (* For extensions *)
+  | TacExtend (loc,opn,l) ->
+      fun gl -> vernac_tactic (opn,List.map (interp_genarg ist gl) l) gl
+  | TacAlias (loc,_,l,(_,body)) -> fun gl ->
+    let rec f x = match genarg_tag x with
+    | IntArgType -> VInteger (out_gen globwit_int x)
+    | IntOrVarArgType -> 
+	VInteger (interp_int_or_var ist (out_gen globwit_int_or_var x))
+    | PreIdentArgType ->
+	failwith "pre-identifiers cannot be bound"
+    | IntroPatternArgType ->
+	VIntroPattern (out_gen globwit_intro_pattern x)
+    | IdentArgType -> 
+        VIntroPattern (IntroIdentifier (out_gen globwit_ident x))
+    | HypArgType ->
+	VConstr (mkVar (interp_var ist gl (out_gen globwit_var x)))
+    | RefArgType -> 
+        VConstr (constr_of_reference 
+          (pf_interp_reference ist gl (out_gen globwit_ref x)))
+    | SortArgType ->
+	VConstr (mkSort (Pretyping.interp_sort (out_gen globwit_sort x)))
+    | ConstrArgType ->
+        VConstr (pf_interp_constr ist gl (out_gen globwit_constr x))
+    | ConstrMayEvalArgType ->
+	VConstr
+          (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
+    | TacticArgType -> 
+	val_interp ist gl (out_gen globwit_tactic x)
+    | StringArgType | BoolArgType
+    | QuantHypArgType | RedExprArgType 
+    | CastedOpenConstrArgType | ConstrWithBindingsArgType | BindingsArgType 
+    | ExtraArgType _ | List0ArgType _ | List1ArgType _ | OptArgType _ | PairArgType _ 
+	-> error "This generic type is not supported in alias"
+    in
+    let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
+    let v = locate_tactic_call loc (val_interp { ist with lfun=lfun } gl body)
+    in tactic_of_value v gl
+
+(* Initial call for interpretation *)
+let interp_tac_gen lfun debug t gl = 
+  interp_tactic { lfun=lfun; debug=debug } 
+    (intern_tactic {
+      ltacvars = (List.map fst lfun, []); ltacrecvars = [];
+      gsigma = project gl; genv = pf_env gl } t) gl
+
+let eval_tactic t = interp_tactic { lfun=[]; debug=get_debug() } t
+
+let interp t = interp_tac_gen [] (get_debug()) t
+
+(* Hides interpretation for pretty-print *)
+let hide_interp t ot gl =
+  let ist = { ltacvars = ([],[]); ltacrecvars = []; 
+            gsigma = project gl; genv = pf_env gl } in
+  let te = intern_tactic ist t in
+  let t = eval_tactic te in
+  match ot with 
+  | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl
+  | Some t' -> abstract_tactic_expr (TacArg (Tacexp te)) (tclTHEN t t') gl
+
+(***************************************************************************)
+(* Substitution at module closing time *)
+
+let subst_quantified_hypothesis _ x = x
+
+let subst_declared_or_quantified_hypothesis _ x = x
+
+let subst_inductive subst (kn,i) = (subst_kn subst kn,i)
+
+let subst_rawconstr subst (c,e) =
+  assert (e=None); (* e<>None only for toplevel tactics *)
+  (subst_raw subst c,None)
+
+let subst_binding subst (loc,b,c) =
+  (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c)
+
+let subst_bindings subst = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_rawconstr subst) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
+
+let subst_raw_with_bindings subst (c,bl) =
+  (subst_rawconstr subst c, subst_bindings subst bl)
+
+let subst_induction_arg subst = function
+  | ElimOnConstr c -> ElimOnConstr (subst_rawconstr subst c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent id as x -> x
+
+let subst_evaluable_reference subst = function
+  | EvalVarRef id -> EvalVarRef id
+  | EvalConstRef kn -> EvalConstRef (subst_kn subst kn)
+
+let subst_and_short_name f (c,n) =
+  assert (n=None); (* since tacdef are strictly globalized *)
+  (f c,None)
+
+let subst_or_var f =  function
+  | ArgVar _ as x -> x
+  | ArgArg (x) -> ArgArg (f x)
+
+let subst_located f (_loc,id) = (loc,f id)
+
+let subst_reference subst = 
+  subst_or_var (subst_located (subst_kn subst))
+
+let subst_global_reference subst = 
+  subst_or_var (subst_located (subst_global subst))
+
+let subst_evaluable subst =
+  subst_or_var (subst_and_short_name (subst_evaluable_reference subst))
+
+let subst_unfold subst (l,e) = 
+  (l,subst_evaluable subst e)
+
+let subst_flag subst red =
+  { red with rConst = List.map (subst_evaluable subst) red.rConst }
+
+let subst_constr_occurrence subst (l,c) = (l,subst_rawconstr subst c)
+
+let subst_redexp subst = function
+  | Unfold l -> Unfold (List.map (subst_unfold subst) l)
+  | Fold l -> Fold (List.map (subst_rawconstr subst) l)
+  | Cbv f -> Cbv (subst_flag subst f)
+  | Lazy f -> Lazy (subst_flag subst f)
+  | Pattern l -> Pattern (List.map (subst_constr_occurrence subst) l)
+  | Simpl o -> Simpl (option_app (subst_constr_occurrence subst) o)
+  | (Red _ | Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s, subst_rawconstr subst c)
+
+let subst_raw_may_eval subst = function
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_rawconstr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_rawconstr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
+
+let subst_match_pattern subst = function
+  | Subterm (ido,pc) -> Subterm (ido,subst_pattern subst pc)
+  | Term pc -> Term (subst_pattern subst pc)
+
+let rec subst_match_context_hyps subst = function
+  | Hyp (locs,mp) :: tl ->
+      Hyp (locs,subst_match_pattern subst mp)
+      :: subst_match_context_hyps subst tl
+  | [] -> []
+
+let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
+  (* Basic tactics *)
+  | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
+  | TacAssumption as x -> x
+  | TacExact c -> TacExact (subst_rawconstr subst c)
+  | TacApply cb -> TacApply (subst_raw_with_bindings subst cb)
+  | TacElim (cb,cbo) ->
+      TacElim (subst_raw_with_bindings subst cb,
+               option_app (subst_raw_with_bindings subst) cbo)
+  | TacElimType c -> TacElimType (subst_rawconstr subst c)
+  | TacCase cb -> TacCase (subst_raw_with_bindings subst cb)
+  | TacCaseType c -> TacCaseType (subst_rawconstr subst c)
+  | TacFix (idopt,n) as x -> x
+  | TacMutualFix (id,n,l) ->
+      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
+  | TacCofix idopt as x -> x
+  | TacMutualCofix (id,l) ->
+      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
+  | TacCut c -> TacCut (subst_rawconstr subst c)
+  | TacTrueCut (ido,c) -> TacTrueCut (ido, subst_rawconstr subst c)
+  | TacForward (b,na,c) -> TacForward (b,na,subst_rawconstr subst c)
+  | TacGeneralize cl -> TacGeneralize (List.map (subst_rawconstr subst) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c)
+  | TacLetTac (id,c,clp) -> TacLetTac (id,subst_rawconstr subst c,clp)
+  | TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido)
+
+  (* Automation tactics *)
+  | TacTrivial l -> TacTrivial l
+  | TacAuto (n,l) -> TacAuto (n,l)
+  | TacAutoTDB n -> TacAutoTDB n
+  | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
+  | TacDestructConcl -> TacDestructConcl
+  | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
+  | TacDAuto (n,p) -> TacDAuto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction h as x -> x
+  | TacNewInduction (c,cbo,ids) ->
+      TacNewInduction (subst_induction_arg subst c,
+               option_app (subst_raw_with_bindings subst) cbo, ids)
+  | TacSimpleDestruct h as x -> x
+  | TacNewDestruct (c,cbo,ids) ->
+      TacNewDestruct (subst_induction_arg subst c,
+               option_app (subst_raw_with_bindings subst) cbo, ids)
+  | TacDoubleInduction (h1,h2) as x -> x
+  | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
+  | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
+  | TacDecompose (l,c) ->
+      let l = List.map (subst_or_var (subst_inductive subst)) l in
+      TacDecompose (l,subst_rawconstr subst c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,subst_raw_with_bindings subst l)
+  | TacLApply c -> TacLApply (subst_rawconstr subst c)
+
+  (* Context management *)
+  | TacClear l as x -> x
+  | TacClearBody l as x -> x
+  | TacMove (dep,id1,id2) as x -> x
+  | TacRename (id1,id2) as x -> x
+
+  (* Constructors *)
+  | TacLeft bl -> TacLeft (subst_bindings subst bl)
+  | TacRight bl -> TacRight (subst_bindings subst bl)
+  | TacSplit (b,bl) -> TacSplit (b,subst_bindings subst bl)
+  | TacAnyConstructor t -> TacAnyConstructor (option_app (subst_tactic subst) t)
+  | TacConstructor (n,bl) -> TacConstructor (n, subst_bindings subst bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
+  | TacChange (occl,c,cl) ->
+      TacChange (option_app (subst_constr_occurrence subst) occl,
+        subst_rawconstr subst c, cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity | TacSymmetry _ as x -> x
+  | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c)
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,l),hyp) ->
+     TacInversion (DepInversion (k,option_app (subst_rawconstr subst) c,l),hyp)
+  | TacInversion (NonDepInversion _,_) as x -> x
+  | TacInversion (InversionUsing (c,cl),hyp) ->
+      TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp)
+
+  (* For extensions *)
+  | TacExtend (_loc,opn,l) ->
+      TacExtend (loc,opn,List.map (subst_genarg subst) l)
+  | TacAlias (_,s,l,(dir,body)) ->
+      TacAlias (loc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
+        (dir,subst_tactic subst body))
+
+and subst_tactic subst (t:glob_tactic_expr) = match t with
+  | TacAtom (_loc,t) -> TacAtom (loc, subst_atomic subst t)
+  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
+  | TacLetRecIn (lrc,u) ->
+      let lrc = List.map (fun (n,b) -> (n,subst_tactic_fun subst b)) lrc in
+      TacLetRecIn (lrc,(subst_tactic subst u:glob_tactic_expr))
+  | TacLetIn (l,u) ->
+      let l = List.map (fun (n,c,b) -> (n,option_app (subst_tactic subst) c,subst_tacarg subst b)) l in
+      TacLetIn (l,subst_tactic subst u)
+  | TacMatchContext (lr,lmr) ->
+      TacMatchContext(lr, subst_match_rule subst lmr)
+  | TacMatch (c,lmr) ->
+      TacMatch (subst_tactic subst c,subst_match_rule subst lmr)
+  | TacId _ | TacFail _ as x -> x
+  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
+  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
+  | TacThen (t1,t2) ->
+      TacThen (subst_tactic subst t1,subst_tactic subst t2)
+  | TacThens (t,tl) ->
+      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
+  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTry tac -> TacTry (subst_tactic subst tac)
+  | TacInfo tac -> TacInfo (subst_tactic subst tac)
+  | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
+  | TacOrelse (tac1,tac2) ->
+      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
+  | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
+  | TacArg a -> TacArg (subst_tacarg subst a)
+
+and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
+
+and subst_tacarg subst = function
+  | Reference r -> Reference (subst_reference subst r)
+  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
+  | MetaIdArg (_loc,_) -> assert false
+  | TacCall (_loc,f,l) ->
+      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
+  | Tacexp t -> Tacexp (subst_tactic subst t)
+  | TacDynamic(_,t) as x ->
+      (match tag t with
+	| "tactic" | "value" | "constr" -> x
+	| s -> anomaly_loc (loc, "Tacinterp.val_interp",
+                 str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and subst_match_rule subst = function
+  | (All tc)::tl ->
+      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let hyps = subst_match_context_hyps subst rl in
+      let pat = subst_match_pattern subst mp in
+      Pat (hyps,pat,subst_tactic subst tc)
+      ::(subst_match_rule subst tl)
+  | [] -> []
+
+and subst_genarg subst (x:glob_generic_argument) =
+  match genarg_tag x with
+  | BoolArgType -> in_gen globwit_bool (out_gen globwit_bool x)
+  | IntArgType -> in_gen globwit_int (out_gen globwit_int x)
+  | IntOrVarArgType -> in_gen globwit_int_or_var (out_gen globwit_int_or_var x)
+  | StringArgType -> in_gen globwit_string (out_gen globwit_string x)
+  | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x)
+  | IntroPatternArgType ->
+      in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x)
+  | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x)
+  | HypArgType -> in_gen globwit_var (out_gen globwit_var x)
+  | RefArgType ->
+      in_gen globwit_ref (subst_global_reference subst 
+	(out_gen globwit_ref x))
+  | SortArgType ->
+      in_gen globwit_sort (out_gen globwit_sort x)
+  | ConstrArgType ->
+      in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen globwit_quant_hyp
+        (subst_declared_or_quantified_hypothesis subst 
+          (out_gen globwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
+  | TacticArgType ->
+      in_gen globwit_tactic (subst_tactic subst (out_gen globwit_tactic x))
+  | CastedOpenConstrArgType ->
+      in_gen globwit_casted_open_constr 
+        (subst_rawconstr subst (out_gen globwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen globwit_constr_with_bindings
+        (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen globwit_bindings
+        (subst_bindings subst (out_gen globwit_bindings x))
+  | List0ArgType _ -> app_list0 (subst_genarg subst) x
+  | List1ArgType _ -> app_list1 (subst_genarg subst) x
+  | OptArgType _ -> app_opt (subst_genarg subst) x
+  | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x
+  | ExtraArgType s -> lookup_genarg_subst s subst x
+
+(***************************************************************************)
+(* Tactic registration *)
+
+(* For bad tactic calls *)
+let bad_tactic_args s =
+  anomalylabstrm s
+    (str "Tactic " ++ str s ++ str " called with bad arguments")
+
+(* Declaration of the TAC-DEFINITION object *)
+let add (kn,td) = mactab := Gmap.add kn td !mactab
+
+let load_md i ((sp,kn),defs) =
+  let dp,_ = repr_path sp in
+  let mp,dir,_ = repr_kn kn in
+  List.iter (fun (id,t) -> 
+    let sp = Libnames.make_path dp id in
+    let kn = Names.make_kn mp dir (label_of_id id) in
+    Nametab.push_tactic (Until i) sp kn;
+    add (kn,t)) defs
+
+let open_md i((sp,kn),defs) =
+  let dp,_ = repr_path sp in
+  let mp,dir,_ = repr_kn kn in
+  List.iter (fun (id,t) -> 
+    let sp = Libnames.make_path dp id in
+    let kn = Names.make_kn mp dir (label_of_id id) in
+    Nametab.push_tactic (Exactly i) sp kn) defs
+
+let cache_md x = load_md 1 x
+
+let subst_md (_,subst,defs) =
+  List.map (fun (id,t) -> (id,subst_tactic subst t)) defs
+
+let (inMD,outMD) =
+  declare_object {(default_object "TAC-DEFINITION") with
+     cache_function  = cache_md;
+     load_function   = load_md;
+     open_function   = open_md;
+     subst_function = subst_md;
+     classify_function = (fun (_,o) -> Substitute o);       
+     export_function = (fun x -> Some x)}
+
+(* Adds a definition for tactics in the table *)
+let make_absolute_name (loc,id) =
+  let kn = Lib.make_kn id in
+  if Gmap.mem kn !mactab or is_atomic_kn kn then
+    user_err_loc (loc,"Tacinterp.add_tacdef",
+      str "There is already an Ltac named " ++ pr_id id);
+  kn
+
+let make_empty_glob_sign () =
+  { ltacvars = ([],[]); ltacrecvars = []; 
+    gsigma = Evd.empty; genv = Global.env() }
+
+let add_tacdef isrec tacl =
+(*  let isrec = if !Options.p1 then isrec else true in*)
+  let rfun = List.map (fun ((loc,id as locid),_) -> (id,make_absolute_name locid)) tacl in
+  let ist =
+    {(make_empty_glob_sign()) with ltacrecvars = if isrec then rfun else []} in
+  let gtacl =
+    List.map (fun ((_,id),def) ->
+      (id,Options.with_option strict_check (intern_tactic ist) def))
+      tacl in
+  let id0 = fst (List.hd rfun) in
+  let _ = Lib.add_leaf id0 (inMD gtacl) in
+  List.iter
+    (fun (id,_) -> Options.if_verbose msgnl (pr_id id ++ str " is defined"))
+    rfun
+
+(***************************************************************************)
+(* Other entry points *)
+
+let glob_tactic x = intern_tactic (make_empty_glob_sign ()) x
+
+let glob_tactic_env l env x = 
+  intern_tactic
+    { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }
+    x
+
+let interp_redexp env evc r = 
+  let ist = { lfun=[]; debug=get_debug () } in
+  let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = evc } in
+  redexp_interp ist evc env (intern_redexp gist r)
+
+(***************************************************************************)
+(* Backwarding recursive needs of tactic glob/interp/eval functions *)
+
+let _ = Auto.set_extern_interp
+  (fun l -> 
+    let l = List.map (fun (id,c) -> (id,VConstr c)) l in
+    interp_tactic {lfun=l;debug=get_debug()})
+let _ = Auto.set_extern_intern_tac 
+  (fun l ->
+    Options.with_option strict_check
+    (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
+let _ = Auto.set_extern_subst_tactic subst_tactic
+let _ = Dhyp.set_extern_interp eval_tactic
+let _ = Dhyp.set_extern_intern_tac
+  (fun t -> intern_tactic (make_empty_glob_sign()) t)
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
new file mode 100644
index 00000000..1f75b5a4
--- /dev/null
+++ b/tactics/tacinterp.mli
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tacinterp.mli,v 1.13.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Dyn
+open Pp
+open Names
+open Proof_type
+open Tacmach
+open Tactic_debug
+open Term
+open Tacexpr
+open Genarg
+open Topconstr
+(*i*)
+
+(* Values for interpretation *)
+type value =
+  | VTactic of Util.loc * tactic  (* For mixed ML/Ltac tactics (e.g. Tauto) *)
+  | VRTactic of (goal list sigma * validation)
+  | VFun of (identifier * value) list * identifier option list * glob_tactic_expr
+  | VVoid
+  | VInteger of int
+  | VIntroPattern of intro_pattern_expr
+  | VConstr of constr
+  | VConstr_context of constr
+  | VRec of value ref
+
+(* Signature for interpretation: val\_interp and interpretation functions *)
+and interp_sign =
+  { lfun : (identifier * value) list;
+    debug : debug_info }
+
+(* Gives the identifier corresponding to an Identifier [tactic_arg] *)
+val id_of_Identifier : Environ.env -> value -> identifier
+
+(* Gives the constr corresponding to a Constr [value] *)
+val constr_of_VConstr : Environ.env -> value -> constr
+
+(* Transforms an id into a constr if possible *)
+val constr_of_id : Environ.env -> identifier -> constr
+
+(* To embed several objects in Coqast.t *)
+val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr
+val tacticOut : raw_tactic_expr -> (interp_sign -> raw_tactic_expr)
+val valueIn : value -> raw_tactic_arg
+val valueOut: raw_tactic_arg -> value
+val constrIn : constr -> constr_expr
+val constrOut : constr_expr -> constr
+
+(* Sets the debugger mode *)
+val set_debug : debug_info -> unit
+
+(* Gives the state of debug *)
+val get_debug : unit -> debug_info
+
+(* Adds a definition for tactics in the table *)
+val add_tacdef :
+  bool -> (identifier Util.located * raw_tactic_expr) list -> unit
+val add_primitive_tactic : string -> glob_tactic_expr -> unit
+
+(* Adds an interpretation function for extra generic arguments *)
+type glob_sign = {
+  ltacvars : identifier list * identifier list;
+  ltacrecvars : (identifier * Nametab.ltac_constant) list;
+  gsigma : Evd.evar_map;
+  genv : Environ.env }
+
+val add_interp_genarg :
+  string ->
+    (glob_sign -> raw_generic_argument -> glob_generic_argument) *
+    (interp_sign -> goal sigma -> glob_generic_argument -> 
+      closed_generic_argument) *
+    (Names.substitution -> glob_generic_argument -> glob_generic_argument)
+    -> unit
+
+val interp_genarg :
+  interp_sign -> goal sigma -> glob_generic_argument -> closed_generic_argument
+
+val intern_genarg :
+  glob_sign -> raw_generic_argument -> glob_generic_argument
+
+val subst_genarg :
+  Names.substitution -> glob_generic_argument -> glob_generic_argument
+
+(* Interprets any expression *)
+val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
+
+(* Interprets redexp arguments *)
+val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr
+  -> Tacred.red_expr
+
+(* Interprets tactic expressions *)
+val interp_tac_gen : (identifier * value) list -> 
+                 debug_info -> raw_tactic_expr -> tactic
+
+(* Initial call for interpretation *)
+val glob_tactic : raw_tactic_expr -> glob_tactic_expr
+
+val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+
+val eval_tactic : glob_tactic_expr -> tactic
+
+val interp : raw_tactic_expr -> tactic
+
+val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+
+(* Hides interpretation for pretty-print *)
+
+val hide_interp : raw_tactic_expr -> tactic option -> tactic
+
+(* Adds an interpretation function *)
+val interp_add : string * (interp_sign -> Coqast.t -> value) -> unit
+
+(* Adds a possible existing interpretation function *)
+val overwriting_interp_add : string * (interp_sign -> Coqast.t -> value) ->
+                             unit
+
+
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
new file mode 100644
index 00000000..77898afb
--- /dev/null
+++ b/tactics/tacticals.ml
@@ -0,0 +1,457 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tacticals.ml,v 1.60.2.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Sign
+open Declarations
+open Inductive
+open Reduction
+open Environ
+open Libnames
+open Refiner
+open Tacmach
+open Clenv
+open Pattern
+open Matching
+open Evar_refiner
+open Genarg
+open Tacexpr
+
+(******************************************)
+(*         Basic Tacticals                *)
+(******************************************)
+
+(*************************************************)
+(* Tacticals re-exported from the Refiner module.*)
+(*************************************************)
+
+let tclIDTAC         = tclIDTAC
+let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE
+let tclORELSE        = tclORELSE
+let tclTHEN          = tclTHEN
+let tclTHENLIST      = tclTHENLIST
+let tclTHEN_i        = tclTHEN_i
+let tclTHENFIRST     = tclTHENFIRST
+let tclTHENLAST      = tclTHENLAST
+let tclTHENS         = tclTHENS
+let tclTHENSV        = Refiner.tclTHENSV
+let tclTHENSFIRSTn   = Refiner.tclTHENSFIRSTn
+let tclTHENSLASTn    = Refiner.tclTHENSLASTn
+let tclTHENFIRSTn    = Refiner.tclTHENFIRSTn
+let tclTHENLASTn     = Refiner.tclTHENLASTn
+let tclREPEAT        = Refiner.tclREPEAT
+let tclREPEAT_MAIN   = tclREPEAT_MAIN
+let tclFIRST         = Refiner.tclFIRST
+let tclSOLVE         = Refiner.tclSOLVE
+let tclTRY           = Refiner.tclTRY
+let tclINFO          = Refiner.tclINFO
+let tclCOMPLETE      = Refiner.tclCOMPLETE
+let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
+let tclFAIL          = Refiner.tclFAIL
+let tclDO            = Refiner.tclDO
+let tclPROGRESS      = Refiner.tclPROGRESS
+let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
+let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
+let tclTHENTRY       = tclTHENTRY
+let tclIFTHENELSE    = tclIFTHENELSE
+let tclIFTHENSELSE   = tclIFTHENSELSE
+let tclIFTHENSVELSE   = tclIFTHENSVELSE
+
+let unTAC            = unTAC
+
+(* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *)
+let tclTHENSEQ = List.fold_left tclTHEN tclIDTAC
+
+(* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *)
+(* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *)
+let tclMAP tacfun l = 
+  List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC
+
+(* apply a tactic to the nth element of the signature  *)
+
+let tclNTH_HYP m (tac : constr->tactic) gl =
+  tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) 
+       with Failure _ -> error "No such assumption") gl
+
+(* apply a tactic to the last element of the signature  *)
+
+let tclLAST_HYP = tclNTH_HYP 1
+
+let tclTRY_sign (tac : constr->tactic) sign gl =
+  let rec arec = function
+    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | [s]     -> tac (mkVar s) (*added in order to get useful error messages *)
+    | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) 
+  in 
+  arec (ids_of_named_context sign) gl
+
+let tclTRY_HYPS (tac : constr->tactic) gl = 
+  tclTRY_sign tac (pf_hyps gl) gl
+
+(***************************************)
+(*           Clause Tacticals          *)
+(***************************************)
+
+(* The following functions introduce several tactic combinators and
+   functions useful for working with clauses. A clause is either None
+   or (Some id), where id is an identifier. This type is useful for
+   defining tactics that may be used either to transform the
+   conclusion (None) or to transform a hypothesis id (Some id).  --
+   --Eduardo (8/8/97) 
+*)
+
+(* The type of clauses *)
+
+type simple_clause = identifier gsimple_clause
+type clause = identifier gclause
+
+let allClauses = { onhyps=None; onconcl=true; concl_occs=[] }
+let allHyps = { onhyps=None; onconcl=false; concl_occs=[] }
+let onHyp id =
+  { onhyps=Some[(id,[],(InHyp, ref None))]; onconcl=false; concl_occs=[] }
+let onConcl = { onhyps=Some[]; onconcl=true; concl_occs=[] }
+
+let simple_clause_list_of cl gls =
+  let hyps =
+    match cl.onhyps with 
+        None ->
+          List.map (fun id -> Some(id,[],(InHyp,ref None))) (pf_ids_of_hyps gls)
+      | Some l -> List.map (fun h -> Some h) l in
+  if cl.onconcl then None::hyps else hyps
+
+
+(* OR-branch *)
+let tryClauses tac cl gls = 
+  let rec firstrec = function
+    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | [cls]   -> tac cls (* added in order to get a useful error message *)
+    | cls::tl -> (tclORELSE (tac cls) (firstrec tl))
+  in
+  let hyps = simple_clause_list_of cl gls in
+  firstrec hyps gls
+
+(* AND-branch *)
+let onClauses tac cl gls = 
+  let hyps = simple_clause_list_of cl gls in
+  tclMAP tac hyps gls
+
+(* AND-branch reverse order*)
+let onClausesLR tac cl gls = 
+  let hyps = simple_clause_list_of cl gls in
+  tclMAP tac (List.rev hyps) gls
+
+(* A clause corresponding to the |n|-th hypothesis or None *)
+
+let nth_clause n gl =
+  if n = 0 then 
+    onConcl
+  else if n < 0 then 
+    let id = List.nth (List.rev (pf_ids_of_hyps gl)) (-n-1) in 
+    onHyp id
+  else 
+    let id = List.nth (pf_ids_of_hyps gl) (n-1) in 
+    onHyp id
+
+(* Gets the conclusion or the type of a given hypothesis *)
+
+let clause_type cls gl =
+  match simple_clause_of cls with
+    | None    -> pf_concl gl
+    | Some (id,_,_) -> pf_get_hyp_typ gl id
+
+(* Functions concerning matching of clausal environments *)
+
+let pf_is_matching gls pat n =
+  let (wc,_) = startWalk gls in 
+  is_matching_conv (w_env wc) (w_Underlying wc) pat n
+
+let pf_matches gls pat n =
+  matches_conv (pf_env gls) (project gls) pat n
+
+(* [OnCL clausefinder clausetac]
+ * executes the clausefinder to find the clauses, and then executes the
+ * clausetac on the clause so obtained. *)
+
+let onCL cfind cltac gl = cltac (cfind gl) gl
+
+
+(* [OnHyps hypsfinder hypstac]
+ * idem [OnCL] but only for hypotheses, not for conclusion *)
+
+let onHyps find tac gl = tac (find gl) gl
+
+
+
+(* Create a clause list with all the hypotheses from the context, occuring
+   after id *)
+
+let afterHyp id gl =
+  fst (list_splitby (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
+    
+
+(* Create a singleton clause list with the last hypothesis from then context *)
+
+let lastHyp gl = List.hd (pf_ids_of_hyps gl)
+
+
+(* Create a clause list with the n last hypothesis from then context *)
+
+let nLastHyps n gl =
+  try list_firstn n (pf_hyps gl)
+  with Failure "firstn" -> error "Not enough hypotheses in the goal"
+
+
+let onClause t cls gl  = t cls gl
+let tryAllClauses  tac = tryClauses tac allClauses
+let onAllClauses   tac = onClauses tac allClauses
+let onAllClausesLR tac = onClausesLR tac allClauses
+let onNthLastHyp n tac gls = tac (nth_clause n gls) gls
+
+let tryAllHyps     tac =
+  tryClauses (function Some(id,_,_) -> tac id | _ -> assert false) allHyps
+let onNLastHyps n  tac     = onHyps (nLastHyps n) (tclMAP tac)
+let onLastHyp      tac gls = tac (lastHyp gls) gls
+
+let clauseTacThen tac continuation =
+  (fun cls -> (tclTHEN (tac cls) continuation))
+
+let if_tac pred tac1 tac2 gl =
+  if pred gl then tac1 gl else tac2 gl
+
+let ifOnClause pred tac1 tac2 cls gl =
+  if pred (cls,clause_type cls gl) then
+    tac1 cls gl
+  else 
+    tac2 cls gl
+
+let ifOnHyp pred tac1 tac2 id gl =
+  if pred (id,pf_get_hyp_typ gl id) then
+    tac1 id gl
+  else 
+    tac2 id gl
+
+(***************************************)
+(*         Elimination Tacticals       *)
+(***************************************)
+
+(* The following tacticals allow to apply a tactic to the
+   branches generated by the application of an elimination
+  tactic. 
+
+  Two auxiliary types --branch_args and branch_assumptions-- are
+  used to keep track of some information about the ``branches'' of 
+  the elimination. *)
+
+type branch_args = {
+  ity        : inductive;   (* the type we were eliminating on *)
+  largs      : constr list; (* its arguments *)
+  branchnum  : int;         (* the branch number *)
+  pred       : constr;      (* the predicate we used *)
+  nassums    : int;         (* the number of assumptions to be introduced *)
+  branchsign : bool list;   (* the signature of the branch.
+                               true=recursive argument, false=constant *)
+  branchnames : intro_pattern_expr list}
+
+type branch_assumptions = {
+  ba        : branch_args;     (* the branch args *)
+  assums    : named_context}   (* the list of assumptions introduced *)
+
+let compute_induction_names n = function
+  | None ->
+      Array.make n []
+  | Some (IntroOrAndPattern names) when List.length names = n ->
+      Array.of_list names
+  | _ ->
+      errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names")
+
+let compute_construtor_signatures isrec (_,k as ity) =
+  let rec analrec c recargs =
+    match kind_of_term c, recargs with 
+    | Prod (_,_,c), recarg::rest ->
+	let b = match dest_recarg recarg with
+	  | Norec | Imbr _  -> false
+	  | Mrec j  -> isrec & j=k
+	in b :: (analrec c rest)
+    | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
+    | _, [] -> []
+    | _ -> anomaly "compute_construtor_signatures"
+  in 
+  let (mib,mip) = Global.lookup_inductive ity in
+  let n = mip.mind_nparams in
+  let lc =
+    Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in
+  let lrecargs = dest_subterms mip.mind_recargs in
+  array_map2 analrec lc lrecargs
+
+let elimination_sort_of_goal gl = 
+  match kind_of_term (hnf_type_of gl (pf_concl gl)) with 
+    | Sort s ->
+	(match s with
+	   | Prop Null -> InProp
+	   | Prop Pos -> InSet
+	   | Type _ -> InType)
+    | _        -> anomaly "goal should be a type"
+
+let elimination_sort_of_hyp id gl = 
+  match kind_of_term (hnf_type_of gl (pf_get_hyp_typ gl id)) with 
+    | Sort s ->
+	(match s with
+	   | Prop Null -> InProp
+	   | Prop Pos -> InSet
+	   | Type _ -> InType)
+    | _        -> anomaly "goal should be a type"
+
+
+(* Find the right elimination suffix corresponding to the sort of the goal *)
+(* c should be of type A1->.. An->B with B an inductive definition *)
+
+let last_arg c = match kind_of_term c with
+  | App (f,cl) -> array_last cl
+  | _ -> anomaly "last_arg"
+
+let general_elim_then_using 
+  elim isrec allnames tac predicate (indbindings,elimbindings) c gl =
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  (* applying elimination_scheme just a little modified *)
+  let (wc,kONT)  = startWalk gl in
+  let indclause  = mk_clenv_from wc (c,t) in
+  let indclause' = clenv_constrain_with_bindings indbindings indclause in
+  let elimclause = mk_clenv_from () (elim,w_type_of wc elim) in
+  let indmv = 
+    match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+      | Meta mv -> mv
+      | _         -> error "elimination"
+  in
+  let pmv =
+    let p, _ = decompose_app (clenv_template_type elimclause).rebus in
+    match kind_of_term p with
+      | Meta p -> p
+      | _ ->
+	  let name_elim =
+	    match kind_of_term elim with
+	      | Const kn -> string_of_kn kn
+	      | Var id -> string_of_id id
+	      | _ -> "\b"
+	  in
+	  error ("The elimination combinator " ^ name_elim ^ " is not known") 
+  in
+  let elimclause' = clenv_fchain indmv elimclause indclause' in
+  let elimclause' = clenv_constrain_with_bindings elimbindings elimclause' in
+  let branchsigns = compute_construtor_signatures isrec ity in
+  let brnames = compute_induction_names (Array.length branchsigns) allnames in
+  let after_tac ce i gl =
+    let (hd,largs) = decompose_app (clenv_template_type ce).rebus in
+    let ba = { branchsign = branchsigns.(i);
+               branchnames = brnames.(i);
+               nassums = 
+		 List.fold_left 
+                   (fun acc b -> if b then acc+2 else acc+1)
+                   0 branchsigns.(i);
+               branchnum = i+1;
+               ity = ity;
+               largs = List.map (clenv_instance_term ce) largs;
+               pred = clenv_instance_term ce hd }
+    in 
+    tac ba gl
+  in
+  let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in
+  let elimclause' =
+    match predicate with
+       | None   -> elimclause'
+       | Some p -> clenv_assign pmv p elimclause'
+  in 
+  elim_res_pf_THEN_i kONT elimclause' branchtacs gl
+
+
+let elimination_then_using tac predicate (indbindings,elimbindings) c gl = 
+  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let elim =
+    Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in
+  general_elim_then_using
+    elim true None tac predicate (indbindings,elimbindings) c gl
+
+
+let elimination_then tac        = elimination_then_using tac None 
+let simple_elimination_then tac = elimination_then tac ([],[])
+
+let case_then_using allnames tac predicate (indbindings,elimbindings) c gl =
+  (* finding the case combinator *)
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma = project gl in 
+  let sort  = elimination_sort_of_goal gl  in
+  let elim  = Indrec.make_case_dep (pf_env gl) sigma ity sort in  
+  general_elim_then_using 
+    elim false allnames tac predicate (indbindings,elimbindings) c gl
+
+let case_nodep_then_using allnames tac predicate (indbindings,elimbindings)
+  c gl =
+  (* finding the case combinator *)
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma = project gl in 
+  let sort  = elimination_sort_of_goal gl  in
+  let elim  = Indrec.make_case_nodep (pf_env gl) sigma ity sort in  
+  general_elim_then_using 
+    elim false allnames tac predicate (indbindings,elimbindings) c gl
+
+
+let make_elim_branch_assumptions ba gl =   
+  let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
+    match lb,lc with 
+      | ([], _) -> 
+          { ba = ba;
+            assums    = assums}
+      | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) ->
+	  makerec (recarg::indarg::assums,
+		   idrec::cargs,
+		   idrec::recargs,
+		   constargs,
+		   idind::indargs) tl idtl
+      | ((false::tl), ((id,_,_ as constarg)::idtl))      ->
+	  makerec (constarg::assums,
+		   id::cargs,
+		   id::constargs,
+		   recargs,
+		   indargs) tl idtl
+      | (_, _) -> error "make_elim_branch_assumptions"
+  in 
+  makerec ([],[],[],[],[]) ba.branchsign
+    (try list_firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly "make_elim_branch_assumptions")
+
+let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl
+
+let make_case_branch_assumptions ba gl =
+  let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 =
+    match p_0,p_1 with 
+      | ([], _) -> 
+          { ba = ba;
+            assums    = assums}
+      | ((true::tl), ((idrec,_,_ as recarg)::idtl)) ->
+	  makerec (recarg::assums,
+		   idrec::cargs,
+		   idrec::recargs,
+		   constargs) tl idtl
+      | ((false::tl), ((id,_,_ as constarg)::idtl)) ->
+	  makerec (constarg::assums,
+		   id::cargs,
+		   recargs,
+		   id::constargs) tl idtl
+      | (_, _) -> error "make_case_branch_assumptions"
+  in 
+  makerec ([],[],[],[]) ba.branchsign
+    (try list_firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly "make_case_branch_assumptions")
+
+let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl
+
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
new file mode 100644
index 00000000..2cb63b40
--- /dev/null
+++ b/tactics/tacticals.mli
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tacticals.mli,v 1.38.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Tacmach
+open Proof_type
+open Clenv
+open Reduction
+open Pattern
+open Genarg
+open Tacexpr
+(*i*)
+
+(* Tacticals i.e. functions from tactics to tactics. *)
+
+val tclIDTAC         : tactic
+val tclIDTAC_MESSAGE : string -> tactic
+val tclORELSE        : tactic -> tactic -> tactic
+val tclTHEN          : tactic -> tactic -> tactic
+val tclTHENSEQ       : tactic list -> tactic
+val tclTHENLIST      : tactic list -> tactic
+val tclTHEN_i        : tactic -> (int -> tactic) -> tactic
+val tclTHENFIRST     : tactic -> tactic -> tactic
+val tclTHENLAST      : tactic -> tactic -> tactic
+val tclTHENS         : tactic -> tactic list -> tactic
+val tclTHENSV        : tactic -> tactic array -> tactic
+val tclTHENSLASTn    : tactic -> tactic -> tactic array -> tactic
+val tclTHENLASTn     : tactic -> tactic array -> tactic
+val tclTHENSFIRSTn   : tactic -> tactic array -> tactic -> tactic
+val tclTHENFIRSTn    : tactic -> tactic array -> tactic
+val tclREPEAT        : tactic -> tactic
+val tclREPEAT_MAIN   : tactic -> tactic
+val tclFIRST         : tactic list -> tactic
+val tclSOLVE         : tactic list -> tactic
+val tclTRY           : tactic -> tactic
+val tclINFO          : tactic -> tactic
+val tclCOMPLETE      : tactic -> tactic
+val tclAT_LEAST_ONCE : tactic -> tactic
+val tclFAIL          : int -> string -> tactic
+val tclDO            : int -> tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
+val tclWEAK_PROGRESS : tactic -> tactic
+val tclNOTSAMEGOAL   : tactic -> tactic
+val tclTHENTRY       : tactic -> tactic -> tactic
+
+val tclNTH_HYP       : int -> (constr -> tactic) -> tactic
+val tclMAP           : ('a -> tactic) -> 'a list -> tactic
+val tclLAST_HYP      : (constr -> tactic) -> tactic
+val tclTRY_sign      : (constr -> tactic) -> named_context -> tactic
+val tclTRY_HYPS      : (constr -> tactic) -> tactic
+
+val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
+val tclIFTHENSELSE   : tactic -> tactic list -> tactic -> tactic
+val tclIFTHENSVELSE  : tactic -> tactic array -> tactic -> tactic
+
+
+
+val unTAC            : tactic -> goal sigma -> proof_tree sigma
+
+(*s Clause tacticals. *)
+
+type simple_clause = identifier gsimple_clause
+type clause = identifier gclause
+
+val allClauses : 'a gclause
+val allHyps : clause
+val onHyp : identifier -> clause
+val onConcl : 'a gclause
+
+val nth_clause  : int -> goal sigma -> clause
+val clause_type : clause -> goal sigma -> constr
+val simple_clause_list_of : clause -> goal sigma -> simple_clause list
+
+val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map
+val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
+
+val afterHyp   : identifier -> goal sigma -> named_context
+val lastHyp    : goal sigma -> identifier
+val nLastHyps  : int -> goal sigma -> named_context
+
+val onCL           : (goal sigma -> clause) -> 
+                     (clause -> tactic) -> tactic
+val tryAllClauses  : (simple_clause -> tactic) -> tactic
+val onAllClauses   : (simple_clause -> tactic) -> tactic
+val onClause       : (clause -> tactic) -> clause -> tactic
+val onClauses      : (simple_clause -> tactic) -> clause -> tactic
+val onAllClausesLR : (simple_clause -> tactic) -> tactic
+val onNthLastHyp   : int -> (clause -> tactic) -> tactic
+val clauseTacThen  : (clause -> tactic) -> tactic -> clause -> tactic
+val if_tac         : (goal sigma -> bool) -> tactic -> (tactic) -> tactic
+val ifOnClause     : 
+  (clause * types -> bool) ->
+    (clause -> tactic) -> (clause -> tactic) -> clause -> tactic
+val ifOnHyp        : 
+  (identifier * types -> bool) ->
+    (identifier -> tactic) -> (identifier -> tactic) -> identifier -> tactic
+
+val onHyps         : (goal sigma -> named_context) -> 
+                     (named_context -> tactic) -> tactic
+val tryAllHyps     : (identifier -> tactic) -> tactic
+val onNLastHyps    : int -> (named_declaration -> tactic) -> tactic
+val onLastHyp      : (identifier -> tactic) -> tactic
+
+(*s Elimination tacticals. *)
+
+type branch_args = { 
+  ity        : inductive;   (* the type we were eliminating on *)
+  largs      : constr list; (* its arguments *)
+  branchnum  : int;         (* the branch number *)
+  pred       : constr;      (* the predicate we used *)
+  nassums    : int;         (* the number of assumptions to be introduced *)
+  branchsign : bool list;   (* the signature of the branch.
+                               true=recursive argument, false=constant *)
+  branchnames : intro_pattern_expr list}
+
+type branch_assumptions = {
+  ba        : branch_args;     (* the branch args *)
+  assums    : named_context}   (* the list of assumptions introduced *)
+
+(* Useful for "as intro_pattern" modifier *)
+val compute_induction_names : 
+  int -> intro_pattern_expr option -> intro_pattern_expr list array
+
+val elimination_sort_of_goal : goal sigma -> sorts_family
+val elimination_sort_of_hyp  : identifier -> goal sigma -> sorts_family
+
+val general_elim_then_using :
+  constr -> (* isrec: *) bool -> intro_pattern_expr option ->
+    (branch_args -> tactic) -> constr option -> 
+      (arg_bindings * arg_bindings) -> constr -> tactic
+	  
+val elimination_then_using :
+  (branch_args -> tactic) -> constr option -> 
+    (arg_bindings * arg_bindings) -> constr -> tactic
+
+val elimination_then :
+  (branch_args -> tactic) -> 
+    (arg_bindings * arg_bindings) -> constr -> tactic
+
+val case_then_using :
+  intro_pattern_expr option -> (branch_args -> tactic) -> 
+    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+
+val case_nodep_then_using :
+  intro_pattern_expr option -> (branch_args -> tactic) -> 
+    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+
+val simple_elimination_then :
+  (branch_args -> tactic) -> constr -> tactic
+
+val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
+val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
new file mode 100644
index 00000000..cab4f025
--- /dev/null
+++ b/tactics/tactics.ml
@@ -0,0 +1,1922 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tactics.ml,v 1.162.2.2 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Termops
+open Declarations
+open Inductive
+open Inductiveops
+open Reductionops
+open Environ
+open Libnames
+open Evd
+open Pfedit
+open Tacred
+open Rawterm
+open Tacmach
+open Proof_trees
+open Proof_type
+open Logic
+open Evar_refiner
+open Clenv
+open Refiner
+open Tacticals
+open Hipattern
+open Coqlib
+open Nametab
+open Genarg
+open Tacexpr
+open Decl_kinds
+
+exception Bound
+
+let rec nb_prod x =
+  let rec count n c =
+    match kind_of_term c with
+        Prod(_,_,t) -> count (n+1) t
+      | LetIn(_,a,_,t) -> count n (subst1 a t)
+      | Cast(c,_) -> count n c
+      | _ -> n
+  in count 0 x
+
+(*********************************************)
+(*                 Tactics                   *)
+(*********************************************)
+
+(****************************************)
+(* General functions                    *)
+(****************************************)
+
+(*
+let get_pairs_from_bindings = 
+  let pair_from_binding = function  
+    | [(Bindings binds)] -> binds
+    | _                  -> error "not a binding list!"
+  in 
+  List.map pair_from_binding
+*)
+
+let string_of_inductive c = 
+  try match kind_of_term c with
+  | Ind ind_sp -> 
+      let (mib,mip) = Global.lookup_inductive ind_sp in 
+      string_of_id mip.mind_typename
+  | _ -> raise Bound
+  with Bound -> error "Bound head variable"
+
+let rec head_constr_bound t l =
+  let t = strip_outer_cast(collapse_appl t) in
+  match kind_of_term t with
+    | Prod (_,_,c2)  -> head_constr_bound c2 l 
+    | LetIn (_,_,_,c2) -> head_constr_bound c2 l 
+    | App (f,args)  -> 
+	head_constr_bound f (Array.fold_right (fun a l -> a::l) args l)
+    | Const _        -> t::l
+    | Ind _       -> t::l
+    | Construct _ -> t::l
+    | Var _          -> t::l
+    | _                -> raise Bound
+
+let head_constr c = 
+  try head_constr_bound c [] with Bound -> error "Bound head variable"
+
+(*
+let bad_tactic_args s l =
+  raise (RefinerError (BadTacticArgs (s,l)))
+*)
+
+(******************************************)
+(*           Primitive tactics            *)
+(******************************************)
+
+let introduction    = Tacmach.introduction 
+let intro_replacing = Tacmach.intro_replacing 
+let internal_cut    = Tacmach.internal_cut
+let internal_cut_rev = Tacmach.internal_cut_rev
+let refine          = Tacmach.refine
+let convert_concl   = Tacmach.convert_concl
+let convert_hyp     = Tacmach.convert_hyp
+let thin            = Tacmach.thin 
+let thin_body       = Tacmach.thin_body
+
+(* Moving hypotheses *)
+let move_hyp        = Tacmach.move_hyp 
+
+(* Renaming hypotheses *)
+let rename_hyp      = Tacmach.rename_hyp
+
+(* Refine as a fixpoint *)
+let mutual_fix = Tacmach.mutual_fix
+
+let fix ido n = match ido with
+  | None -> mutual_fix (Pfedit.get_current_proof_name ()) n []
+  | Some id -> mutual_fix id n []
+
+(* Refine as a cofixpoint *)
+let mutual_cofix = Tacmach.mutual_cofix
+
+let cofix = function
+  | None -> mutual_cofix (Pfedit.get_current_proof_name ()) []
+  | Some id -> mutual_cofix id []
+
+(**************************************************************)
+(*          Reduction and conversion tactics                  *)
+(**************************************************************)
+
+type tactic_reduction = env -> evar_map -> constr -> constr
+
+(* The following two tactics apply an arbitrary
+   reduction function either to the conclusion or to a 
+   certain hypothesis *)
+
+let reduct_in_concl redfun gl = 
+  convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) gl
+
+let reduct_in_hyp redfun (id,_,(where,where')) gl =
+  let (_,c, ty) = pf_get_hyp gl id in
+  let redfun' = (*under_casts*) (pf_reduce redfun gl) in
+  match c with
+  | None -> 
+      if where = InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value");
+      if Options.do_translate () then where' := Some where;
+      convert_hyp_no_check (id,None,redfun' ty) gl
+  | Some b ->
+      let where =
+	if !Options.v7 & where = InHyp then InHypValueOnly else where in
+      let b' = if where <> InHypTypeOnly then redfun' b else b in
+      let ty' =	if where <> InHypValueOnly then redfun' ty else ty in
+      if Options.do_translate () then where' := Some where;
+      convert_hyp_no_check (id,Some b',ty') gl
+
+let reduct_option redfun = function
+  | Some id -> reduct_in_hyp   redfun id 
+  | None    -> reduct_in_concl redfun 
+
+(* The following tactic determines whether the reduction
+   function has to be applied to the conclusion or
+   to the hypotheses. *) 
+
+let redin_combinator redfun =
+  onClauses (reduct_option redfun)
+
+(* Now we introduce different instances of the previous tacticals *)
+let change_and_check cv_pb t env sigma c =
+  if is_fconv cv_pb env sigma t c then 
+    t
+  else 
+    errorlabstrm "convert-check-hyp" (str "Not convertible")
+
+(* Use cumulutavity only if changing the conclusion not a subterm *)
+let change_on_subterm cv_pb t = function
+  | None -> change_and_check cv_pb t
+  | Some occl -> contextually false occl (change_and_check CONV t) 
+
+let change_in_concl occl t = reduct_in_concl (change_on_subterm CUMUL t occl) 
+let change_in_hyp occl t   = reduct_in_hyp (change_on_subterm CONV t occl)
+
+let change_option occl t = function
+    Some id -> change_in_hyp occl t id
+  | None -> change_in_concl occl t
+
+let change occl c cls =
+  (match cls, occl with
+      ({onhyps=(Some(_::_::_)|None)}|{onhyps=Some(_::_);onconcl=true}),
+      Some _ ->
+	error "No occurrences expected when changing several hypotheses"
+    | _ -> ());
+  onClauses (change_option occl c) cls
+
+(* Pour usage interne (le niveau User est pris en compte par reduce) *)
+let red_in_concl        = reduct_in_concl red_product
+let red_in_hyp          = reduct_in_hyp   red_product
+let red_option          = reduct_option   red_product
+let hnf_in_concl        = reduct_in_concl hnf_constr
+let hnf_in_hyp          = reduct_in_hyp   hnf_constr
+let hnf_option          = reduct_option   hnf_constr
+let simpl_in_concl      = reduct_in_concl nf
+let simpl_in_hyp        = reduct_in_hyp   nf
+let simpl_option        = reduct_option   nf
+let normalise_in_concl  = reduct_in_concl compute
+let normalise_in_hyp    = reduct_in_hyp   compute
+let normalise_option    = reduct_option   compute
+let unfold_in_concl loccname   = reduct_in_concl (unfoldn loccname) 
+let unfold_in_hyp   loccname   = reduct_in_hyp   (unfoldn loccname) 
+let unfold_option   loccname   = reduct_option   (unfoldn loccname) 
+let pattern_option l = reduct_option (pattern_occs l)
+
+(* A function which reduces accordingly to a reduction expression,
+   as the command Eval does. *)
+
+let reduce redexp cl goal =
+  redin_combinator (reduction_of_redexp redexp) cl goal
+
+(* Unfolding occurrences of a constant *)
+
+let unfold_constr = function 
+  | ConstRef sp -> unfold_in_concl [[],EvalConstRef sp]
+  | VarRef id -> unfold_in_concl [[],EvalVarRef id]
+  | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
+
+(*******************************************)
+(*         Introduction tactics            *)
+(*******************************************)
+
+let fresh_id avoid id gl =
+  next_global_ident_away true id (avoid@(pf_ids_of_hyps gl))
+
+let id_of_name_with_default s = function
+  | Anonymous -> id_of_string s
+  | Name id   -> id
+
+let default_id gl = function
+  | (name,None,t) ->
+      (match kind_of_term (pf_whd_betadeltaiota gl (pf_type_of gl t)) with
+	| Sort (Prop _) -> (id_of_name_with_default "H" name)
+	| Sort (Type _) -> (id_of_name_with_default "X" name)
+	| _                   -> anomaly "Wrong sort")
+  | (name,Some b,_) -> id_of_name_using_hdchar (pf_env gl) b name
+
+(* Non primitive introduction tactics are treated by central_intro
+   There is possibly renaming, with possibly names to avoid and 
+   possibly a move to do after the introduction *)
+
+type intro_name_flag =
+  | IntroAvoid of identifier list
+  | IntroBasedOn of identifier * identifier list
+  | IntroMustBe of identifier
+
+let find_name decl gl = function
+  | IntroAvoid idl        -> 
+      let id = fresh_id idl (default_id gl decl) gl in id
+  | IntroBasedOn (id,idl) -> fresh_id idl id gl
+  | IntroMustBe id        -> 
+      let id' = fresh_id [] id gl in
+      if id' <> id then error ((string_of_id id)^" is already used");
+      id'
+
+let build_intro_tac id = function
+  | None      -> introduction id
+  | Some dest -> tclTHEN (introduction id) (move_hyp true id dest)
+
+let rec intro_gen name_flag move_flag force_flag gl =
+  match kind_of_term (pf_concl gl) with
+    | Prod (name,t,_) -> 
+	build_intro_tac (find_name (name,None,t) gl name_flag) move_flag gl
+    | LetIn (name,b,t,_) ->
+	build_intro_tac (find_name (name,Some b,t) gl name_flag) move_flag gl
+    | _ -> 
+	if not force_flag then raise (RefinerError IntroNeedsProduct);
+	try
+	  tclTHEN
+	    (reduce (Red true) onConcl)
+	    (intro_gen name_flag move_flag force_flag) gl
+	with Redelimination ->
+	  errorlabstrm "Intro" (str "No product even after head-reduction")
+
+let intro_mustbe_force id = intro_gen (IntroMustBe id) None true
+let intro_using id = intro_gen (IntroBasedOn (id,[])) None false
+let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag
+let intro = intro_force false
+let introf = intro_force true
+
+let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true
+
+(* For backwards compatibility *)
+let central_intro = intro_gen
+
+(**** Multiple introduction tactics ****)
+
+let rec intros_using = function
+    []      -> tclIDTAC
+   | str::l  -> tclTHEN (intro_using str) (intros_using l)
+
+let intros = tclREPEAT (intro_force false)
+
+let intro_erasing id = tclTHEN (thin [id]) (intro_using id)
+
+let intros_replacing ids gls = 
+  let rec introrec = function
+    | [] -> tclIDTAC
+    | id::tl ->
+	(tclTHEN (tclORELSE (intro_replacing id)
+		    (tclORELSE (intro_erasing id)   (* ?? *)
+                       (intro_using id)))
+           (introrec tl))
+  in 
+  introrec ids gls
+
+(* User-level introduction tactics *)
+
+let intro_move idopt idopt' = match idopt with
+  | None -> intro_gen (IntroAvoid []) idopt' true
+  | Some id -> intro_gen (IntroMustBe id) idopt' true
+
+let pf_lookup_hypothesis_as_renamed env ccl = function
+  | AnonHyp n -> pf_lookup_index_as_renamed env ccl n
+  | NamedHyp id -> pf_lookup_name_as_renamed env ccl id
+
+let pf_lookup_hypothesis_as_renamed_gen red h gl =
+  let env = pf_env gl in
+  let rec aux ccl =
+    match pf_lookup_hypothesis_as_renamed env ccl h with
+      | None when red ->
+          aux (reduction_of_redexp (Red true) env (project gl) ccl)
+      | x -> x
+  in
+  try aux (pf_concl gl)
+  with Redelimination -> None
+
+let is_quantified_hypothesis id g =
+  match pf_lookup_hypothesis_as_renamed_gen true (NamedHyp id) g with
+    | Some _ -> true
+    | None -> false
+
+let msg_quantified_hypothesis = function
+  | NamedHyp id -> 
+      str "hypothesis " ++ pr_id id
+  | AnonHyp n ->
+      int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++
+      str " non dependent hypothesis"
+
+let depth_of_quantified_hypothesis red h gl =
+  match pf_lookup_hypothesis_as_renamed_gen red h gl with
+    | Some depth -> depth
+    | None ->
+        errorlabstrm "lookup_quantified_hypothesis" 
+          (str "No " ++ msg_quantified_hypothesis h ++
+	  str " in current goal" ++
+	  if red then str " even after head-reduction" else mt ())
+
+let intros_until_gen red h g =
+  tclDO (depth_of_quantified_hypothesis red h g) intro g
+
+let intros_until_id id = intros_until_gen true (NamedHyp id)
+let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
+
+let intros_until = intros_until_gen true
+let intros_until_n = intros_until_n_gen true
+let intros_until_n_wored = intros_until_n_gen false
+
+let try_intros_until tac = function
+  | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id)
+  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp tac)
+
+let rec intros_move = function
+  | [] -> tclIDTAC
+  | (hyp,destopt) :: rest ->
+      tclTHEN (intro_gen (IntroMustBe hyp) destopt false)
+	(intros_move rest)
+
+let dependent_in_decl a (_,c,t) =
+  match c with
+    | None -> dependent a t
+    | Some body -> dependent a body || dependent a t
+
+let move_to_rhyp rhyp gl =
+  let rec get_lhyp lastfixed depdecls = function
+    | [] ->
+	(match rhyp with
+	   | None -> lastfixed
+      	   | Some h -> anomaly ("Hypothesis should occur: "^ (string_of_id h)))
+    | (hyp,c,typ) as ht :: rest ->
+	if Some hyp = rhyp then 
+	  lastfixed
+	else if List.exists (occur_var_in_decl (pf_env gl) hyp) depdecls then 
+	  get_lhyp lastfixed (ht::depdecls) rest
+        else
+	  get_lhyp (Some hyp) depdecls rest
+  in
+  let sign = pf_hyps gl in
+  let (hyp,c,typ as decl) = List.hd sign in
+  match get_lhyp None [decl] (List.tl sign) with
+    | None -> tclIDTAC gl
+    | Some hypto -> move_hyp true hyp hypto gl
+
+let rec intros_rmove = function
+  | [] -> tclIDTAC
+  | (hyp,destopt) :: rest ->
+      tclTHENLIST [ introduction hyp;
+ 		    move_to_rhyp destopt;
+		    intros_rmove rest ]
+
+(****************************************************)
+(*            Resolution tactics                    *)
+(****************************************************)
+
+(*  Refinement tactic: unification with the head of the head normal form
+ *  of the type of a term. *)
+
+let apply_type hdcty argl gl =
+  refine (applist (mkCast (mkMeta (new_meta()),hdcty),argl)) gl
+    
+let apply_term hdc argl gl =
+  refine (applist (hdc,argl)) gl
+
+let bring_hyps hyps = 
+  if hyps = [] then Refiner.tclIDTAC
+  else
+    (fun gl ->
+      let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in
+      let f = mkCast (mkMeta (new_meta()),newcl) in
+      refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
+
+(* Resolution with missing arguments *)
+
+let apply_with_bindings (c,lbind) gl = 
+  let apply = 
+    match kind_of_term c with 
+      | Lambda _ -> res_pf_cast 
+      | _ -> res_pf 
+  in 
+  let (wc,kONT) = startWalk gl in
+  (* The actual type of the theorem. It will be matched against the
+  goal. If this fails, then the head constant will be unfolded step by
+  step. *)
+  let thm_ty0 = nf_betaiota (w_type_of wc c) in
+  let rec try_apply thm_ty =
+    try
+      let n = nb_prod thm_ty - nb_prod (pf_concl gl) in
+      if n<0 then error "Apply: theorem has not enough premisses.";
+      let clause = make_clenv_binding_apply wc n (c,thm_ty) lbind in
+      apply kONT clause gl
+    with (RefinerError _|UserError _|Failure _) as exn ->
+      let red_thm =
+        try red_product (w_env wc) (w_Underlying wc) thm_ty
+        with (Redelimination | UserError _) -> raise exn in
+      try_apply red_thm in
+  try try_apply thm_ty0
+  with (RefinerError _|UserError _|Failure _) ->
+    (* Last chance: if the head is a variable, apply may try
+       second order unification *)
+    let clause = make_clenv_binding_apply wc (-1) (c,thm_ty0) lbind in 
+    apply kONT clause gl
+
+let apply c = apply_with_bindings (c,NoBindings)
+
+let apply_list = function 
+  | c::l -> apply_with_bindings (c,ImplicitBindings l)
+  | _ -> assert false
+
+(* Resolution with no reduction on the type *)
+
+let apply_without_reduce c gl = 
+  let (wc,kONT) = startWalk gl in
+  let clause = mk_clenv_type_of wc c in 
+  res_pf kONT clause gl
+
+(* A useful resolution tactic which, if c:A->B, transforms |- C into
+   |- B -> C and |- A
+
+   -------------------
+   Gamma |- c : A -> B      Gamma |- ?2 : A
+   ----------------------------------------
+           Gamma |- B                        Gamma |- ?1 : B -> C
+           -----------------------------------------------------
+                             Gamma |- ? : C
+
+ Ltac lapply c :=
+  let ty := check c in
+  match eval hnf in ty with
+    ?A -> ?B => cut B; [ idtac | apply c ]
+  end.
+*)
+
+let cut_and_apply c gl =
+  let goal_constr = pf_concl gl in 
+  match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
+    | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
+	tclTHENLAST
+	  (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())])
+	  (apply_term c [mkMeta (new_meta())]) gl
+    | _ -> error "Imp_elim needs a non-dependent product"
+
+(**************************)
+(*     Cut tactics        *)
+(**************************)
+
+let assert_tac first na c gl =
+  match kind_of_term (hnf_type_of gl c) with
+    | Sort s -> 
+	let id = match na with
+	  | Anonymous -> 
+              let d = match s with Prop _ -> "H" | Type _ -> "X" in
+              fresh_id [] (id_of_string d) gl
+	  | Name id -> id
+	in
+	(if first then internal_cut else internal_cut_rev) id c gl
+    | _  -> error "Not a proposition or a type"
+
+let true_cut = assert_tac true
+
+let cut c gl =
+  match kind_of_term (hnf_type_of gl c) with
+    | Sort _ ->
+        let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+        let t = mkProd (Anonymous, c, pf_concl gl) in
+        tclTHENFIRST
+          (internal_cut_rev id c)
+          (tclTHEN (apply_type t [mkVar id]) (thin [id]))
+          gl
+    | _  -> error "Not a proposition or a type"
+
+let cut_intro t = tclTHENFIRST (cut t) intro
+		    
+let cut_replacing id t = 
+  tclTHENFIRST
+    (cut t)
+    (tclORELSE
+      (intro_replacing id) 
+      (tclORELSE (intro_erasing id) 
+        (intro_using id)))
+
+let cut_in_parallel l = 
+  let rec prec = function
+    | [] -> tclIDTAC 
+    | h::t -> tclTHENFIRST (cut h) (prec t)
+  in 
+  prec (List.rev l)
+
+(**************************)
+(*   Generalize tactics   *)
+(**************************)
+
+let generalize_goal gl c cl =
+  let t = pf_type_of gl c in
+  match kind_of_term c with
+    | Var id ->
+	(* The choice of remembering or not a non dependent name has an impact
+	   on the future Intro naming strategy! *)
+	(* if dependent c cl then mkNamedProd id t cl
+	   else mkProd (Anonymous,t,cl) *)
+	mkNamedProd id t cl
+    | _        -> 
+        let cl' = subst_term c cl in
+        if noccurn 1 cl' then 
+	  mkProd (Anonymous,t,cl)
+          (* On ne se casse pas la tete : on prend pour nom de variable
+             la premiere lettre du type, meme si "ci" est une
+             constante et qu'on pourrait prendre directement son nom *)
+        else 
+	  prod_name (Global.env()) (Anonymous, t, cl')
+
+let generalize_dep c gl =
+  let env = pf_env gl in
+  let sign = pf_hyps gl in
+  let init_ids = ids_of_named_context (Global.named_context()) in
+  let rec seek d toquant =
+    if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
+      or dependent_in_decl c d then 
+      d::toquant
+    else 
+      toquant in
+  let to_quantify = Sign.fold_named_context seek sign ~init:[] in
+  let to_quantify_rev = List.rev to_quantify in
+  let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in
+  let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in
+  let tothin' =
+    match kind_of_term c with
+      | Var id when mem_named_context id sign & not (List.mem id init_ids)
+	  -> id::tothin
+      | _ -> tothin
+  in
+  let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
+  let cl'' = generalize_goal gl c cl' in
+  let args = Array.to_list (instance_from_named_context to_quantify_rev) in
+  tclTHEN
+    (apply_type cl'' (c::args))
+    (thin (List.rev tothin'))
+    gl
+    
+let generalize lconstr gl = 
+  let newcl = List.fold_right (generalize_goal gl) lconstr (pf_concl gl) in
+  apply_type newcl lconstr gl
+
+(* Faudra-t-il une version avec plusieurs args de generalize_dep ?
+Cela peut-être troublant de faire "Generalize Dependent H n" dans
+"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la
+généralisation dépendante par n.
+
+let quantify lconstr =
+ List.fold_right 
+   (fun com tac -> tclTHEN tac (tactic_com generalize_dep c))
+   lconstr
+   tclIDTAC
+*)
+
+(* A dependent cut rule à la sequent calculus
+   ------------------------------------------
+   Sera simplifiable le jour où il y aura un let in primitif dans constr
+
+   [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
+   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
+   [...x:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
+   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
+
+   [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted;
+   if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted
+   wherever it occurs, otherwise [c] is substituted only in hyps
+   present in [occ_hyps] at the specified occurrences (everywhere if
+   the list of occurrences is empty), and in the goal at the specified
+   occurrences if [occ_goal] is not [None];
+
+   if name = Anonymous, the name is build from the first letter of the type;
+
+   The tactic first quantify the goal over x1, x2,... then substitute then
+   re-intro x1, x2,... at their initial place ([marks] is internally
+   used to remember the place of x1, x2, ...: it is the list of hypotheses on
+   the left of each x1, ...).
+*)
+
+
+
+let occurrences_of_hyp id cls =
+  let rec hyp_occ = function
+      [] -> None
+    | (id',occs,hl)::_ when id=id' -> Some occs
+    | _::l -> hyp_occ l in
+  match cls.onhyps with
+      None -> Some []
+    | Some l -> hyp_occ l
+
+let occurrences_of_goal cls =
+  if cls.onconcl then Some cls.concl_occs else None
+
+let everywhere cls = (cls=allClauses)
+
+(*
+(* Implementation with generalisation then re-intro: introduces noise *)
+(* in proofs *)
+
+let letin_abstract id c occs gl =
+  let env = pf_env gl in
+  let compute_dependency _ (hyp,_,_ as d) ctxt =
+    let d' =
+      try
+	match occurrences_of_hyp hyp occs with
+	  | None -> raise Not_found
+	  | Some occ ->
+              let newdecl = subst_term_occ_decl occ c d in
+              if d = newdecl then
+		if not (everywhere occs)
+		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+		else raise Not_found
+              else 
+		(subst1_decl (mkVar id) newdecl, true)
+	with Not_found -> 
+	  (d,List.exists
+	      (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt)
+    in d'::ctxt
+  in 
+  let ctxt' = fold_named_context compute_dependency env ~init:[] in
+  let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) =
+    if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp)
+    else (accu, Some hyp) in
+  let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in
+  let ccl = match occurrences_of_goal occs with
+    | None -> pf_concl gl
+    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl))
+  in
+  (depdecls,marks,ccl)
+
+let letin_tac with_eq name c occs gl =
+  let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+  let id =
+    if name = Anonymous then fresh_id [] x gl else
+      if not (mem_named_context x (pf_hyps gl)) then x else
+	error ("The variable "^(string_of_id x)^" is already declared") in
+  let (depdecls,marks,ccl)= letin_abstract id c occs gl in 
+  let t = pf_type_of gl c in
+  let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in
+  let args = Array.to_list (instance_from_named_context depdecls) in
+  let newcl = mkNamedLetIn id c t tmpcl in
+  let lastlhyp = if marks=[] then None else snd (List.hd marks) in
+  tclTHENLIST
+    [ apply_type newcl args;
+      thin (List.map (fun (id,_,_) -> id) depdecls);
+      intro_gen (IntroMustBe id) lastlhyp false;
+      if with_eq then tclIDTAC else thin_body [id];
+      intros_move marks ] gl
+*)
+
+(* Implementation without generalisation: abbrev will be lost in hyps in *)
+(* in the extracted proof *)
+
+let letin_abstract id c occs gl =
+  let env = pf_env gl in
+  let compute_dependency _ (hyp,_,_ as d) depdecls =
+    match occurrences_of_hyp hyp occs with
+      | None -> depdecls
+      | Some occ ->
+          let newdecl = subst_term_occ_decl occ c d in
+          if d = newdecl then
+	    if not (everywhere occs)
+	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+	    else depdecls
+          else 
+	    (subst1_decl (mkVar id) newdecl)::depdecls in 
+  let depdecls = fold_named_context compute_dependency env ~init:[] in
+  let ccl = match occurrences_of_goal occs with
+    | None -> pf_concl gl
+    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in
+  let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in
+  (depdecls,lastlhyp,ccl)
+
+let letin_tac with_eq name c occs gl =
+  let id =
+    let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+    if name = Anonymous then fresh_id [] x gl else
+      if not (mem_named_context x (pf_hyps gl)) then x else
+	error ("The variable "^(string_of_id x)^" is already declared") in
+  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in 
+  let t = pf_type_of gl c in
+  let newcl = mkNamedLetIn id c t ccl in
+  tclTHENLIST
+    [ convert_concl_no_check newcl;
+      intro_gen (IntroMustBe id) lastlhyp true;
+      if with_eq then tclIDTAC else thin_body [id];
+      tclMAP convert_hyp_no_check depdecls ] gl
+  
+let check_hypotheses_occurrences_list env (_,occl) =
+  let rec check acc = function
+    | (hyp,_) :: rest -> 
+	if List.mem hyp acc then
+	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice");
+	if not (mem_named_context hyp (named_context env)) then
+	  error ("No such hypothesis: " ^ (string_of_id hyp));
+	check (hyp::acc) rest
+    | [] -> ()
+  in check [] occl
+
+let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]}
+
+(* Tactic Assert (b=false) and Pose (b=true):
+   the behaviour of Pose is corrected by the translator.
+   not that of Assert *)
+let forward b na c =
+  let wh =  if !Options.v7 && b then onConcl else nowhere in
+  letin_tac b na c wh
+
+(********************************************************************)
+(*               Exact tactics                                      *)
+(********************************************************************)
+
+let exact_check c gl =
+  let concl = (pf_concl gl) in
+  let ct = pf_type_of gl c in
+  if pf_conv_x_leq gl ct concl then  
+    refine_no_check c gl 
+  else 
+    error "Not an exact proof"
+
+let exact_no_check = refine_no_check
+
+let exact_proof c gl =
+  (* on experimente la synthese d'ise dans exact *)
+  let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
+  in refine_no_check c gl 
+
+let (assumption : tactic) = fun gl ->
+  let concl =  pf_concl gl in 
+  let hyps = pf_hyps gl in
+  let rec arec only_eq = function
+    | [] -> 
+        if only_eq then arec false hyps else error "No such assumption"
+    | (id,c,t)::rest -> 
+	if (only_eq & eq_constr t concl) 
+          or (not only_eq & pf_conv_x_leq gl t concl)
+        then refine_no_check (mkVar id) gl
+	else arec only_eq rest
+  in
+  arec true hyps
+
+(*****************************************************************)
+(*          Modification of a local context                      *)
+(*****************************************************************)
+
+(* This tactic enables the user to remove hypotheses from the signature.
+ * Some care is taken to prevent him from removing variables that are 
+ * subsequently used in other hypotheses or in the conclusion of the  
+ * goal. *)                                                               
+
+let clear ids gl = (* avant seul dyn_clear n'echouait pas en [] *)
+  if ids=[] then tclIDTAC gl else with_check (thin ids) gl
+
+let clear_body = thin_body
+
+(*   Takes a list of booleans, and introduces all the variables 
+ *  quantified in the goal which are associated with a value
+ *  true  in the boolean list. *)
+
+let rec intros_clearing = function
+  | []          -> tclIDTAC
+  | (false::tl) -> tclTHEN intro (intros_clearing tl)
+  | (true::tl)  ->
+      tclTHENLIST
+        [ intro; onLastHyp (fun id -> clear [id]); intros_clearing tl]
+
+(* Adding new hypotheses  *)
+
+let new_hyp mopt (c,lbind) g =
+  let (wc,kONT) = startWalk g in
+  let clause  = make_clenv_binding wc (c,w_type_of wc c) lbind in
+  let (thd,tstack) = whd_stack (clenv_instance_template clause) in
+  let nargs = List.length tstack in
+  let cut_pf = 
+    applist(thd, 
+            match mopt with
+	      | Some m -> if m < nargs then list_firstn m tstack else tstack
+	      | None   -> tstack)
+  in 
+  (tclTHENLAST (tclTHEN (kONT clause.hook)
+               (cut (pf_type_of g cut_pf)))
+     ((tclORELSE (apply cut_pf) (exact_no_check cut_pf)))) g
+
+(************************)
+(* Introduction tactics *)
+(************************)
+
+let constructor_tac boundopt i lbind gl =
+  let cl = pf_concl gl in 
+  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in 
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames
+  and sigma   = project gl in
+  if i=0 then error "The constructors are numbered starting from 1";
+  if i > nconstr then error "Not enough constructors";
+  begin match boundopt with 
+    | Some expctdnum -> 
+        if expctdnum <> nconstr then 
+	  error "Not the expected number of constructors"
+    | None -> ()
+  end;
+  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
+  let apply_tac = apply_with_bindings (cons,lbind) in
+  (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl
+
+let one_constructor i = constructor_tac None i
+
+(* Try to apply the constructor of the inductive definition followed by 
+   a tactic t given as an argument.
+   Should be generalize in Constructor (Fun c : I -> tactic)
+ *)
+
+let any_constructor tacopt gl =
+  let t = match tacopt with None -> tclIDTAC | Some t -> t in
+  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
+  if nconstr = 0 then error "The type has no constructors";
+  tclFIRST (List.map (fun i -> tclTHEN (one_constructor i NoBindings) t) 
+              (interval 1 nconstr)) gl
+
+let left           = constructor_tac (Some 2) 1
+let simplest_left  = left NoBindings
+
+let right          = constructor_tac (Some 2) 2
+let simplest_right = right NoBindings
+
+let split          = constructor_tac (Some 1) 1
+let simplest_split = split NoBindings
+
+(********************************************)
+(*       Elimination tactics                *)
+(********************************************)
+
+
+(* kONT : ??
+ * wc : ??
+ * elimclause : ??
+ * inclause : ??
+ * gl : the current goal
+*)
+
+let last_arg c = match kind_of_term c with
+  | App (f,cl) ->  array_last cl
+  | _ -> anomaly "last_arg"
+	
+let elimination_clause_scheme kONT elimclause indclause allow_K gl = 
+  let indmv = 
+    (match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+       | Meta mv -> mv
+       | _  -> errorlabstrm "elimination_clause"
+             (str "The type of elimination clause is not well-formed")) 
+  in
+  let elimclause' = clenv_fchain indmv elimclause indclause in 
+  elim_res_pf kONT elimclause' allow_K gl
+
+(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and 
+ * refine fails *)
+
+let type_clenv_binding wc (c,t) lbind = 
+  clenv_instance_template_type (make_clenv_binding wc (c,t) lbind)
+
+(* 
+ * Elimination tactic with bindings and using an arbitrary 
+ * elimination constant called elimc. This constant should end 
+ * with a clause (x:I)(P .. ), where P is a bound variable.
+ * The term c is of type t, which is a product ending with a type 
+ * matching I, lbindc are the expected terms for c arguments 
+ *)
+
+let general_elim (c,lbindc) (elimc,lbindelimc) ?(allow_K=true) gl = 
+  let (wc,kONT)  = startWalk gl in
+  let ct = pf_type_of gl c in
+  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
+  let indclause  = make_clenv_binding wc (c,t) lbindc  in
+  let elimt      = w_type_of wc elimc in
+  let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in 
+  elimination_clause_scheme kONT elimclause indclause allow_K gl
+
+(* Elimination tactic with bindings but using the default elimination 
+ * constant associated with the type. *)
+
+let find_eliminator c gl =
+  let env = pf_env gl in
+  let (ind,t) = reduce_to_quantified_ind env (project gl) (pf_type_of gl c) in
+  let s = elimination_sort_of_goal gl in
+    Indrec.lookup_eliminator ind s 
+(*  with Not_found -> 
+    let dir, base = repr_path (path_of_inductive env ind) in
+    let id = Indrec.make_elimination_ident base s in
+    errorlabstrm "default_elim"
+      (str "Cannot find the elimination combinator :" ++
+         pr_id id ++ spc () ++
+	 str "The elimination of the inductive definition :" ++
+         pr_id base ++ spc () ++ str "on sort " ++
+         spc () ++ print_sort (new_sort_in_family s) ++
+	 str " is probably not allowed")
+(* lookup_eliminator prints the message *) *)
+let default_elim (c,lbindc) gl = 
+  general_elim (c,lbindc) (find_eliminator c gl,NoBindings) gl
+
+let elim_in_context (c,_ as cx) elim gl =
+  match elim with
+  | Some (elimc,lbindelimc) -> general_elim cx (elimc,lbindelimc) gl
+  | None -> general_elim cx (find_eliminator c gl,NoBindings) gl 
+
+let elim (c,lbindc as cx) elim =
+  match kind_of_term c with
+    | Var id when lbindc = NoBindings ->
+	tclTHEN (tclTRY (intros_until_id id)) (elim_in_context cx elim)
+    | _ -> elim_in_context cx elim
+
+(* The simplest elimination tactic, with no substitutions at all. *)
+
+let simplest_elim c = default_elim (c,NoBindings)
+
+(* Elimination in hypothesis *)
+
+let elimination_in_clause_scheme kONT id elimclause indclause =
+  let (hypmv,indmv) = 
+    match clenv_independent elimclause with
+        [k1;k2] -> (k1,k2)
+      | _  -> errorlabstrm "elimination_clause"
+          (str "The type of elimination clause is not well-formed") in
+  let elimclause'  = clenv_fchain indmv elimclause indclause in 
+  let hyp = mkVar id in
+  let hyp_typ = clenv_type_of elimclause' hyp in
+  let hypclause =
+    mk_clenv_from_n elimclause'.hook (Some 0) (hyp, hyp_typ) in
+  let elimclause'' = clenv_fchain hypmv elimclause' hypclause in  
+  let new_hyp_prf  = clenv_instance_template elimclause'' in
+  let new_hyp_typ  = clenv_instance_template_type elimclause'' in
+  if eq_constr hyp_typ new_hyp_typ then
+    errorlabstrm "general_rewrite_in" 
+      (str "Nothing to rewrite in " ++ pr_id id);
+  tclTHEN
+    (kONT elimclause''.hook)
+    (tclTHENS
+      (cut new_hyp_typ)
+      [ (* Try to insert the new hyp at the same place *)
+        tclORELSE (intro_replacing id)
+          (tclTHEN (clear [id]) (introduction id));
+        refine_no_check new_hyp_prf])
+
+let general_elim_in id (c,lbindc) (elimc,lbindelimc) gl = 
+  let (wc,kONT)  = startWalk gl in
+  let ct = pf_type_of gl c in
+  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
+  let indclause  = make_clenv_binding wc (c,t) lbindc  in
+  let elimt      = w_type_of wc elimc in
+  let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in 
+  elimination_in_clause_scheme kONT id elimclause indclause gl
+
+(* Case analysis tactics *)
+
+let general_case_analysis_in_context (c,lbindc) gl =
+  let env = pf_env gl in
+  let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma    = project gl in 
+  let sort     = elimination_sort_of_goal gl in
+  let case = if occur_term c (pf_concl gl) then Indrec.make_case_dep
+  else Indrec.make_case_gen in
+  let elim     = case env sigma mind sort in 
+  general_elim (c,lbindc) (elim,NoBindings) gl
+
+let general_case_analysis (c,lbindc as cx) =
+  match kind_of_term c with
+    | Var id when lbindc = NoBindings ->
+	tclTHEN (tclTRY (intros_until_id id))
+	(general_case_analysis_in_context cx)
+    | _ ->
+	general_case_analysis_in_context cx
+
+let simplest_case c = general_case_analysis (c,NoBindings)
+
+(*****************************)
+(* Decomposing introductions *)
+(*****************************)
+
+let clear_last = tclLAST_HYP (fun c -> (clear [destVar c]))
+let case_last  = tclLAST_HYP simplest_case
+
+let rec intro_pattern destopt = function
+  | IntroWildcard ->
+      tclTHEN intro clear_last
+  | IntroIdentifier id ->
+      intro_gen (IntroMustBe id) destopt true
+  | IntroOrAndPattern l ->
+      tclTHEN introf
+        (tclTHENS
+	  (tclTHEN case_last clear_last)
+	  (List.map (intros_pattern destopt) l))
+
+and intros_pattern destopt l = tclMAP (intro_pattern destopt) l
+
+let intro_patterns = function 
+  | [] -> tclREPEAT intro
+  | l  -> intros_pattern None l
+
+(*
+ * A "natural" induction tactic
+ * 
+  - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal
+  - [hyp0] is the induction hypothesis
+  - we extract from [args] the variables which are not rigid parameters
+    of the inductive type, this is [indvars] (other terms are forgotten);
+    [indhyps] are the ones which actually are declared in context
+    (done in [find_atomic_param_of_ind])
+  - we look for all hyps depending of [hyp0] or one of [indvars]:
+    this is [dephyps] of types [deptyps] respectively
+  - [statuslist] tells for each hyps in [dephyps] after which other hyp
+    fixed in the context they must be moved (when induction is done)
+  - [hyp0succ] is the name of the hyp fixed in the context after which to
+    move the subterms of [hyp0succ] in the i-th branch where it is supposed
+    to be the i-th constructor of the inductive type.
+
+  Strategy: (cf in [induction_from_context])
+  - requantify and clear all [dephyps]
+  - apply induction on [hyp0]
+  - clear [indhyps] and [hyp0]
+  - in the i-th subgoal, intro the arguments of the i-th constructor
+    of the inductive type after [hyp0succ] (done in
+    [induct_discharge]) let the induction hypotheses on top of the
+    hyps because they may depend on variables between [hyp0] and the
+    top. A counterpart is that the dep hyps programmed to be intro-ed
+    on top must now be intro-ed after the induction hypotheses
+  - move each of [dephyps] at the right place following the
+    [statuslist]
+
+ *)
+
+let rec str_intro_pattern = function
+  | IntroOrAndPattern pll ->
+      "["^(String.concat "|" 
+	(List.map 
+	  (fun pl -> String.concat " " (List.map str_intro_pattern pl)) pll))
+      ^"]"
+  | IntroWildcard -> "_"
+  | IntroIdentifier id -> string_of_id id
+
+let check_unused_names names =
+  if names <> [] & Options.is_verbose () then
+    let s = if List.tl names = [] then " " else "s " in
+    let names = String.concat " " (List.map str_intro_pattern names) in
+    warning ("Unused introduction pattern"^s^": "^names)
+
+let rec first_name_buggy = function
+  | IntroOrAndPattern [] -> None
+  | IntroOrAndPattern ([]::l) -> first_name_buggy (IntroOrAndPattern l)
+  | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p
+  | IntroWildcard -> None
+  | IntroIdentifier id -> Some id
+
+type elim_arg_kind = RecArg | IndArg | OtherArg
+
+let induct_discharge statuslists destopt avoid' ((avoid7,avoid8),ra) (names,force,rnames) gl =
+  let avoid7 = avoid7 @ avoid' in
+  let avoid8 = avoid8 @ avoid' in
+  let (lstatus,rstatus) = statuslists in
+  let tophyp = ref None in
+  let rec peel_tac ra names gl = match ra with
+    | (RecArg,(recvarname7,recvarname8)) ::
+        (IndArg,(hyprecname7,hyprecname8)) :: ra' ->
+        let recpat,hyprec,names = match names with
+          | [] ->
+              let idrec7 = (fresh_id avoid7 recvarname7 gl) in
+              let idrec8 = (fresh_id avoid8 recvarname8 gl) in
+              let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in
+              let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in
+ 	      if Options.do_translate() &
+                (idrec7 <> idrec8 or idhyp7 <> idhyp8)
+	      then force := true;
+              let idrec = if !Options.v7 then idrec7 else idrec8 in
+              let idhyp = if !Options.v7 then idhyp7 else idhyp8 in
+              (IntroIdentifier idrec, IntroIdentifier idhyp, [])
+          | [IntroIdentifier id as pat] ->
+              let id7 = next_ident_away (add_prefix "IH" id) avoid7 in
+              let id8 = next_ident_away (add_prefix "IH" id) avoid8 in
+ 	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+	      (pat, IntroIdentifier id, [])
+	  | [pat] ->
+              let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in
+              let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in
+ 	      if Options.do_translate() & idhyp7 <> idhyp8 then force := true;
+              let idhyp = if !Options.v7 then idhyp7 else idhyp8 in
+	      (pat, IntroIdentifier idhyp, [])
+          | pat1::pat2::names -> (pat1,pat2,names) in
+	(* This is buggy for intro-or-patterns with different first hypnames *)
+	if !tophyp=None then tophyp := first_name_buggy hyprec;
+	rnames := !rnames @ [recpat; hyprec];
+        tclTHENLIST
+	  [ intros_pattern destopt [recpat];
+	    intros_pattern None [hyprec];
+	    peel_tac ra' names ] gl
+    | (IndArg,(hyprecname7,hyprecname8)) :: ra' ->
+	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
+        let pat,names = match names with
+          | [] -> IntroIdentifier (fresh_id avoid8 hyprecname8 gl), []
+	  | pat::names -> pat,names in
+	rnames := !rnames @ [pat];
+	tclTHEN (intros_pattern destopt [pat]) (peel_tac ra' names) gl
+    | (RecArg,(recvarname7,recvarname8)) :: ra' ->
+        let introtac,names = match names with
+          | [] -> 
+              let id8 = fresh_id avoid8 recvarname8 gl in
+	      let i =
+                if !Options.v7 then IntroAvoid avoid7 else IntroMustBe id8
+	      in
+	      (* For translator *)
+	      let id7 = fresh_id avoid7 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+	      rnames := !rnames @ [IntroIdentifier id];
+	      intro_gen i destopt false, []
+          | pat::names ->
+	      rnames := !rnames @ [pat];
+	      intros_pattern destopt [pat],names in
+	tclTHEN introtac (peel_tac ra' names) gl
+    | (OtherArg,_) :: ra' ->
+        let introtac,names = match names with
+          | [] -> 
+	      (* For translator *)
+	      let id7 = fresh_id avoid7 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      let id8 = fresh_id avoid8 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+              let avoid = if !Options.v7 then avoid7 else avoid8 in
+	      rnames := !rnames @ [IntroIdentifier id];
+	      intro_gen (IntroAvoid avoid) destopt false, []
+          | pat::names ->
+	      rnames := !rnames @ [pat];
+	      intros_pattern destopt [pat],names in
+	tclTHEN introtac (peel_tac ra' names) gl
+    | [] ->
+        check_unused_names names;
+        tclIDTAC gl
+  in
+  let intros_move lstatus =
+    let newlstatus = (* if some IH has taken place at the top of hyps *)
+      List.map (function (hyp,None) -> (hyp,!tophyp) | x -> x) lstatus in
+    intros_move newlstatus
+  in 
+  tclTHENLIST [ peel_tac ra names;
+		intros_rmove rstatus;
+		intros_move lstatus ] gl
+
+(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
+     s'embêter à regarder si un letin_tac ne fait pas des
+     substitutions aussi sur l'argument voisin *)
+
+(* Marche pas... faut prendre en compte l'occurrence précise... *)
+
+let atomize_param_of_ind (indref,nparams) hyp0 gl =
+  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+  let prods, indtyp = decompose_prod typ0 in
+  let argl = snd (decompose_app indtyp) in
+  let params = list_firstn nparams argl in
+  (* le gl est important pour ne pas préévaluer *)
+  let rec atomize_one i avoid gl =
+    if i<>nparams then
+      let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+      (* If argl <> [], we expect typ0 not to be quantified, in order to
+         avoid bound parameters... then we call pf_reduce_to_atomic_ind *)
+      let indtyp = pf_apply reduce_to_atomic_ref gl indref tmptyp0 in
+      let argl = snd (decompose_app indtyp) in
+      let c = List.nth argl (i-1) in
+      match kind_of_term c with
+	| Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->
+	    atomize_one (i-1) ((mkVar id)::avoid) gl
+	| Var id ->
+	    let x = fresh_id [] id gl in
+	    tclTHEN
+	      (letin_tac true (Name x) (mkVar id) allClauses)
+	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+	| _ ->
+	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
+		       Anonymous in
+	    let x = fresh_id [] id gl in
+	    tclTHEN
+	      (letin_tac true (Name x) c allClauses)
+	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+    else 
+      tclIDTAC gl
+  in
+  atomize_one (List.length argl) params gl
+
+let find_atomic_param_of_ind nparams indtyp =
+  let argl = snd (decompose_app indtyp) in
+  let argv = Array.of_list argl in
+  let params = list_firstn nparams argl in
+  let indvars = ref Idset.empty in
+  for i = nparams to (Array.length argv)-1 do
+    match kind_of_term argv.(i) with
+      | Var id
+          when not (List.exists (occur_var (Global.env()) id) params) ->
+	  indvars := Idset.add id !indvars
+      | _ -> ()
+  done;
+  Idset.elements !indvars;
+  
+
+   (* [cook_sign] builds the lists [indhyps] of hyps that must be
+   erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
+   goal together with the places [(lstatus,rstatus)] where to re-intro
+   them after induction. To know where to re-intro the dep hyp, we
+   remember the name of the hypothesis [lhyp] after which (if the dep
+   hyp is more recent than [hyp0]) or [rhyp] before which (if older
+   than [hyp0]) its equivalent must be moved when the induction has
+   been applied. Since computation of dependencies and [rhyp] is from
+   more ancient (on the right) to more recent hyp (on the left) but
+   the computation of [lhyp] progresses from the other way, [cook_hyp]
+   is in two passes (an alternative would have been to write an
+   higher-order algorithm). We strongly use references to reduce
+   the accumulation of arguments.
+
+   To summarize, the situation looks like this
+
+   Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat
+                Left                                                    Right 
+
+   Induction hypothesis is H4 ([hyp0])
+   Variable parameters of (le O n) is the singleton list with "n" ([indvars])
+   Part of [indvars] really in context is the same ([indhyps])
+   The dependent hyps are H3 and H6 ([dephyps])
+   For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp])
+    because these names are among the hyp which are fixed through the induction
+   For H6 the neighbours are None ([lhyp]) and H5 ([rhyp])
+   For H3, because on the right of H4, we remember rhyp (here H2)
+   For H6, because on the left of H4, we remember lhyp (here None)
+   For H4, we remember lhyp (here H5)
+
+   The right neighbour is then translated into the left neighbour
+   because move_hyp tactic needs the name of the hyp _after_ which we
+   move the hyp to move.
+
+   But, say in the 2nd subgoal of the hypotheses, the goal will be
+
+   (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)->   (Q Sm)->   (Goal Sm)
+     ^^^^^^^^^^^^^^^^^^^^^^^^^^^       ^^^^
+         both go where H4 was       goes where  goes where
+                                      H3 was      H6 was
+
+   We have to intro and move m and the recursive hyp first, but then
+   where to move H3 ??? Only the hyp on its right is relevant, but we
+   have to translate it into the name of the hyp on the left
+
+   Note: this case where some hyp(s) in [dephyps] has(have) the same
+   left neighbour as [hyp0] is the only problematic case with right
+   neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2
+   would have posed no problem. But for uniformity, we decided to use
+   the right hyp for all hyps on the right of H4.
+
+   Others solutions are welcome *)
+
+exception Shunt of identifier option
+
+let cook_sign hyp0 indvars env =
+  (* First phase from L to R: get [indhyps], [decldep] and [statuslist]
+     for the hypotheses before (= more ancient than) hyp0 (see above) *)
+  let allindhyps = hyp0::indvars in
+  let indhyps = ref [] in
+  let decldeps = ref [] in
+  let ldeps = ref [] in
+  let rstatus = ref [] in
+  let lstatus = ref [] in
+  let before = ref true in
+  let seek_deps env (hyp,_,_ as decl) rhyp =
+    if hyp = hyp0 then begin
+      before:=false; 
+      None (* fake value *)
+    end else if List.mem hyp indvars then begin
+      (* warning: hyp can still occur after induction *)
+      (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
+      indhyps := hyp::!indhyps; 
+      rhyp
+    end else
+      if (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps
+	  or List.exists (fun (id,_,_) -> occur_var_in_decl env id decl)
+        !decldeps)
+      then begin
+	decldeps := decl::!decldeps;
+	if !before then 
+	  rstatus := (hyp,rhyp)::!rstatus
+	else 
+	  ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
+	Some hyp end
+      else
+	Some hyp
+  in
+  let _ = fold_named_context seek_deps env ~init:None in
+  (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *)
+  let compute_lstatus lhyp (hyp,_,_ as d) =
+    if hyp = hyp0 then raise (Shunt lhyp);
+    if List.mem hyp !ldeps then begin
+      lstatus := (hyp,lhyp)::!lstatus;
+      lhyp
+    end else
+      if List.mem hyp !indhyps then lhyp else (Some hyp) 
+  in
+  try 
+    let _ = fold_named_context_reverse compute_lstatus ~init:None env in
+    anomaly "hyp0 not found"
+  with Shunt lhyp0 ->
+    let statuslists = (!lstatus,List.rev !rstatus) in
+    (statuslists, lhyp0, !indhyps, !decldeps)
+
+let induction_tac varname typ ((elimc,lbindelimc),elimt) gl =
+  let c = mkVar varname in
+  let (wc,kONT)  = startWalk gl                    in
+  let indclause  = make_clenv_binding wc (c,typ) NoBindings  in
+  let elimclause =
+    make_clenv_binding wc (mkCast (elimc,elimt),elimt) lbindelimc in
+  elimination_clause_scheme kONT elimclause indclause true gl
+
+let make_up_names7 n ind (old_style,cname) = 
+  if old_style (* = V6.3 version of Induction on hypotheses *)
+  then
+    let recvarname =
+      if n=1 then 
+        cname
+      else (* To force renumbering if there is only one *)
+        make_ident (string_of_id cname ) (Some 1) in
+    recvarname, add_prefix "Hrec" recvarname, []
+  else
+    let is_hyp = atompart_of_id cname = "H" in
+    let hyprecname =
+      add_prefix "IH" (if is_hyp then Nametab.id_of_global ind else cname) in
+    let avoid =
+      if n=1 (* Only one recursive argument *)
+        or 
+        (* Rem: no recursive argument (especially if Destruct) *)
+        n=0 (* & atompart_of_id cname <> "H" (* for 7.1 compatibility *)*)
+      then []
+      else
+        (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
+        (* in order to get names such as f1, f2, ... *)
+        let avoid =
+          (make_ident (string_of_id cname) (Some 0)) ::(*here for 7.1 cmpat*)
+          (make_ident (string_of_id hyprecname) None) ::
+          (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
+        if atompart_of_id cname <> "H" then
+          (make_ident (string_of_id cname) None) :: avoid
+        else avoid in
+    cname, hyprecname, avoid
+
+let make_base n id =
+  if n=0 or n=1 then id
+  else
+    (* This extends the name to accept new digits if it already ends with *)
+    (* digits *)
+    id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
+
+let make_up_names8 n ind (_,cname) = 
+  let is_hyp = atompart_of_id cname = "H" in
+  let base = string_of_id (make_base n cname) in
+  let hyprecname =
+    add_prefix "IH"
+      (make_base n (if is_hyp then Nametab.id_of_global ind else cname)) in
+  let avoid =
+    if n=1 (* Only one recursive argument *) or n=0 then []
+    else
+      (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
+      (* in order to get names such as f1, f2, ... *)
+      let avoid =
+        (make_ident (string_of_id hyprecname) None) ::
+        (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
+      if atompart_of_id cname <> "H" then
+        (make_ident base (Some 0)) :: (make_ident base None) :: avoid
+      else avoid in
+  id_of_string base, hyprecname, avoid
+
+let is_indhyp p n t =
+  let l, c = decompose_prod t in
+  let c,_ = decompose_app c in 
+  let p = p + List.length l in
+  match kind_of_term c with
+    | Rel k when p < k & k <= p + n -> true
+    | _ -> false
+
+let chop_context n l = 
+  let rec chop_aux acc = function
+    | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t)
+    | 0, l2 -> (List.rev acc, l2)
+    | n, (h::t) -> chop_aux (h::acc) (n-1, t)
+    | _, [] -> anomaly "chop_context"
+  in 
+  chop_aux [] (n,l)
+
+let error_ind_scheme s =
+  let s = if s <> "" then s^" " else s in
+  error ("Cannot recognise "^s^"an induction schema")
+
+(* Check that the elimination scheme has a form similar to the 
+   elimination schemes built by Coq *)
+let compute_elim_signature elimt names_info =
+  let nparams = ref 0 in
+  let hyps,ccl = decompose_prod_assum elimt in
+  let n = List.length hyps in
+  if n = 0 then error_ind_scheme "";
+  let f,l = decompose_app ccl in
+  let _,indbody,ind = List.hd hyps in
+  if indbody <> None then error "Cannot recognise an induction scheme";
+  let nargs = List.length l in
+  let dep = (nargs >= 1 && list_last l = mkRel 1) in
+  let nrealargs = if dep then nargs-1 else nargs in
+  let args = if dep then list_firstn nrealargs l else l in
+  let realargs,hyps1 = chop_context nrealargs (List.tl hyps) in
+  if args <> extended_rel_list 1 realargs then
+    error_ind_scheme "the conclusion of";
+  let indhd,indargs = decompose_app ind in
+  let indt = 
+    try reference_of_constr indhd
+    with _ -> error "Cannot find the inductive type of the inductive schema" in
+  let nparams = List.length indargs - nrealargs in
+  let revparams, revhyps2 = chop_context nparams (List.rev hyps1) in
+  let rec check_elim npred = function
+  | (na,None,t)::l when isSort (snd (decompose_prod_assum t)) ->
+      check_elim (npred+1) l
+  | l ->
+    let is_pred n c = 
+      let hd = fst (decompose_app c) in match kind_of_term hd with
+    | Rel q when n < q & q <= n+npred -> IndArg
+    | _ when hd = indhd -> RecArg
+    | _ -> OtherArg in
+    let rec check_branch p c = match kind_of_term c with
+    | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c
+    | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c
+(*    | App (f,_) when is_pred p f = IndArg -> []*)
+    | _ when is_pred p c = IndArg -> []
+    | _ -> raise Exit in 
+    let rec find_branches p = function
+    | (_,None,t)::brs ->
+	(match try Some (check_branch p t) with Exit -> None with
+	 | Some l ->
+	     let n7 = List.fold_left
+	       (fun n b -> if b=IndArg then n+1 else n) 0 l in
+	     let n8 = List.fold_left
+	       (fun n b -> if b=RecArg then n+1 else n) 0 l in
+             let recvarname7, hyprecname7, avoid7 = make_up_names7 n7 indt names_info in
+             let recvarname8, hyprecname8, avoid8 = make_up_names8 n8 indt names_info in
+	     let namesign = List.map
+	       (fun b -> (b,if b=IndArg then (hyprecname7,hyprecname8)
+                else (recvarname7,recvarname8))) l in
+	     ((avoid7,avoid8),namesign) :: find_branches (p+1) brs
+	 | None -> error_ind_scheme "the branches of")
+    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+    | [] ->
+	(* Check again conclusion *)
+	let ccl_arg_ok = is_pred (p + List.length realargs + 1) f = IndArg in
+	let ind_is_ok = 
+	  list_lastn nrealargs indargs = extended_rel_list 0 realargs in
+	if not (ccl_arg_ok & ind_is_ok) then
+	  error "Cannot recognize the conclusion of an induction schema";
+	[] in
+    find_branches 0 l in
+  nparams, indt, (Array.of_list (check_elim 0 revhyps2))
+
+let find_elim_signature isrec style elim hyp0 gl =
+  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
+  let (elimc,elimt) = match elim with
+    | None ->
+	let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
+	let s = elimination_sort_of_goal gl in
+	let elimc =
+	  if isrec then Indrec.lookup_eliminator mind s
+	  else pf_apply Indrec.make_case_gen gl mind s in
+	let elimt = pf_type_of gl elimc in
+	((elimc, NoBindings), elimt)
+    | Some (elimc,lbind as e) -> 
+	(e, pf_type_of gl elimc) in
+  let name_info = (style,hyp0) in
+  let nparams,indref,indsign = compute_elim_signature elimt name_info in
+  (elimc,elimt,nparams,indref,indsign)
+
+let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl =
+  (*test suivant sans doute inutile car refait par le letin_tac*)
+  if List.mem hyp0 (ids_of_named_context (Global.named_context())) then
+    errorlabstrm "induction" 
+      (str "Cannot generalize a global variable");
+  let elimc,elimt,nparams,indref,indsign = elim_info in
+  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
+  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+  let env = pf_env gl in
+  let indvars = find_atomic_param_of_ind nparams (snd (decompose_prod typ0)) in
+  let (statlists,lhyp0,indhyps,deps) = cook_sign hyp0 indvars env in
+  let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
+  let names = compute_induction_names (Array.length indsign) names in
+  (* For translator *)
+  let names' = Array.map ref (Array.make (Array.length indsign) []) in
+  let b = ref false in
+  b_rnames := (b,Array.to_list names')::!b_rnames;
+  let names = array_map2 (fun n n' -> (n,b,n')) names names' in
+  (* End translator *)
+  let dephyps = List.map (fun (id,_,_) -> id) deps in
+  let args =
+    List.fold_left
+      (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
+
+  (* Magistral effet de bord: si hyp0 a des arguments, ceux d'entre
+     eux qui ouvrent de nouveaux buts arrivent en premier dans la
+     liste des sous-buts du fait qu'ils sont le plus à gauche dans le
+     combinateur engendré par make_case_gen (un "Cases (hyp0 ?) of
+     ...")  et il faut alors appliquer tclTHENLASTn; en revanche,
+     comme lookup_eliminator renvoie un combinateur de la forme
+     "ind_rec ... (hyp0 ?)", les buts correspondant à des arguments de
+     hyp0 sont maintenant à la fin et c'est tclTHENFIRSTn qui marche !!! *)
+  tclTHENLIST
+    [ if deps = [] then tclIDTAC else apply_type tmpcl args;
+      thin dephyps;
+      (if isrec then tclTHENFIRSTn else tclTHENLASTn)
+       	(tclTHENLIST
+	  [ induction_tac hyp0 typ0 (elimc,elimt);
+	    thin [hyp0];
+            tclTRY (thin indhyps) ])
+       	(array_map2
+	   (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
+    ]
+    gl
+
+let induction_with_atomization_of_ind_arg isrec elim names hyp0 gl =
+  let (elimc,elimt,nparams,indref,indsign as elim_info) =
+    find_elim_signature isrec false elim hyp0 gl in
+  tclTHEN
+    (atomize_param_of_ind (indref,nparams) hyp0)
+    (induction_from_context isrec elim_info hyp0 names) gl
+
+(* This is Induction since V7 ("natural" induction both in quantified
+   premisses and introduced ones) *)
+let new_induct_gen isrec elim names c gl =
+  match kind_of_term c with
+    | Var id when not (mem_named_context id (Global.named_context())) ->
+	induction_with_atomization_of_ind_arg isrec elim names id gl
+    | _        ->
+	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) 
+		  Anonymous in
+	let id = fresh_id [] x gl in
+	tclTHEN
+	  (letin_tac true (Name id) c allClauses)
+	  (induction_with_atomization_of_ind_arg isrec elim names id) gl
+
+let new_induct_destruct isrec c elim names = match c with
+  | ElimOnConstr c -> new_induct_gen isrec elim names c
+  | ElimOnAnonHyp n ->
+      tclTHEN (intros_until_n n)
+        (tclLAST_HYP (new_induct_gen isrec elim names))
+  (* Identifier apart because id can be quantified in goal and not typable *)
+  | ElimOnIdent (_,id) ->
+      tclTHEN (tclTRY (intros_until_id id))
+        (new_induct_gen isrec elim names (mkVar id))
+
+let new_induct = new_induct_destruct true
+let new_destruct = new_induct_destruct false
+
+(* The registered tactic, which calls the default elimination
+ * if no elimination constant is provided. *)
+	
+(* Induction tactics *)
+
+(* This was Induction before 6.3 (induction only in quantified premisses) *)
+let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim)
+let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim)
+
+(* This was Induction in 6.3 (hybrid form) *)
+let induction_from_context_old_style hyp b_ids gl =
+  let elim_info = find_elim_signature true true None hyp gl in
+  let x = induction_from_context true elim_info hyp (None,b_ids) gl in
+  (* For translator *) fst (List.hd !b_ids) := true;
+  x
+
+let simple_induct_id hyp b_ids =
+  if !Options.v7 then
+    tclORELSE (raw_induct hyp) (induction_from_context_old_style hyp b_ids)
+  else
+    raw_induct hyp
+let simple_induct_nodep = raw_induct_nodep
+
+let simple_induct = function
+  | NamedHyp id,b_ids -> simple_induct_id id b_ids
+  | AnonHyp n,_ -> simple_induct_nodep n
+
+(* Destruction tactics *)
+
+let simple_destruct_id s    =
+  (tclTHEN (intros_until_id s) (tclLAST_HYP simplest_case))
+let simple_destruct_nodep n =
+  (tclTHEN (intros_until_n n)    (tclLAST_HYP simplest_case))
+
+let simple_destruct = function
+  | NamedHyp id -> simple_destruct_id id
+  | AnonHyp n -> simple_destruct_nodep n
+
+(*
+ *  Eliminations giving the type instead of the proof.
+ * These tactics use the default elimination constant and
+ * no substitutions at all. 
+ * May be they should be integrated into Elim ...
+ *)
+
+let elim_scheme_type elim t gl =
+  let (wc,kONT) = startWalk gl in
+  let clause = mk_clenv_type_of wc elim in 
+  match kind_of_term (last_arg (clenv_template clause).rebus) with
+    | Meta mv ->
+        let clause' =
+	  (* t is inductive, then CUMUL or CONV is irrelevant *)
+	  clenv_unify true CUMUL t (clenv_instance_type clause mv) clause in
+	elim_res_pf kONT clause' true gl
+    | _ -> anomaly "elim_scheme_type"
+
+let elim_type t gl =
+  let (ind,t) = pf_reduce_to_atomic_ind gl t in
+  let elimc = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in
+  elim_scheme_type elimc t gl
+
+let case_type t gl =
+  let (ind,t) = pf_reduce_to_atomic_ind gl t in
+  let env = pf_env gl in
+  let elimc = Indrec.make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in 
+  elim_scheme_type elimc t gl
+
+
+(* Some eliminations frequently used *)
+
+(* These elimination tactics are particularly adapted for sequent
+   calculus.  They take a clause as argument, and yield the
+   elimination rule if the clause is of the form (Some id) and a
+   suitable introduction rule otherwise. They do not depend on 
+   the name of the eliminated constant, so they can be also 
+   used on ad-hoc disjunctions and conjunctions introduced by
+   the user. 
+   -- Eduardo Gimenez (11/8/97)
+
+   HH (29/5/99) replaces failures by specific error messages
+ *)
+
+let andE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_conjunction (pf_hnf_constr gl t) then 
+    (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl
+  else 
+    errorlabstrm "andE" 
+      (str("Tactic andE expects "^(string_of_id id)^" is a conjunction."))
+
+let dAnd cls =
+  onClauses
+    (function
+      | None    -> simplest_split
+      | Some (id,_,_) -> andE id)
+    cls
+
+let orE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_disjunction (pf_hnf_constr gl t) then 
+    (tclTHEN (simplest_elim (mkVar id)) intro) gl
+  else 
+    errorlabstrm "orE" 
+      (str("Tactic orE expects "^(string_of_id id)^" is a disjunction."))
+
+let dorE b cls =
+  onClauses
+    (function
+      | (Some (id,_,_)) -> orE id
+      |  None     -> (if b then right else left) NoBindings)
+    cls
+
+let impE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_imp_term (pf_hnf_constr gl t) then 
+    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in 
+    tclTHENLAST
+      (cut_intro rng) 
+      (apply_term (mkVar id) [mkMeta (new_meta())]) gl
+  else 
+    errorlabstrm "impE"
+      (str("Tactic impE expects "^(string_of_id id)^
+	      " is a an implication."))
+                        
+let dImp cls =
+  onClauses
+    (function
+      | None    -> intro
+      | Some (id,_,_) -> impE id)
+    cls
+
+(************************************************)
+(*  Tactics related with logic connectives      *)
+(************************************************)
+
+(* Reflexivity tactics *)
+
+let reflexivity gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) ->  one_constructor 1 NoBindings gl
+
+let intros_reflexivity  = (tclTHEN intros reflexivity)
+
+(* Symmetry tactics *)
+
+(* This tactic first tries to apply a constant named sym_eq, where eq
+   is the name of the equality predicate. If this constant is not
+   defined and the conclusion is a=b, it solves the goal doing (Cut
+   b=a;Intro H;Case H;Constructor 1) *)
+
+let symmetry gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) ->
+        let hdcncls = string_of_inductive hdcncl in
+        begin 
+	  try 
+	    (apply (pf_parse_const gl ("sym_"^hdcncls)) gl)
+          with  _ ->
+            let symc = match args with 
+	      | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
+              | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
+              | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
+	      | _ -> assert false 
+	    in 
+	    tclTHENLAST (cut symc)
+              (tclTHENLIST 
+		[ intro;
+		  tclLAST_HYP simplest_case;
+		  one_constructor 1 NoBindings ])
+	      gl
+	end
+
+let symmetry_in id gl = 
+  let ctype = pf_type_of gl (mkVar id) in 
+  let sign,t = decompose_prod_assum ctype in
+  match match_with_equation t with
+    | None -> (* Do not deal with setoids yet *) 
+        error "The term provided does not end with an equation" 
+    | Some (hdcncl,args) -> 
+        let symccl = match args with 
+	  | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
+          | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
+          | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
+	  | _ -> assert false in
+	tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
+	  [ intro_replacing id;
+            tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
+	  gl
+
+let intros_symmetry =
+  onClauses
+    (function
+      | None -> tclTHEN intros symmetry
+      | Some (id,_,_) -> symmetry_in id)
+
+(* Transitivity tactics *)
+
+(* This tactic first tries to apply a constant named trans_eq, where eq
+   is the name of the equality predicate. If this constant is not
+   defined and the conclusion is a=b, it solves the goal doing 
+   Cut x1=x2; 
+       [Cut x2=x3; [Intros e1 e2; Case e2;Assumption 
+                    | Idtac]
+       | Idtac]
+   --Eduardo (19/8/97)
+*)
+
+let transitivity t gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) -> 
+        let hdcncls = string_of_inductive hdcncl in
+        begin
+	  try 
+	    apply_list [(pf_parse_const gl ("trans_"^hdcncls));t] gl 
+          with  _ -> 
+            let eq1, eq2 = match args with 
+	      | [typ1;c1;typ2;c2] -> let typt = pf_type_of gl t in
+                  ( mkApp(hdcncl, [| typ1; c1; typt ;t |]),
+		    mkApp(hdcncl, [| typt; t; typ2; c2 |]) )
+              | [typ;c1;c2] ->
+		  ( mkApp (hdcncl, [| typ; c1; t |]),
+		    mkApp (hdcncl, [| typ; t; c2 |]) )
+	      | [c1;c2]     ->
+		  ( mkApp (hdcncl, [| c1; t|]),
+		    mkApp (hdcncl, [| t; c2 |]) )
+	      | _ -> assert false 
+	    in
+            tclTHENFIRST (cut eq2)
+	      (tclTHENFIRST (cut eq1)
+                (tclTHENLIST
+		  [ tclDO 2 intro;
+		    tclLAST_HYP simplest_case;
+		    assumption ])) gl
+        end 
+	
+let intros_transitivity  n  = tclTHEN intros (transitivity n)
+
+(* tactical to save as name a subproof such that the generalisation of 
+   the current goal, abstracted with respect to the local signature, 
+   is solved by tac *)
+
+let interpretable_as_section_decl d1 d2 = match d1,d2 with
+  | (_,Some _,_), (_,None,_) -> false
+  | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
+  | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
+
+let abstract_subproof name tac gls = 
+  let env = Global.env() in
+  let current_sign = Global.named_context()
+  and global_sign = pf_hyps gls in
+  let sign,secsign = 
+    List.fold_right
+      (fun (id,_,_ as d) (s1,s2) -> 
+	 if mem_named_context id current_sign &
+           interpretable_as_section_decl (Sign.lookup_named id current_sign) d
+         then (s1,add_named_decl d s2)
+	 else (add_named_decl d s1,s2)) 
+      global_sign (empty_named_context,empty_named_context) in
+  let na = next_global_ident_away false name (pf_ids_of_hyps gls) in
+  let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in
+  if occur_existential concl then
+    if !Options.v7 then error "Abstract cannot handle existentials"
+    else error "\"abstract\" cannot handle existentials";
+  let lemme =
+    start_proof na (IsGlobal (Proof Lemma)) secsign concl (fun _ _ -> ());
+    let _,(const,kind,_) =
+      try
+	by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); 
+	let r = cook_proof () in 
+	delete_current_proof (); r
+      with e when catchable_exception e -> 
+	(delete_current_proof(); raise e)
+    in   (* Faudrait un peu fonctionnaliser cela *)
+    let cd = Entries.DefinitionEntry const in
+    let sp = Declare.declare_internal_constant na (cd,IsProof Lemma) in
+    let newenv = Global.env() in
+    constr_of_reference (ConstRef (snd sp))
+  in
+  exact_no_check 
+    (applist (lemme, 
+              List.rev (Array.to_list (instance_from_named_context sign))))
+    gls
+
+let tclABSTRACT name_op tac gls = 
+  let s = match name_op with 
+    | Some s -> s 
+    | None   -> add_suffix (get_current_proof_name ()) "_subproof" 
+  in  
+  abstract_subproof s tac gls
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
new file mode 100644
index 00000000..6e67a9cd
--- /dev/null
+++ b/tactics/tactics.mli
@@ -0,0 +1,245 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tactics.mli,v 1.59.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Sign
+open Tacmach
+open Proof_type
+open Reduction
+open Evd
+open Evar_refiner
+open Clenv
+open Tacred
+open Tacticals
+open Libnames
+open Genarg
+open Tacexpr
+open Nametab
+open Rawterm
+
+(* Main tactics. *)
+
+(*s General functions. *)
+
+val type_clenv_binding : named_context sigma ->
+  constr * constr -> constr bindings  -> constr
+
+val string_of_inductive : constr -> string
+val head_constr       : constr -> constr list
+val head_constr_bound : constr -> constr list -> constr list
+val is_quantified_hypothesis : identifier -> goal sigma -> bool
+
+exception Bound
+
+(*s Primitive tactics. *)
+
+val introduction    : identifier -> tactic
+val refine          : constr -> tactic
+val convert_concl   : constr -> tactic
+val convert_hyp     : named_declaration -> tactic
+val thin            : identifier list -> tactic
+val mutual_fix      :
+  identifier -> int -> (identifier * int * constr) list -> tactic
+val fix             : identifier option -> int -> tactic
+val mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val cofix           : identifier option -> tactic
+
+(*s Introduction tactics. *)
+
+val fresh_id : identifier list -> identifier -> goal sigma -> identifier
+
+val intro                : tactic
+val introf               : tactic
+val intro_force          : bool -> tactic
+val intro_move           : identifier option -> identifier option -> tactic
+
+val intro_replacing      : identifier -> tactic
+val intro_using          : identifier -> tactic
+val intro_mustbe_force   : identifier -> tactic
+val intros_using         : identifier list -> tactic
+val intro_erasing        : identifier -> tactic
+val intros_replacing     : identifier list -> tactic
+
+val intros               : tactic
+
+(* [depth_of_quantified_hypothesis b h g] returns the index of [h] in
+   the conclusion of goal [g], up to head-reduction if [b] is [true] *)
+val depth_of_quantified_hypothesis :
+  bool -> quantified_hypothesis -> goal sigma -> int
+
+val intros_until_n_wored : int -> tactic
+val intros_until         : quantified_hypothesis -> tactic
+
+val intros_clearing      : bool list -> tactic
+
+(* Assuming a tactic [tac] depending on an hypothesis identifier,
+   [try_intros_until tac arg] first assumes that arg denotes a
+   quantified hypothesis (denoted by name or by index) and try to
+   introduce it in context before to apply [tac], otherwise assume the
+   hypothesis is already in context and directly apply [tac] *)
+
+val try_intros_until :
+  (identifier -> tactic) -> quantified_hypothesis -> tactic
+
+(*s Introduction tactics with eliminations. *)
+
+val intro_pattern     : identifier option -> intro_pattern_expr      -> tactic
+val intro_patterns    : intro_pattern_expr list -> tactic
+val intros_pattern    : identifier option -> intro_pattern_expr list -> tactic
+
+(*s Exact tactics. *)
+
+val assumption       : tactic
+val exact_no_check   : constr -> tactic
+val exact_check      : constr -> tactic
+val exact_proof      : Topconstr.constr_expr -> tactic
+
+(*s Reduction tactics. *)
+
+type tactic_reduction = env -> evar_map -> constr -> constr
+
+val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
+val reduct_option     : tactic_reduction -> simple_clause -> tactic
+val reduct_in_concl   : tactic_reduction -> tactic
+val change_in_concl   : constr occurrences option -> constr -> tactic
+val change_in_hyp     : constr occurrences option -> constr -> hyp_location ->
+  tactic
+val red_in_concl      : tactic
+val red_in_hyp        : hyp_location        -> tactic
+val red_option        : simple_clause -> tactic
+val hnf_in_concl      : tactic
+val hnf_in_hyp        : hyp_location        -> tactic
+val hnf_option        : simple_clause -> tactic
+val simpl_in_concl    : tactic
+val simpl_in_hyp      : hyp_location        -> tactic
+val simpl_option      : simple_clause -> tactic
+val normalise_in_concl: tactic
+val normalise_in_hyp  : hyp_location        -> tactic
+val normalise_option  : simple_clause -> tactic
+val unfold_in_concl   : (int list * evaluable_global_reference) list -> tactic
+val unfold_in_hyp     : 
+  (int list * evaluable_global_reference) list -> hyp_location -> tactic
+val unfold_option     : 
+  (int list * evaluable_global_reference) list -> simple_clause
+    -> tactic
+val reduce            : red_expr -> clause -> tactic
+val change            :
+  constr occurrences option -> constr -> clause -> tactic
+
+val unfold_constr     : global_reference -> tactic
+val pattern_option  : (int list * constr) list -> simple_clause -> tactic
+
+(*s Modification of the local context. *)
+
+val clear         : identifier list -> tactic
+val clear_body    : identifier list -> tactic
+
+val new_hyp       : int option -> constr with_bindings -> tactic
+
+val move_hyp      : bool -> identifier -> identifier -> tactic
+val rename_hyp    : identifier -> identifier -> tactic
+
+(*s Resolution tactics. *)
+
+val apply_type : constr -> constr list -> tactic
+val apply_term : constr -> constr list -> tactic
+val bring_hyps : named_context -> tactic
+
+val apply                 : constr      -> tactic
+val apply_without_reduce  : constr      -> tactic
+val apply_list            : constr list -> tactic
+val apply_with_bindings   : constr with_bindings -> tactic
+
+val cut_and_apply         : constr -> tactic
+
+(*s Elimination tactics. *)
+
+val general_elim  : constr with_bindings -> constr with_bindings -> 
+  ?allow_K:bool -> tactic
+val default_elim  : constr with_bindings -> tactic
+val simplest_elim : constr -> tactic
+val elim          : constr with_bindings -> constr with_bindings option -> tactic
+val general_elim_in : identifier -> constr * constr bindings ->
+                      constr * constr bindings -> tactic
+
+val simple_induct     : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic
+val general_elim_in : identifier -> constr * constr bindings ->
+                      constr * constr bindings -> tactic
+
+val new_induct : constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+
+(*s Case analysis tactics. *)
+
+val general_case_analysis : constr with_bindings ->  tactic
+val simplest_case         : constr -> tactic
+
+val simple_destruct          : quantified_hypothesis -> tactic
+val new_destruct : constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+
+(*s Eliminations giving the type instead of the proof. *)
+
+val case_type         : constr  -> tactic
+val elim_type         : constr  -> tactic
+
+(*s Some eliminations which are frequently used. *)
+
+val impE : identifier -> tactic
+val andE : identifier -> tactic
+val orE  : identifier -> tactic
+val dImp : clause -> tactic
+val dAnd : clause -> tactic
+val dorE : bool -> clause ->tactic
+
+
+(*s Introduction tactics. *)
+
+val constructor_tac            : int option -> int -> 
+                                 constr bindings  -> tactic
+val one_constructor            : int -> constr bindings  -> tactic
+val any_constructor            : tactic option -> tactic
+val left                       : constr bindings -> tactic
+val simplest_left              : tactic
+val right                      : constr bindings -> tactic
+val simplest_right             : tactic
+val split                      : constr bindings -> tactic
+val simplest_split             : tactic
+
+(*s Logical connective tactics. *)
+
+val reflexivity                 : tactic
+val intros_reflexivity          : tactic
+
+val symmetry                    : tactic
+val symmetry_in                 : identifier -> tactic
+val intros_symmetry             : clause -> tactic
+
+val transitivity                : constr -> tactic
+val intros_transitivity         : constr -> tactic
+
+val cut                         : constr -> tactic
+val cut_intro                   : constr -> tactic
+val cut_replacing               : identifier -> constr -> tactic
+val cut_in_parallel             : constr list -> tactic
+
+val assert_tac                  : bool -> name -> constr -> tactic
+val true_cut                    : name -> constr -> tactic
+val letin_tac                   : bool -> name -> constr -> clause -> tactic
+val forward                     : bool -> name -> constr -> tactic
+val generalize                  : constr list -> tactic
+val generalize_dep              : constr  -> tactic
+
+val tclABSTRACT : identifier option -> tactic -> tactic
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
new file mode 100644
index 00000000..553acc91
--- /dev/null
+++ b/tactics/tauto.ml4
@@ -0,0 +1,209 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(*i $Id: tauto.ml4,v 1.62.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+open Ast
+open Coqast
+open Hipattern
+open Names
+open Libnames
+open Pp
+open Proof_type
+open Tacticals
+open Tacinterp
+open Tactics
+open Util
+
+let assoc_last ist =
+  match List.assoc (Names.id_of_string "X1") ist.lfun with
+    | VConstr c -> c
+    | _ -> failwith "Tauto: anomaly"
+
+let is_empty ist =
+  if is_empty_type (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+
+let is_unit ist =
+  if is_unit_type (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+    
+let is_conj ist =
+  let ind = assoc_last ist in
+    if (is_conjunction ind) && (is_nodep_ind ind) then
+      <:tactic<idtac>>
+    else
+      <:tactic<fail>>
+
+let is_disj ist =
+  if is_disjunction (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+
+let not_dep_intros ist =
+  <:tactic<
+  repeat match goal with
+  | |- (?X1 -> ?X2) => intro
+  | |- (Coq.Init.Logic.iff _ _) => unfold Coq.Init.Logic.iff
+  | |- (Coq.Init.Logic.not _)   => unfold Coq.Init.Logic.not
+  | H:(Coq.Init.Logic.iff _ _)|- _ => unfold Coq.Init.Logic.iff in H
+  | H:(Coq.Init.Logic.not _)|-_    => unfold Coq.Init.Logic.not in H
+  | H:(Coq.Init.Logic.iff _ _)->_|- _ => unfold Coq.Init.Logic.iff in H
+  | H:(Coq.Init.Logic.not _)->_|-_    => unfold Coq.Init.Logic.not in H
+  end >>
+				      
+let axioms ist =
+  let t_is_unit = tacticIn is_unit
+  and t_is_empty = tacticIn is_empty in
+    <:tactic<
+    match reverse goal with
+      | |- ?X1 => $t_is_unit; constructor 1
+      | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
+      | _:?X1 |- ?X1 => assumption
+    end >>
+
+
+let simplif ist =
+  let t_is_unit = tacticIn is_unit
+  and t_is_conj = tacticIn is_conj
+  and t_is_disj = tacticIn is_disj
+  and t_not_dep_intros = tacticIn not_dep_intros in
+  <:tactic<
+    $t_not_dep_intros;
+    repeat
+       (match reverse goal with
+        | id: (?X1 _ _) |- _ =>
+            $t_is_conj; elim id; do 2 intro; clear id
+        | id: (?X1 _ _) |- _ => $t_is_disj; elim id; intro; clear id
+        | id0: ?X1-> ?X2, id1: ?X1|- _ =>
+	    (* generalize (id0 id1); intro; clear id0 does not work
+	       (see Marco Maggiesi's bug PR#301)
+	    so we instead use Assert and exact. *)
+	    assert X2; [exact (id0 id1) | clear id0]
+        | id: ?X1 -> ?X2|- _ =>
+          $t_is_unit; cut X2;
+	    [ intro; clear id
+	    | (* id : ?X1 -> ?X2 |- ?X2 *)
+	      cut X1; [exact id| constructor 1; fail]
+	    ]
+        | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
+          $t_is_conj; cut (X2-> X3-> X4);
+	    [ intro; clear id
+	    | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X3 -> ?X4 *)
+	      intro; intro; cut (X1 X2 X3); [exact id| split; assumption]
+	    ]
+        | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
+          $t_is_disj;
+	    cut (X3-> X4);
+	      [cut (X2-> X4);
+	        [intro; intro; clear id
+		| (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X4 *)
+		  intro; cut (X1 X2 X3); [exact id| left; assumption]
+		]
+	      | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X3 -> ?X4 *)
+		intro; cut (X1 X2 X3); [exact id| right; assumption]
+	      ]
+        | |- (?X1 _ _) => $t_is_conj; split
+        end;
+        $t_not_dep_intros) >>
+
+let rec tauto_intuit t_reduce solver ist =
+  let t_axioms = tacticIn axioms
+  and t_simplif = tacticIn simplif
+  and t_is_disj = tacticIn is_disj
+  and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in
+  let t_solver = Tacexpr.TacArg (valueIn (VTactic (dummy_loc,solver))) in
+  <:tactic<
+   ($t_simplif;$t_axioms
+   || match reverse goal with
+      | id:(?X1-> ?X2)-> ?X3|- _ =>
+	  cut X3;
+	    [ intro; clear id; $t_tauto_intuit 
+	    | cut (X1 -> X2);
+		[ exact id
+		| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
+		  solve [ $t_tauto_intuit ]]]
+      | |- (?X1 _ _) =>
+          $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit]
+      end
+    ||
+    (* NB: [|- _ -> _] matches any product *)
+    match goal with | |- _ -> _ => intro; $t_tauto_intuit
+    |  |- _  => $t_reduce;$t_solver
+    end
+    ||
+    $t_solver
+   ) >>
+    
+let reduction_not_iff=interp
+ <:tactic<repeat 
+  match goal with 
+  | |- _     => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff 
+  | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H
+  end >>
+
+
+let t_reduction_not_iff =
+  Tacexpr.TacArg (valueIn (VTactic (dummy_loc,reduction_not_iff)))
+
+let intuition_gen tac =
+  interp (tacticIn (tauto_intuit t_reduction_not_iff tac))
+
+let simplif_gen = interp (tacticIn simplif)
+
+let tauto g =
+  try intuition_gen (interp <:tactic<fail>>) g
+  with
+    Refiner.FailError _ | UserError _ ->
+      errorlabstrm "tauto" [< str "Tauto failed" >]
+
+let default_intuition_tac = interp <:tactic< auto with * >>
+
+let q_elim tac=
+  <:tactic<
+  match goal with 
+    x : ?X1, H : ?X1 -> _ |- _ => generalize (H x); clear H; $tac
+  end >>
+
+let rec lfo n gl=
+  if n=0 then (tclFAIL 0 "LinearIntuition failed" gl) else
+    let p=if n<0 then n else (n-1) in
+    let lfo_rec=q_elim (Tacexpr.TacArg (valueIn (VTactic(dummy_loc,lfo p)))) in
+      intuition_gen (interp lfo_rec) gl
+
+let lfo_wrap n gl= 
+  try lfo n gl
+  with
+    Refiner.FailError _ | UserError _ ->
+      errorlabstrm "LinearIntuition" [< str "LinearIntuition failed." >]
+
+TACTIC EXTEND Tauto
+| [ "Tauto" ] -> [ tauto ]
+END
+(* Obsolete sinve V8.0
+TACTIC EXTEND TSimplif
+| [ "Simplif" ] -> [ simplif_gen ]
+END
+*)
+TACTIC EXTEND Intuition
+| [ "Intuition" ] -> [ intuition_gen default_intuition_tac ]
+| [ "Intuition" tactic(t) ] -> [ intuition_gen (snd t) ]
+END
+(* Obsolete since V8.0
+TACTIC EXTEND LinearIntuition
+| [ "LinearIntuition" ] -> [ lfo_wrap (-1)]
+| [ "LinearIntuition" integer(n)] -> [ lfo_wrap n]
+END
+*)
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
new file mode 100644
index 00000000..9e77ddbd
--- /dev/null
+++ b/tactics/termdn.ml
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: termdn.ml,v 1.15.8.1 2004/07/16 19:30:56 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Pattern
+open Rawterm
+open Libnames
+open Nametab
+
+(* Discrimination nets of terms.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+
+type 'a t = (constr_label,constr_pattern,'a) Dn.t
+
+(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
+
+let decomp = 
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Cast (c1,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in 
+  decrec []
+
+let decomp_pat = 
+  let rec decrec acc = function
+    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
+    | c -> (c,acc)
+  in 
+  decrec []   
+
+let constr_pat_discr t =
+  if not (occur_meta_pattern t) then 
+    None
+  else
+    match decomp_pat t with
+      | PRef (IndRef sp), args -> Some(IndNode sp,args)
+      | PRef (ConstructRef sp), args -> Some(CstrNode sp,args)
+      | PRef (VarRef id), args -> Some(VarNode id,args)
+      | _ -> None
+
+let constr_val_discr t =
+  let c, l = decomp t in
+  match kind_of_term c with
+    (* Const _,_) -> Some(TERM c,l) *)
+    | Ind ind_sp -> Some(IndNode ind_sp,l)
+    | Construct cstr_sp -> Some(CstrNode cstr_sp,l)
+    (* Ici, comment distinguer SectionVarNode de VarNode ?? *)
+    | Var id -> Some(VarNode id,l)
+    | _ -> None
+
+(* Les deux fonctions suivantes ecrasaient les precedentes, 
+   ajout d'un suffixe _nil CP 16/08 *) 
+
+let constr_pat_discr_nil t =
+  match constr_pat_discr t with
+    | None -> None
+    | Some (c,_) -> Some(c,[])
+
+let constr_val_discr_nil t =
+  match constr_val_discr t with
+    | None -> None
+    | Some (c,_) -> Some(c,[])
+
+let create = Dn.create 
+
+let add dn = Dn.add dn constr_pat_discr
+
+let rmv dn = Dn.rmv dn constr_pat_discr
+
+let lookup dn t = Dn.lookup dn constr_val_discr t
+
+let app f dn = Dn.app f dn
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
new file mode 100644
index 00000000..e3caf6d9
--- /dev/null
+++ b/tactics/termdn.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: termdn.mli,v 1.9.16.1 2004/07/16 19:30:56 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+  
+(* Discrimination nets of terms. *)
+
+(* This module registers actions (typically tactics) mapped to patterns *)
+
+(* Patterns are stocked linearly as the list of its node in prefix
+order in such a way patterns having the same prefix have this common
+prefix shared and the seek for the action associated to the patterns
+that a term matches are found in time proportional to the maximal
+number of nodes of the patterns matching the term *)
+
+type 'a t
+
+val create : unit -> 'a t
+
+(* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
+
+val add : 'a t -> (constr_pattern * 'a) -> 'a t
+
+val rmv : 'a t -> (constr_pattern * 'a) -> 'a t
+
+(* [lookup t c] looks for patterns (with their action) matching term [c] *)
+
+val lookup : 'a t -> constr -> (constr_pattern * 'a) list
+
+val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
+
+
+(*i*)
+(* These are for Nbtermdn *)
+
+val constr_pat_discr : 
+  constr_pattern -> (constr_label * constr_pattern list) option
+val constr_val_discr :
+  constr -> (constr_label * constr list) option
+
+(*i*)
diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v
new file mode 100644
index 00000000..4accbf34
--- /dev/null
+++ b/test-suite/bench/lists-100.v
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Inductive list0 : Set := nil0 : list0 | cons0 : Set -> list0 -> list0.
+Inductive list1 : Set := nil1 : list1 | cons1 : Set -> list1 -> list1.
+Inductive list2 : Set := nil2 : list2 | cons2 : Set -> list2 -> list2.
+Inductive list3 : Set := nil3 : list3 | cons3 : Set -> list3 -> list3.
+Inductive list4 : Set := nil4 : list4 | cons4 : Set -> list4 -> list4.
+Inductive list5 : Set := nil5 : list5 | cons5 : Set -> list5 -> list5.
+Inductive list6 : Set := nil6 : list6 | cons6 : Set -> list6 -> list6.
+Inductive list7 : Set := nil7 : list7 | cons7 : Set -> list7 -> list7.
+Inductive list8 : Set := nil8 : list8 | cons8 : Set -> list8 -> list8.
+Inductive list9 : Set := nil9 : list9 | cons9 : Set -> list9 -> list9.
+Inductive list10 : Set := nil10 : list10 | cons10 : Set -> list10 -> list10.
+Inductive list11 : Set := nil11 : list11 | cons11 : Set -> list11 -> list11.
+Inductive list12 : Set := nil12 : list12 | cons12 : Set -> list12 -> list12.
+Inductive list13 : Set := nil13 : list13 | cons13 : Set -> list13 -> list13.
+Inductive list14 : Set := nil14 : list14 | cons14 : Set -> list14 -> list14.
+Inductive list15 : Set := nil15 : list15 | cons15 : Set -> list15 -> list15.
+Inductive list16 : Set := nil16 : list16 | cons16 : Set -> list16 -> list16.
+Inductive list17 : Set := nil17 : list17 | cons17 : Set -> list17 -> list17.
+Inductive list18 : Set := nil18 : list18 | cons18 : Set -> list18 -> list18.
+Inductive list19 : Set := nil19 : list19 | cons19 : Set -> list19 -> list19.
+Inductive list20 : Set := nil20 : list20 | cons20 : Set -> list20 -> list20.
+Inductive list21 : Set := nil21 : list21 | cons21 : Set -> list21 -> list21.
+Inductive list22 : Set := nil22 : list22 | cons22 : Set -> list22 -> list22.
+Inductive list23 : Set := nil23 : list23 | cons23 : Set -> list23 -> list23.
+Inductive list24 : Set := nil24 : list24 | cons24 : Set -> list24 -> list24.
+Inductive list25 : Set := nil25 : list25 | cons25 : Set -> list25 -> list25.
+Inductive list26 : Set := nil26 : list26 | cons26 : Set -> list26 -> list26.
+Inductive list27 : Set := nil27 : list27 | cons27 : Set -> list27 -> list27.
+Inductive list28 : Set := nil28 : list28 | cons28 : Set -> list28 -> list28.
+Inductive list29 : Set := nil29 : list29 | cons29 : Set -> list29 -> list29.
+Inductive list30 : Set := nil30 : list30 | cons30 : Set -> list30 -> list30.
+Inductive list31 : Set := nil31 : list31 | cons31 : Set -> list31 -> list31.
+Inductive list32 : Set := nil32 : list32 | cons32 : Set -> list32 -> list32.
+Inductive list33 : Set := nil33 : list33 | cons33 : Set -> list33 -> list33.
+Inductive list34 : Set := nil34 : list34 | cons34 : Set -> list34 -> list34.
+Inductive list35 : Set := nil35 : list35 | cons35 : Set -> list35 -> list35.
+Inductive list36 : Set := nil36 : list36 | cons36 : Set -> list36 -> list36.
+Inductive list37 : Set := nil37 : list37 | cons37 : Set -> list37 -> list37.
+Inductive list38 : Set := nil38 : list38 | cons38 : Set -> list38 -> list38.
+Inductive list39 : Set := nil39 : list39 | cons39 : Set -> list39 -> list39.
+Inductive list40 : Set := nil40 : list40 | cons40 : Set -> list40 -> list40.
+Inductive list41 : Set := nil41 : list41 | cons41 : Set -> list41 -> list41.
+Inductive list42 : Set := nil42 : list42 | cons42 : Set -> list42 -> list42.
+Inductive list43 : Set := nil43 : list43 | cons43 : Set -> list43 -> list43.
+Inductive list44 : Set := nil44 : list44 | cons44 : Set -> list44 -> list44.
+Inductive list45 : Set := nil45 : list45 | cons45 : Set -> list45 -> list45.
+Inductive list46 : Set := nil46 : list46 | cons46 : Set -> list46 -> list46.
+Inductive list47 : Set := nil47 : list47 | cons47 : Set -> list47 -> list47.
+Inductive list48 : Set := nil48 : list48 | cons48 : Set -> list48 -> list48.
+Inductive list49 : Set := nil49 : list49 | cons49 : Set -> list49 -> list49.
+Inductive list50 : Set := nil50 : list50 | cons50 : Set -> list50 -> list50.
+Inductive list51 : Set := nil51 : list51 | cons51 : Set -> list51 -> list51.
+Inductive list52 : Set := nil52 : list52 | cons52 : Set -> list52 -> list52.
+Inductive list53 : Set := nil53 : list53 | cons53 : Set -> list53 -> list53.
+Inductive list54 : Set := nil54 : list54 | cons54 : Set -> list54 -> list54.
+Inductive list55 : Set := nil55 : list55 | cons55 : Set -> list55 -> list55.
+Inductive list56 : Set := nil56 : list56 | cons56 : Set -> list56 -> list56.
+Inductive list57 : Set := nil57 : list57 | cons57 : Set -> list57 -> list57.
+Inductive list58 : Set := nil58 : list58 | cons58 : Set -> list58 -> list58.
+Inductive list59 : Set := nil59 : list59 | cons59 : Set -> list59 -> list59.
+Inductive list60 : Set := nil60 : list60 | cons60 : Set -> list60 -> list60.
+Inductive list61 : Set := nil61 : list61 | cons61 : Set -> list61 -> list61.
+Inductive list62 : Set := nil62 : list62 | cons62 : Set -> list62 -> list62.
+Inductive list63 : Set := nil63 : list63 | cons63 : Set -> list63 -> list63.
+Inductive list64 : Set := nil64 : list64 | cons64 : Set -> list64 -> list64.
+Inductive list65 : Set := nil65 : list65 | cons65 : Set -> list65 -> list65.
+Inductive list66 : Set := nil66 : list66 | cons66 : Set -> list66 -> list66.
+Inductive list67 : Set := nil67 : list67 | cons67 : Set -> list67 -> list67.
+Inductive list68 : Set := nil68 : list68 | cons68 : Set -> list68 -> list68.
+Inductive list69 : Set := nil69 : list69 | cons69 : Set -> list69 -> list69.
+Inductive list70 : Set := nil70 : list70 | cons70 : Set -> list70 -> list70.
+Inductive list71 : Set := nil71 : list71 | cons71 : Set -> list71 -> list71.
+Inductive list72 : Set := nil72 : list72 | cons72 : Set -> list72 -> list72.
+Inductive list73 : Set := nil73 : list73 | cons73 : Set -> list73 -> list73.
+Inductive list74 : Set := nil74 : list74 | cons74 : Set -> list74 -> list74.
+Inductive list75 : Set := nil75 : list75 | cons75 : Set -> list75 -> list75.
+Inductive list76 : Set := nil76 : list76 | cons76 : Set -> list76 -> list76.
+Inductive list77 : Set := nil77 : list77 | cons77 : Set -> list77 -> list77.
+Inductive list78 : Set := nil78 : list78 | cons78 : Set -> list78 -> list78.
+Inductive list79 : Set := nil79 : list79 | cons79 : Set -> list79 -> list79.
+Inductive list80 : Set := nil80 : list80 | cons80 : Set -> list80 -> list80.
+Inductive list81 : Set := nil81 : list81 | cons81 : Set -> list81 -> list81.
+Inductive list82 : Set := nil82 : list82 | cons82 : Set -> list82 -> list82.
+Inductive list83 : Set := nil83 : list83 | cons83 : Set -> list83 -> list83.
+Inductive list84 : Set := nil84 : list84 | cons84 : Set -> list84 -> list84.
+Inductive list85 : Set := nil85 : list85 | cons85 : Set -> list85 -> list85.
+Inductive list86 : Set := nil86 : list86 | cons86 : Set -> list86 -> list86.
+Inductive list87 : Set := nil87 : list87 | cons87 : Set -> list87 -> list87.
+Inductive list88 : Set := nil88 : list88 | cons88 : Set -> list88 -> list88.
+Inductive list89 : Set := nil89 : list89 | cons89 : Set -> list89 -> list89.
+Inductive list90 : Set := nil90 : list90 | cons90 : Set -> list90 -> list90.
+Inductive list91 : Set := nil91 : list91 | cons91 : Set -> list91 -> list91.
+Inductive list92 : Set := nil92 : list92 | cons92 : Set -> list92 -> list92.
+Inductive list93 : Set := nil93 : list93 | cons93 : Set -> list93 -> list93.
+Inductive list94 : Set := nil94 : list94 | cons94 : Set -> list94 -> list94.
+Inductive list95 : Set := nil95 : list95 | cons95 : Set -> list95 -> list95.
+Inductive list96 : Set := nil96 : list96 | cons96 : Set -> list96 -> list96.
+Inductive list97 : Set := nil97 : list97 | cons97 : Set -> list97 -> list97.
+Inductive list98 : Set := nil98 : list98 | cons98 : Set -> list98 -> list98.
+Inductive list99 : Set := nil99 : list99 | cons99 : Set -> list99 -> list99.
diff --git a/test-suite/bench/lists_100.v b/test-suite/bench/lists_100.v
new file mode 100644
index 00000000..4accbf34
--- /dev/null
+++ b/test-suite/bench/lists_100.v
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Inductive list0 : Set := nil0 : list0 | cons0 : Set -> list0 -> list0.
+Inductive list1 : Set := nil1 : list1 | cons1 : Set -> list1 -> list1.
+Inductive list2 : Set := nil2 : list2 | cons2 : Set -> list2 -> list2.
+Inductive list3 : Set := nil3 : list3 | cons3 : Set -> list3 -> list3.
+Inductive list4 : Set := nil4 : list4 | cons4 : Set -> list4 -> list4.
+Inductive list5 : Set := nil5 : list5 | cons5 : Set -> list5 -> list5.
+Inductive list6 : Set := nil6 : list6 | cons6 : Set -> list6 -> list6.
+Inductive list7 : Set := nil7 : list7 | cons7 : Set -> list7 -> list7.
+Inductive list8 : Set := nil8 : list8 | cons8 : Set -> list8 -> list8.
+Inductive list9 : Set := nil9 : list9 | cons9 : Set -> list9 -> list9.
+Inductive list10 : Set := nil10 : list10 | cons10 : Set -> list10 -> list10.
+Inductive list11 : Set := nil11 : list11 | cons11 : Set -> list11 -> list11.
+Inductive list12 : Set := nil12 : list12 | cons12 : Set -> list12 -> list12.
+Inductive list13 : Set := nil13 : list13 | cons13 : Set -> list13 -> list13.
+Inductive list14 : Set := nil14 : list14 | cons14 : Set -> list14 -> list14.
+Inductive list15 : Set := nil15 : list15 | cons15 : Set -> list15 -> list15.
+Inductive list16 : Set := nil16 : list16 | cons16 : Set -> list16 -> list16.
+Inductive list17 : Set := nil17 : list17 | cons17 : Set -> list17 -> list17.
+Inductive list18 : Set := nil18 : list18 | cons18 : Set -> list18 -> list18.
+Inductive list19 : Set := nil19 : list19 | cons19 : Set -> list19 -> list19.
+Inductive list20 : Set := nil20 : list20 | cons20 : Set -> list20 -> list20.
+Inductive list21 : Set := nil21 : list21 | cons21 : Set -> list21 -> list21.
+Inductive list22 : Set := nil22 : list22 | cons22 : Set -> list22 -> list22.
+Inductive list23 : Set := nil23 : list23 | cons23 : Set -> list23 -> list23.
+Inductive list24 : Set := nil24 : list24 | cons24 : Set -> list24 -> list24.
+Inductive list25 : Set := nil25 : list25 | cons25 : Set -> list25 -> list25.
+Inductive list26 : Set := nil26 : list26 | cons26 : Set -> list26 -> list26.
+Inductive list27 : Set := nil27 : list27 | cons27 : Set -> list27 -> list27.
+Inductive list28 : Set := nil28 : list28 | cons28 : Set -> list28 -> list28.
+Inductive list29 : Set := nil29 : list29 | cons29 : Set -> list29 -> list29.
+Inductive list30 : Set := nil30 : list30 | cons30 : Set -> list30 -> list30.
+Inductive list31 : Set := nil31 : list31 | cons31 : Set -> list31 -> list31.
+Inductive list32 : Set := nil32 : list32 | cons32 : Set -> list32 -> list32.
+Inductive list33 : Set := nil33 : list33 | cons33 : Set -> list33 -> list33.
+Inductive list34 : Set := nil34 : list34 | cons34 : Set -> list34 -> list34.
+Inductive list35 : Set := nil35 : list35 | cons35 : Set -> list35 -> list35.
+Inductive list36 : Set := nil36 : list36 | cons36 : Set -> list36 -> list36.
+Inductive list37 : Set := nil37 : list37 | cons37 : Set -> list37 -> list37.
+Inductive list38 : Set := nil38 : list38 | cons38 : Set -> list38 -> list38.
+Inductive list39 : Set := nil39 : list39 | cons39 : Set -> list39 -> list39.
+Inductive list40 : Set := nil40 : list40 | cons40 : Set -> list40 -> list40.
+Inductive list41 : Set := nil41 : list41 | cons41 : Set -> list41 -> list41.
+Inductive list42 : Set := nil42 : list42 | cons42 : Set -> list42 -> list42.
+Inductive list43 : Set := nil43 : list43 | cons43 : Set -> list43 -> list43.
+Inductive list44 : Set := nil44 : list44 | cons44 : Set -> list44 -> list44.
+Inductive list45 : Set := nil45 : list45 | cons45 : Set -> list45 -> list45.
+Inductive list46 : Set := nil46 : list46 | cons46 : Set -> list46 -> list46.
+Inductive list47 : Set := nil47 : list47 | cons47 : Set -> list47 -> list47.
+Inductive list48 : Set := nil48 : list48 | cons48 : Set -> list48 -> list48.
+Inductive list49 : Set := nil49 : list49 | cons49 : Set -> list49 -> list49.
+Inductive list50 : Set := nil50 : list50 | cons50 : Set -> list50 -> list50.
+Inductive list51 : Set := nil51 : list51 | cons51 : Set -> list51 -> list51.
+Inductive list52 : Set := nil52 : list52 | cons52 : Set -> list52 -> list52.
+Inductive list53 : Set := nil53 : list53 | cons53 : Set -> list53 -> list53.
+Inductive list54 : Set := nil54 : list54 | cons54 : Set -> list54 -> list54.
+Inductive list55 : Set := nil55 : list55 | cons55 : Set -> list55 -> list55.
+Inductive list56 : Set := nil56 : list56 | cons56 : Set -> list56 -> list56.
+Inductive list57 : Set := nil57 : list57 | cons57 : Set -> list57 -> list57.
+Inductive list58 : Set := nil58 : list58 | cons58 : Set -> list58 -> list58.
+Inductive list59 : Set := nil59 : list59 | cons59 : Set -> list59 -> list59.
+Inductive list60 : Set := nil60 : list60 | cons60 : Set -> list60 -> list60.
+Inductive list61 : Set := nil61 : list61 | cons61 : Set -> list61 -> list61.
+Inductive list62 : Set := nil62 : list62 | cons62 : Set -> list62 -> list62.
+Inductive list63 : Set := nil63 : list63 | cons63 : Set -> list63 -> list63.
+Inductive list64 : Set := nil64 : list64 | cons64 : Set -> list64 -> list64.
+Inductive list65 : Set := nil65 : list65 | cons65 : Set -> list65 -> list65.
+Inductive list66 : Set := nil66 : list66 | cons66 : Set -> list66 -> list66.
+Inductive list67 : Set := nil67 : list67 | cons67 : Set -> list67 -> list67.
+Inductive list68 : Set := nil68 : list68 | cons68 : Set -> list68 -> list68.
+Inductive list69 : Set := nil69 : list69 | cons69 : Set -> list69 -> list69.
+Inductive list70 : Set := nil70 : list70 | cons70 : Set -> list70 -> list70.
+Inductive list71 : Set := nil71 : list71 | cons71 : Set -> list71 -> list71.
+Inductive list72 : Set := nil72 : list72 | cons72 : Set -> list72 -> list72.
+Inductive list73 : Set := nil73 : list73 | cons73 : Set -> list73 -> list73.
+Inductive list74 : Set := nil74 : list74 | cons74 : Set -> list74 -> list74.
+Inductive list75 : Set := nil75 : list75 | cons75 : Set -> list75 -> list75.
+Inductive list76 : Set := nil76 : list76 | cons76 : Set -> list76 -> list76.
+Inductive list77 : Set := nil77 : list77 | cons77 : Set -> list77 -> list77.
+Inductive list78 : Set := nil78 : list78 | cons78 : Set -> list78 -> list78.
+Inductive list79 : Set := nil79 : list79 | cons79 : Set -> list79 -> list79.
+Inductive list80 : Set := nil80 : list80 | cons80 : Set -> list80 -> list80.
+Inductive list81 : Set := nil81 : list81 | cons81 : Set -> list81 -> list81.
+Inductive list82 : Set := nil82 : list82 | cons82 : Set -> list82 -> list82.
+Inductive list83 : Set := nil83 : list83 | cons83 : Set -> list83 -> list83.
+Inductive list84 : Set := nil84 : list84 | cons84 : Set -> list84 -> list84.
+Inductive list85 : Set := nil85 : list85 | cons85 : Set -> list85 -> list85.
+Inductive list86 : Set := nil86 : list86 | cons86 : Set -> list86 -> list86.
+Inductive list87 : Set := nil87 : list87 | cons87 : Set -> list87 -> list87.
+Inductive list88 : Set := nil88 : list88 | cons88 : Set -> list88 -> list88.
+Inductive list89 : Set := nil89 : list89 | cons89 : Set -> list89 -> list89.
+Inductive list90 : Set := nil90 : list90 | cons90 : Set -> list90 -> list90.
+Inductive list91 : Set := nil91 : list91 | cons91 : Set -> list91 -> list91.
+Inductive list92 : Set := nil92 : list92 | cons92 : Set -> list92 -> list92.
+Inductive list93 : Set := nil93 : list93 | cons93 : Set -> list93 -> list93.
+Inductive list94 : Set := nil94 : list94 | cons94 : Set -> list94 -> list94.
+Inductive list95 : Set := nil95 : list95 | cons95 : Set -> list95 -> list95.
+Inductive list96 : Set := nil96 : list96 | cons96 : Set -> list96 -> list96.
+Inductive list97 : Set := nil97 : list97 | cons97 : Set -> list97 -> list97.
+Inductive list98 : Set := nil98 : list98 | cons98 : Set -> list98 -> list98.
+Inductive list99 : Set := nil99 : list99 | cons99 : Set -> list99 -> list99.
diff --git a/test-suite/check b/test-suite/check
new file mode 100755
index 00000000..1c7822d1
--- /dev/null
+++ b/test-suite/check
@@ -0,0 +1,129 @@
+#!/bin/sh
+
+# Automatic test of Coq
+
+if [ "$1" = -byte ]; then
+  command7="../bin/coqtop.byte -translate -q -batch -load-vernac-source"
+else
+  command7="../bin/coqtop -translate -q -batch -load-vernac-source"
+fi
+
+if [ "$1" = -byte ]; then
+  command="../bin/coqtop.byte -q -batch -load-vernac-source"
+else
+  command="../bin/coqtop -q -batch -load-vernac-source"
+fi
+
+# on compte le nombre de tests et de succès
+nbtests=0
+nbtestsok=0
+
+# La fonction suivante teste le compilateur sur des fichiers qu'il doit
+# accepter
+test_success() {
+    for f in $1/*.v; do 
+	nbtests=`expr $nbtests + 1`
+	printf "    "$f"..."
+	$command7 $f > /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
+        else 
+	    echo "V7 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
+# refuser
+test_failure() {
+    for f in $1/*.v; do 
+	nbtests=`expr $nbtests + 1`
+	printf "    "$f"..."
+	$command7 $f > /dev/null 2>&1
+	if [ $? != 0 ]; then 
+	    echo "Ok"
+	    nbtestsok=`expr $nbtestsok + 1`
+        else 
+	    echo "Error! (should be rejected)"
+        fi 
+    done
+}
+
+# La fonction suivante teste la sortie des fichiers qu'elle exécute 
+test_output() {
+    for f in $1/*.v; do 
+	nbtests=`expr $nbtests + 1`
+	printf "    "$f"..."
+        tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`
+	$command7 $f | tail +3 > $tmpoutput 2>&1
+        foutput=`dirname $f`/`basename $f .v`.out
+        diff $tmpoutput $foutput > /dev/null
+	if [ $? = 0 ]; then 
+	    echo "Ok"
+	    nbtestsok=`expr $nbtestsok + 1`
+        else 
+	    echo "Error! (unexpected output)"
+        fi 
+    done
+}
+
+# La fonction suivante teste l'analyseur syntaxique fournit par "parser"
+# Elle fonctionne comme test_output
+test_parser() {
+    if [ -d $1 ]; then
+    for f in $1/*.v; do
+        nbtests=`expr $nbtests + 1`
+        printf "    "$f"..."
+        tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`
+        foutput=`dirname $f`/`basename $f .v`.out
+        echo "parse_file 1 \"$f\"" | ../bin/parser > $tmpoutput 2>&1
+        perl -ne 'if(/Starting.*Parser Loop/){$printit = 1};print if $printit' \
+            $tmpoutput | grep -i error > /dev/null
+        if [ $? = 0 ] ; then
+            echo "Error! (unexpected output)"
+        else
+            echo "Ok"
+            nbtestsok=`expr $nbtestsok + 1`
+        fi
+    done
+    fi
+}
+
+# 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 "Parser tests"
+test_parser parser
+pourcentage=`expr 100 \* $nbtestsok / $nbtests`
+echo
+echo "$nbtestsok tests passed over $nbtests, i.e. $pourcentage %"
+
+
+
diff --git a/test-suite/failure/Case1.v b/test-suite/failure/Case1.v
new file mode 100644
index 00000000..fafcafc1
--- /dev/null
+++ b/test-suite/failure/Case1.v
@@ -0,0 +1 @@
+Type Cases O of x => O | O => (S O) end.
diff --git a/test-suite/failure/Case10.v b/test-suite/failure/Case10.v
new file mode 100644
index 00000000..ee47544d
--- /dev/null
+++ b/test-suite/failure/Case10.v
@@ -0,0 +1 @@
+Type [x:nat]<nat> Cases x  of ((S x) as b) => (S b) end.
diff --git a/test-suite/failure/Case11.v b/test-suite/failure/Case11.v
new file mode 100644
index 00000000..c39a76ca
--- /dev/null
+++ b/test-suite/failure/Case11.v
@@ -0,0 +1 @@
+Type [x:nat]<nat> Cases x  of ((S x) as b) => (S b x) end.
diff --git a/test-suite/failure/Case12.v b/test-suite/failure/Case12.v
new file mode 100644
index 00000000..b56eac0d
--- /dev/null
+++ b/test-suite/failure/Case12.v
@@ -0,0 +1,7 @@
+
+Type [x:nat]<nat> Cases x  of 
+                  ((S x) as b) => <nat>Cases x  of
+                                        x => x 
+                                   end
+                          end.
+
diff --git a/test-suite/failure/Case13.v b/test-suite/failure/Case13.v
new file mode 100644
index 00000000..8a4d75b6
--- /dev/null
+++ b/test-suite/failure/Case13.v
@@ -0,0 +1,5 @@
+Type [x:nat]<nat> Cases x  of 
+                  ((S x) as b) => <nat>Cases x  of
+                                        x => (S b x)
+                                   end
+                          end.
diff --git a/test-suite/failure/Case14.v b/test-suite/failure/Case14.v
new file mode 100644
index 00000000..a198d068
--- /dev/null
+++ b/test-suite/failure/Case14.v
@@ -0,0 +1,8 @@
+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.
diff --git a/test-suite/failure/Case15.v b/test-suite/failure/Case15.v
new file mode 100644
index 00000000..a27b07f8
--- /dev/null
+++ b/test-suite/failure/Case15.v
@@ -0,0 +1,6 @@
+(* 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
diff --git a/test-suite/failure/Case16.v b/test-suite/failure/Case16.v
new file mode 100644
index 00000000..f994a8f2
--- /dev/null
+++ b/test-suite/failure/Case16.v
@@ -0,0 +1,9 @@
+(* 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.
diff --git a/test-suite/failure/Case2.v b/test-suite/failure/Case2.v
new file mode 100644
index 00000000..183f612b
--- /dev/null
+++ b/test-suite/failure/Case2.v
@@ -0,0 +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.
+
diff --git a/test-suite/failure/Case3.v b/test-suite/failure/Case3.v
new file mode 100644
index 00000000..2c651b87
--- /dev/null
+++ b/test-suite/failure/Case3.v
@@ -0,0 +1,7 @@
+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.
diff --git a/test-suite/failure/Case4.v b/test-suite/failure/Case4.v
new file mode 100644
index 00000000..d00c9a05
--- /dev/null
+++ b/test-suite/failure/Case4.v
@@ -0,0 +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.
diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v
new file mode 100644
index 00000000..bdb5544b
--- /dev/null
+++ b/test-suite/failure/Case5.v
@@ -0,0 +1,3 @@
+Inductive MS: Set := X:MS->MS | Y:MS->MS.
+ 
+Type  [p:MS]<nat>Cases p of (X x) => O end.
diff --git a/test-suite/failure/Case6.v b/test-suite/failure/Case6.v
new file mode 100644
index 00000000..f588d275
--- /dev/null
+++ b/test-suite/failure/Case6.v
@@ -0,0 +1,10 @@
+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.
+
diff --git a/test-suite/failure/Case7.v b/test-suite/failure/Case7.v
new file mode 100644
index 00000000..3718f198
--- /dev/null
+++ b/test-suite/failure/Case7.v
@@ -0,0 +1,22 @@
+Inductive listn : nat-> Set := 
+  niln : (listn O) 
+| consn : (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.
+
diff --git a/test-suite/failure/Case8.v b/test-suite/failure/Case8.v
new file mode 100644
index 00000000..7f6bb615
--- /dev/null
+++ b/test-suite/failure/Case8.v
@@ -0,0 +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.
+
diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v
new file mode 100644
index 00000000..e8d8e89a
--- /dev/null
+++ b/test-suite/failure/Case9.v
@@ -0,0 +1,6 @@
+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.
+
diff --git a/test-suite/failure/ClearBody.v b/test-suite/failure/ClearBody.v
new file mode 100644
index 00000000..ca8e3c68
--- /dev/null
+++ b/test-suite/failure/ClearBody.v
@@ -0,0 +1,8 @@
+(* ClearBody must check that removing the body of definition does not
+   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.
diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v
new file mode 100644
index 00000000..fb9a27bb
--- /dev/null
+++ b/test-suite/failure/Tauto.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(**** Tactics Tauto and Intuition ****)
+
+(**** Tauto:
+  Tactic for automating proof in Intuionnistic Propositional Calculus, based on
+  the contraction-free LJT of Dickhoff ****)
+
+(**** Intuition:
+  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).
+Proof.
+  Tauto.
diff --git a/test-suite/failure/cases.v b/test-suite/failure/cases.v
new file mode 100644
index 00000000..a27b07f8
--- /dev/null
+++ b/test-suite/failure/cases.v
@@ -0,0 +1,6 @@
+(* 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
diff --git a/test-suite/failure/check.v b/test-suite/failure/check.v
new file mode 100644
index 00000000..0bf7091c
--- /dev/null
+++ b/test-suite/failure/check.v
@@ -0,0 +1,3 @@
+Implicits eq [1].
+
+Check (eq bool true).
diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v
new file mode 100644
index 00000000..56cd73f4
--- /dev/null
+++ b/test-suite/failure/clash_cons.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* Teste la verification d'unicite des noms de constr *)
+
+
+Inductive X : Set := 
+    cons : X.
+
+Inductive Y : Set := 
+    cons : Y.
+
diff --git a/test-suite/failure/clashes.v b/test-suite/failure/clashes.v
new file mode 100644
index 00000000..fcfd29fe
--- /dev/null
+++ b/test-suite/failure/clashes.v
@@ -0,0 +1,8 @@
+(* Submitted by David Nowak *)
+
+(* Simpler to forbid the definition of n as a global than to write it
+   S.n to keep n accessible... *)
+
+Section S.
+Variable n:nat.
+Inductive P : Set := n : P.
diff --git a/test-suite/failure/coqbugs0266.v b/test-suite/failure/coqbugs0266.v
new file mode 100644
index 00000000..2ac6c4f0
--- /dev/null
+++ b/test-suite/failure/coqbugs0266.v
@@ -0,0 +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.
diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v
new file mode 100644
index 00000000..742e9774
--- /dev/null
+++ b/test-suite/failure/fixpoint1.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      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
diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v
new file mode 100644
index 00000000..aff43ff1
--- /dev/null
+++ b/test-suite/failure/illtype1.v
@@ -0,0 +1,8 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Check (S S).
diff --git a/test-suite/failure/ltac1.v b/test-suite/failure/ltac1.v
new file mode 100644
index 00000000..d0256619
--- /dev/null
+++ b/test-suite/failure/ltac1.v
@@ -0,0 +1,5 @@
+(* Check all variables are different in a Context *)
+Tactic Definition X := Match Context With [ x:?; x:? |- ? ] -> Apply x.
+Goal True->True->True.
+Intros.
+X.
diff --git a/test-suite/failure/ltac2.v b/test-suite/failure/ltac2.v
new file mode 100644
index 00000000..55925a7a
--- /dev/null
+++ b/test-suite/failure/ltac2.v
@@ -0,0 +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" *)
diff --git a/test-suite/failure/ltac3.v b/test-suite/failure/ltac3.v
new file mode 100644
index 00000000..bfccc546
--- /dev/null
+++ b/test-suite/failure/ltac3.v
@@ -0,0 +1,2 @@
+(* Proposed by Benjamin *)
+Definition A := Try REflexivity.
diff --git a/test-suite/failure/ltac4.v b/test-suite/failure/ltac4.v
new file mode 100644
index 00000000..d1e4e892
--- /dev/null
+++ b/test-suite/failure/ltac4.v
@@ -0,0 +1,4 @@
+(* Check static globalisation of tactic names *)
+(* Proposed by Benjamin (mars 2002) *)
+Goal (n:nat)n=n.
+Induction n; Try REflexivity.
diff --git a/test-suite/failure/params_ind.v b/test-suite/failure/params_ind.v
new file mode 100644
index 00000000..20689128
--- /dev/null
+++ b/test-suite/failure/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/failure/positivity.v b/test-suite/failure/positivity.v
new file mode 100644
index 00000000..b43eb899
--- /dev/null
+++ b/test-suite/failure/positivity.v
@@ -0,0 +1,8 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Inductive t:Set := c: (t -> nat) -> t.
diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v
new file mode 100644
index 00000000..8f3aedac
--- /dev/null
+++ b/test-suite/failure/redef.v
@@ -0,0 +1,9 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Definition toto := Set.
+Definition toto := Set.
diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v
new file mode 100644
index 00000000..e8ca8494
--- /dev/null
+++ b/test-suite/failure/search.v
@@ -0,0 +1,8 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+SearchPattern ? = ? outside n_existe_pas.
diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v
new file mode 100644
index 00000000..01d46133
--- /dev/null
+++ b/test-suite/failure/universes-buraliforti.v
@@ -0,0 +1,227 @@
+(* Check that Burali-Forti paradox does not go through *)
+
+(* Source: contrib/Rocq/PARADOX/{Logics,BuraliForti},v *)
+
+(* 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).
+
+  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.
+
+  Definition WF := [A:Type][R:A->A->Prop](x:A)(ACC A R x).
+
+
+Section Inverse_Image.
+
+  Variables A,B:Type; R:B->B->Prop; f:A->B.
+
+  Definition 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).
+    Induction 1; Intros.
+    Constructor; Intros.
+    Apply (H1 (f y0)); Trivial.
+    Elim H2 using eqT_ind_r; Trivial.
+    Save.
+
+  Lemma ACC_inverse_image : (x:A)(ACC B R (f x)) -> (ACC A Rof x).
+    Intros; Apply (ACC_lemma (f x)); Trivial.
+    Save.
+
+  Lemma WF_inverse_image: (WF B R)->(WF A Rof).
+    Red; Intros; Apply ACC_inverse_image; Auto.
+    Save.
+
+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]
+    (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  : (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)).
+
+  (* 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.
+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.
+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.
+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; Trivial.
+
+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)).
+
+  (* 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.
+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.
+
+
+  (* 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' *)
+
+
+  (* 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.
+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-sections1.v b/test-suite/failure/universes-sections1.v
new file mode 100644
index 00000000..c4eef34b
--- /dev/null
+++ b/test-suite/failure/universes-sections1.v
@@ -0,0 +1,8 @@
+(* Check that constraints on definitions are preserved by discharging *)
+
+Section A.
+  Definition Type2 := Type.
+  Definition Type1 := Type : Type2.
+End A.
+
+Definition Inconsistency := Type2 : Type1.
diff --git a/test-suite/failure/universes-sections2.v b/test-suite/failure/universes-sections2.v
new file mode 100644
index 00000000..1872dac1
--- /dev/null
+++ b/test-suite/failure/universes-sections2.v
@@ -0,0 +1,10 @@
+(* Check that constraints on locals are preserved by discharging *)
+
+Definition Type2 := Type.
+
+Section A.
+  Local Type1 := Type : Type2.
+  Definition Type1' := Type1.
+End A.
+
+Definition Inconsistency := Type2 : Type1'.
diff --git a/test-suite/failure/universes.v b/test-suite/failure/universes.v
new file mode 100644
index 00000000..6fada6f1
--- /dev/null
+++ b/test-suite/failure/universes.v
@@ -0,0 +1,3 @@
+Definition Type2 := Type.
+Definition Type1 := Type : Type2.
+Definition Inconsistency := Type2 : Type1.
diff --git a/test-suite/failure/universes2.v b/test-suite/failure/universes2.v
new file mode 100644
index 00000000..a6c8ba43
--- /dev/null
+++ b/test-suite/failure/universes2.v
@@ -0,0 +1,5 @@
+(* Example submitted by Randy Pollack *)
+
+Parameter K: (T:Type)T->T.
+Check (K ((T:Type)T->T) K).
+(* Universe Inconsistency *)
diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v
new file mode 100644
index 00000000..bba356f2
--- /dev/null
+++ b/test-suite/ideal-features/Apply.v
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 needs unification on type *)
+
+Goal (n,m:nat)(eq nat (S m) (S n)).
+Intros.
+Apply f_equal.
+
+(* 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 *)
+
+
+(* This needs step by step unfolding *)
+
+Fixpoint T [n:nat] : Prop := Cases n of O => True | (S p) => n=n->(T p) end.
+Require Arith.
+
+Goal (T (3))->(T (1)).
+Intro H.
+Apply H.
diff --git a/test-suite/ideal-features/Case3.v b/test-suite/ideal-features/Case3.v
new file mode 100644
index 00000000..e9dba1e3
--- /dev/null
+++ b/test-suite/ideal-features/Case3.v
@@ -0,0 +1,28 @@
+Inductive Le : nat->nat->Set :=
+  LeO: (n:nat)(Le O n) 
+| LeS: (n,m:nat)(Le n m) -> (Le (S n) (S m)).
+
+Parameter iguales : (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) (S y) H) => (iguales (S x) (S y) H)
+                       | _ => False end.
+
+
+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)))
+ 
+  end.
+
diff --git a/test-suite/ideal-features/Case4.v b/test-suite/ideal-features/Case4.v
new file mode 100644
index 00000000..d8f14a4e
--- /dev/null
+++ b/test-suite/ideal-features/Case4.v
@@ -0,0 +1,39 @@
+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.
+
diff --git a/test-suite/ideal-features/Case8.v b/test-suite/ideal-features/Case8.v
new file mode 100644
index 00000000..73b55028
--- /dev/null
+++ b/test-suite/ideal-features/Case8.v
@@ -0,0 +1,40 @@
+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.
diff --git a/test-suite/kernel/inds.mv b/test-suite/kernel/inds.mv
new file mode 100644
index 00000000..bd1cc49f
--- /dev/null
+++ b/test-suite/kernel/inds.mv
@@ -0,0 +1,3 @@
+Inductive [] nat : Set := O : nat | S : nat->nat.
+Check Construct nat 0 1.
+Check Construct nat 0 2.
diff --git a/test-suite/modules/Demo.v b/test-suite/modules/Demo.v
new file mode 100644
index 00000000..1e9273f0
--- /dev/null
+++ b/test-suite/modules/Demo.v
@@ -0,0 +1,55 @@
+Module M.
+  Definition t:=nat.
+  Definition x:=O.
+End M.
+
+Print M.t.
+
+
+Module Type SIG.
+  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.
+  Defined.
+  Definition y:=X.x.
+End F.
+
+
+Module N := F M.
+
+Print N.t.
+Eval Compute in N.t.
+
+
+Module N' : SIG := N.
+
+Print N'.t.
+Eval Compute in N'.t.
+
+
+Module N'' <: SIG := F N.
+
+Print N''.t.
+Eval Compute in N''.t.
+
+Eval Compute in N''.x.
+
+
+Module N''' : SIG with Definition t:=nat->nat  :=  N.
+
+Print N'''.t.
+Eval Compute in N'''.t.
+
+Print N'''.x.
+
+
+Import N'''.
+
+Print t.
\ No newline at end of file
diff --git a/test-suite/modules/Nametab.v b/test-suite/modules/Nametab.v
new file mode 100644
index 00000000..61966c7c
--- /dev/null
+++ b/test-suite/modules/Nametab.v
@@ -0,0 +1,48 @@
+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
new file mode 100644
index 00000000..d3e98ae4
--- /dev/null
+++ b/test-suite/modules/Nat.v
@@ -0,0 +1,19 @@
+Definition T:=nat.
+
+Definition le:=Peano.le.
+
+Hints Unfold le.
+
+Lemma le_refl:(n:nat)(le n n).
+  Auto.
+Qed.
+
+Require Le.
+
+Lemma le_trans:(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.
diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v
new file mode 100644
index 00000000..9ba3fb2e
--- /dev/null
+++ b/test-suite/modules/PO.v
@@ -0,0 +1,57 @@
+Implicit Arguments On.
+
+Implicits fst.
+Implicits snd.
+
+Module Type PO.
+  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).
+  
+  Hints 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)).
+
+  Hints Unfold le.
+
+  Lemma le_refl : (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.
+  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.
+
+    Info Auto.
+
+    Info Auto.
+  Qed.
+
+End Pair.
+
+
+
+Read Module Nat.
+
+Module NN := Pair Nat Nat.
+
+Lemma zz_min : (p:NN.T)(NN.le (O,O) p).
+  Info Auto with arith.
+Qed.
diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v
new file mode 100644
index 00000000..4f4c2066
--- /dev/null
+++ b/test-suite/modules/Przyklad.v
@@ -0,0 +1,193 @@
+Definition ifte := [T:Set][A:Prop][B:Prop][s:(sumbool A B)][th:T][el:T] 
+	   	   if s then [_]th else [_]el.
+
+Implicits 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.
+
+Intro.
+Absurd a=a; Auto.
+
+Save.
+
+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.
+
+Intro.
+Split with b0; Reflexivity.
+
+Save.
+
+Module Type ELEM.
+  Parameter T : Set.
+  Parameter eq_dec : (a,a':T){a=a'}+{~ a=a'}.
+End ELEM.
+                                        
+Module Type SET[Elt : ELEM].
+  Parameter T : Set.
+  Parameter empty : T.
+  Parameter add : Elt.T -> T -> T.
+  Parameter find : Elt.T -> T -> bool.
+
+  (* Axioms *)
+
+  Axiom find_empty_false : 
+      (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_false :
+        (s:T) (e:Elt.T) (e':Elt.T) ~(e=e') -> 
+	(find e (add e' s))=(find e s).
+
+End SET.
+
+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)).
+
+  Lemma find_empty_false : (e:E.T) (find e empty) = false.
+    Auto.
+  Qed.
+
+  Lemma find_add_true : 
+        (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.
+
+  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.
+
+  Qed.
+
+End FuncDict.
+
+Module F : SET := FuncDict.
+
+
+Module Nat.
+  Definition T:=nat.
+  Lemma eq_dec :  (a,a':T){a=a'}+{~ a=a'}.
+    Decide Equality.
+  Qed.
+End Nat.
+
+
+Module SetNat:=F Nat. 
+
+
+Lemma no_zero_in_empty:(SetNat.find O SetNat.empty)=false. 
+Apply SetNat.find_empty_false. 
+Save.
+
+(***************************************************************************)
+Module Lemmas[G:SET][E:ELEM].
+
+  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). 
+  
+    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.
+End Lemmas.
+
+
+Inductive list [A:Set] : Set := nil : (list A) 
+                             | cons : A -> (list A) -> (list A).
+
+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.
+
+  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.    
+  
+
+End ListDict.
+
+
+Module L : SET := ListDict.
+
+
+
+
+
+
+
+
diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v
new file mode 100644
index 00000000..13c28418
--- /dev/null
+++ b/test-suite/modules/Tescik.v
@@ -0,0 +1,30 @@
+
+Module Type ELEM.
+  Parameter A:Set.
+  Parameter x:A.
+End ELEM.
+
+Module Nat.
+    Definition A:=nat.
+    Definition x:=O.
+End Nat. 
+
+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 singl := [x:X.A] (cons x nil).
+  
+  Lemma head_singl : (x:X.A)(head (singl x))=x.
+  Auto.
+  Qed.
+
+End List.
+
+Module N:=(List Nat).
diff --git a/test-suite/modules/fun_objects.v b/test-suite/modules/fun_objects.v
new file mode 100644
index 00000000..0f8eef84
--- /dev/null
+++ b/test-suite/modules/fun_objects.v
@@ -0,0 +1,32 @@
+Implicit Arguments On.
+
+Module Type SIG.
+  Parameter id:(A:Set)A->A.
+End SIG.
+ 
+Module M[X:SIG].
+  Definition idid := (X.id X.id).
+  Definition id := (idid X.id).
+End M.
+
+Module N:=M.
+
+Module Nat.
+  Definition T := nat.
+  Definition x := O.
+  Definition id := [A:Set][x:A]x.
+End Nat.
+
+Module Z:=(N Nat).
+
+Check (Z.idid O).
+
+Module P[Y:SIG] := N.
+
+Module Y:=P Nat Z.
+
+Check (Y.id O).
+
+
+
+
diff --git a/test-suite/modules/grammar.v b/test-suite/modules/grammar.v
new file mode 100644
index 00000000..fb734b5d
--- /dev/null
+++ b/test-suite/modules/grammar.v
@@ -0,0 +1,15 @@
+Module N.
+Definition f:=plus.
+Syntax constr level 7: plus [ (f $n $m)] -> [ $n:L "+" $m:E].
+Check (f O O).
+End N.
+Check (N.f O O).
+Import N.
+Check (N.f O O).
+Check (f O O).
+Module M:=N.
+Check (f O O).
+Check (N.f O O).
+Import M.
+Check (f O O).
+Check (N.f O O).
diff --git a/test-suite/modules/ind.v b/test-suite/modules/ind.v
new file mode 100644
index 00000000..94c344bb
--- /dev/null
+++ b/test-suite/modules/ind.v
@@ -0,0 +1,13 @@
+Module Type SIG.
+  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.
+End M.
+
+Module N:=M.
+
+Check (N.f M.A).
diff --git a/test-suite/modules/mod_decl.v b/test-suite/modules/mod_decl.v
new file mode 100644
index 00000000..867b8a11
--- /dev/null
+++ b/test-suite/modules/mod_decl.v
@@ -0,0 +1,55 @@
+Module Type SIG.
+  Definition A:Set. (*error*)
+  Axiom A:Set.
+End SIG.
+
+Module M0.
+  Definition A:Set.
+  Exact nat.
+  Save.
+End M0.
+
+Module M1:SIG.
+  Definition A:=nat.
+End M1.
+
+Module M2<:SIG.
+  Definition A:=nat.
+End M2.
+
+Module M3:=M0.
+
+Module M4:SIG:=M0.
+
+Module M5<:SIG:=M0.
+
+
+Module F[X:SIG]:=X.
+
+
+Declare Module M6.
+
+
+Module Type T.
+
+  Declare Module M0.
+    Lemma A:Set (*error*).
+    Axiom A:Set.
+  End M0.
+  
+  Declare Module M1:SIG.
+  
+  Declare Module M2<:SIG.
+    Definition A:=nat.
+  End M2.
+  
+  Declare Module M3:=M0.
+  
+  Declare Module M4:SIG:=M0.  (* error *)
+  
+  Declare Module M5<:SIG:=M0.
+
+  Declare Module M6:=F M0. (* error *)
+
+  Module M7.
+End T.
\ No newline at end of file
diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v
new file mode 100644
index 00000000..73448dc7
--- /dev/null
+++ b/test-suite/modules/modeq.v
@@ -0,0 +1,22 @@
+Module M.
+  Definition T:=nat.
+  Definition x:T:=O.
+End M.
+
+Module Type SIG.
+  Declare Module M:=Top.M.
+  Module Type SIG.
+    Parameter T:Set.
+  End SIG.
+  Declare Module N:SIG.
+End SIG.
+
+Module Z.
+  Module M:=Top.M.
+  Module Type SIG.
+    Parameter T:Set.
+  End SIG.
+  Module N:=M.
+End Z.
+
+Module A:SIG:=Z.  
diff --git a/test-suite/modules/modul.v b/test-suite/modules/modul.v
new file mode 100644
index 00000000..5612ea75
--- /dev/null
+++ b/test-suite/modules/modul.v
@@ -0,0 +1,39 @@
+Module M.
+  Parameter rel:nat -> nat -> Prop.
+
+  Axiom w : (n:nat)(rel O (S n)).
+
+  Hints Resolve w.
+
+  Grammar constr constr8 := 
+     not_eq [ constr7($a) "#" constr7($b) ] -> [ (rel $a $b) ].
+  
+  Print Hint *.
+
+  Lemma w1 : (O#(S O)).
+  Auto.
+  Save.
+
+End M.
+
+(*Lemma w1 : (M.rel O (S O)).
+Auto.
+*)
+
+Import M.
+
+Print Hint *.
+Lemma w1 : (O#(S O)).
+Print Hint.
+Print Hint *.
+
+Auto.
+Save.
+
+Check (O#O).
+Locate rel.
+
+Locate M.
+
+Module N:=Top.M.
+
diff --git a/test-suite/modules/obj.v b/test-suite/modules/obj.v
new file mode 100644
index 00000000..2231e084
--- /dev/null
+++ b/test-suite/modules/obj.v
@@ -0,0 +1,26 @@
+Implicit Arguments On.
+
+Module M. 
+  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).
+  Module N.
+    Definition apap:=[A,B:Set](app (app 1!A 2!B)).
+    Print app.
+    Print apap.
+  End N.
+  Print N.apap.
+End K.
+
+Print K.app.
+Print K.N.apap.
+
+Module W:=K.N.
+
+Print W.apap.
+
diff --git a/test-suite/modules/objects.v b/test-suite/modules/objects.v
new file mode 100644
index 00000000..418ece44
--- /dev/null
+++ b/test-suite/modules/objects.v
@@ -0,0 +1,33 @@
+Module Type SET.
+  Axiom T:Set.
+  Axiom x:T.
+End SET.
+ 
+Implicit Arguments On.
+
+Module M[X:SET].
+  Definition T := nat.
+  Definition x := O.
+  Definition f := [A:Set][x:A]X.x.
+End M.
+
+Module N:=M.
+
+Module Nat.
+  Definition T := nat.
+  Definition x := O.
+End Nat.
+
+Module Z:=(N Nat).
+
+Check (Z.f O).
+
+Module P[Y:SET] := N.
+
+Module Y:=P Z Nat.
+
+Check (Y.f O).
+
+
+
+
diff --git a/test-suite/modules/pliczek.v b/test-suite/modules/pliczek.v
new file mode 100644
index 00000000..6061ace3
--- /dev/null
+++ b/test-suite/modules/pliczek.v
@@ -0,0 +1,3 @@
+Require Export plik.
+
+Definition tutu := [X:Set](toto X).
diff --git a/test-suite/modules/plik.v b/test-suite/modules/plik.v
new file mode 100644
index 00000000..f1f59df0
--- /dev/null
+++ b/test-suite/modules/plik.v
@@ -0,0 +1,4 @@
+Definition toto:=[x:Set]x.
+
+Grammar constr constr8 := 
+     toto [ "#" constr7($b) ] -> [ (toto $b) ].
diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v
new file mode 100644
index 00000000..eb8736bb
--- /dev/null
+++ b/test-suite/modules/sig.v
@@ -0,0 +1,29 @@
+Module M.
+  Module Type SIG.
+    Parameter T:Set.
+    Parameter x:T.
+  End SIG.
+  Module N:SIG.
+    Definition T:=nat.
+    Definition x:=O.
+  End N.
+End M.
+
+Module N:=M.
+
+Module Type SPRYT.
+  Declare Module N.
+    Definition T:=M.N.T.
+    Parameter x:T.
+  End N.
+End SPRYT.
+
+Module K:SPRYT:=N.  
+Module K':SPRYT:=M.  
+
+Module Type SIG.
+  Definition T:Set:=M.N.T.
+  Parameter x:T.
+End SIG.
+
+Module J:SIG:=M.N.
diff --git a/test-suite/modules/sub_objects.v b/test-suite/modules/sub_objects.v
new file mode 100644
index 00000000..1bd4faef
--- /dev/null
+++ b/test-suite/modules/sub_objects.v
@@ -0,0 +1,33 @@
+Set Implicit Arguments.
+
+
+Module M.
+  Definition id:=[A:Set][x:A]x.
+
+  Module Type SIG.
+    Parameter idid:(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)). 
+  End N.
+
+  Definition zero:=(N.idid O).
+
+End M.
+
+Definition zero := (M.N.idid O).
+Definition jeden := (M.N.inc O).
+
+Module Goly:=M.N.
+
+Definition Gole_zero := (Goly.idid O).
+Definition Goly_jeden := (Goly.inc O).
+
+Module Ubrany : M.SIG := M.N.
+
+Definition Ubrane_zero := (Ubrany.idid O).
+
diff --git a/test-suite/output/Arith.out b/test-suite/output/Arith.out
new file mode 100644
index 00000000..210dd6ad
--- /dev/null
+++ b/test-suite/output/Arith.out
@@ -0,0 +1,4 @@
+[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
new file mode 100644
index 00000000..39989dfc
--- /dev/null
+++ b/test-suite/output/Arith.v
@@ -0,0 +1,2 @@
+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
new file mode 100644
index 00000000..5f13caaf
--- /dev/null
+++ b/test-suite/output/Cases.out
@@ -0,0 +1,4 @@
+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)
diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v
new file mode 100644
index 00000000..7483e8c4
--- /dev/null
+++ b/test-suite/output/Cases.v
@@ -0,0 +1,5 @@
+(* Cases with let-in in constructors types *)
+
+Inductive t : Set := k : [x:=t]x -> x.
+
+Print t_rect.
diff --git a/test-suite/output/Coercions.out b/test-suite/output/Coercions.out
new file mode 100644
index 00000000..63e042d8
--- /dev/null
+++ b/test-suite/output/Coercions.out
@@ -0,0 +1,4 @@
+(P x)
+     : Prop
+(R x x)
+     : Prop
diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v
new file mode 100644
index 00000000..61b69038
--- /dev/null
+++ b/test-suite/output/Coercions.v
@@ -0,0 +1,9 @@
+(* Submitted by Randy Pollack *)
+
+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.
+Check (P x).
+Check (R x x).
diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v
new file mode 100644
index 00000000..270fff4e
--- /dev/null
+++ b/test-suite/output/Fixpoint.v
@@ -0,0 +1,7 @@
+Require PolyList.
+
+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
new file mode 100644
index 00000000..f9cf9efc
--- /dev/null
+++ b/test-suite/output/Implicit.out
@@ -0,0 +1,5 @@
+d2 = [x:nat](d1 1!x)
+     : (x,x0:nat)x0=x ->x0=x
+
+Positions [1; 2] are implicit
+Argument scopes are [nat_scope nat_scope _]
diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v
new file mode 100644
index 00000000..2dea0d18
--- /dev/null
+++ b/test-suite/output/Implicit.v
@@ -0,0 +1,18 @@
+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).
+
+(* Test for V8 printing of implicit by names *)
+Definition d1 [y;x;h:x=y:>nat] := h.
+Definition d2 [x] := (!d1 x).
+
+Print d2.
diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out
new file mode 100644
index 00000000..d7120f89
--- /dev/null
+++ b/test-suite/output/InitSyntax.out
@@ -0,0 +1,6 @@
+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)
+     : Prop
+[b:bool](if b then b else b)
+     : bool->bool
diff --git a/test-suite/output/InitSyntax.v b/test-suite/output/InitSyntax.v
new file mode 100644
index 00000000..90fad371
--- /dev/null
+++ b/test-suite/output/InitSyntax.v
@@ -0,0 +1,4 @@
+(* Soumis par Pierre *)
+Print  sig2.
+Check (EX x:nat|x=x).
+Check [b:bool]if b then b else b.
diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out
new file mode 100644
index 00000000..cadb35c6
--- /dev/null
+++ b/test-suite/output/Intuition.out
@@ -0,0 +1,7 @@
+1 subgoal
+  
+  m : Z
+  n : Z
+  H : `m >= n`
+  ============================
+   `m >= m`
diff --git a/test-suite/output/Intuition.v b/test-suite/output/Intuition.v
new file mode 100644
index 00000000..c0508c90
--- /dev/null
+++ b/test-suite/output/Intuition.v
@@ -0,0 +1,5 @@
+Require ZArith_base.
+Goal (m,n:Z) `m >= n` -> `m >= m` /\ `m >= n`.
+Intros; Intuition.
+Show.
+Abort.
diff --git a/test-suite/output/Nametab.out b/test-suite/output/Nametab.out
new file mode 100644
index 00000000..505821d7
--- /dev/null
+++ b/test-suite/output/Nametab.out
@@ -0,0 +1,28 @@
+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
+Constant Top.Q.N.K.id
+K is not a defined object
+N.K is not a defined object
+Module Top.Q.N.K
+Module Top.Q.N.K
+N is not a defined object
+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
+Constant Top.Q.N.K.id
+Constant Top.Q.N.K.id
+Module Top.Q.N.K
+N.K is not a defined object
+Module Top.Q.N.K
+Module Top.Q.N.K
+N is not a defined object
+Module Top.Q.N
+Module Top.Q.N
+Module Top.Q
+Module Top.Q
diff --git a/test-suite/output/Nametab.v b/test-suite/output/Nametab.v
new file mode 100644
index 00000000..61966c7c
--- /dev/null
+++ b/test-suite/output/Nametab.v
@@ -0,0 +1,48 @@
+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/output/RealSyntax.out b/test-suite/output/RealSyntax.out
new file mode 100644
index 00000000..fa30656b
--- /dev/null
+++ b/test-suite/output/RealSyntax.out
@@ -0,0 +1,4 @@
+``32``
+     : R
+``-31``
+     : R
diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v
new file mode 100644
index 00000000..d976dcc1
--- /dev/null
+++ b/test-suite/output/RealSyntax.v
@@ -0,0 +1,3 @@
+Require Reals.
+Check ``32``.
+Check ``-31``.
diff --git a/test-suite/output/Remark2.out b/test-suite/output/Remark2.out
new file mode 100644
index 00000000..adabc2fe
--- /dev/null
+++ b/test-suite/output/Remark2.out
@@ -0,0 +1 @@
+B.C.t is not a defined object
diff --git a/test-suite/output/Remark2.v b/test-suite/output/Remark2.v
new file mode 100644
index 00000000..e1ef57a0
--- /dev/null
+++ b/test-suite/output/Remark2.v
@@ -0,0 +1,8 @@
+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
new file mode 100644
index 00000000..22422602
--- /dev/null
+++ b/test-suite/output/Sum.out
@@ -0,0 +1,6 @@
+nat+nat+{True}
+     : Set
+{True}+{True}+{True}
+     : Set
+nat+{True}+{True}
+     : Set
diff --git a/test-suite/output/Sum.v b/test-suite/output/Sum.v
new file mode 100644
index 00000000..aceadd12
--- /dev/null
+++ b/test-suite/output/Sum.v
@@ -0,0 +1,3 @@
+Check nat+nat+{True}.
+Check {True}+{True}+{True}.
+Check nat+{True}+{True}.
diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out
new file mode 100644
index 00000000..41e8648b
--- /dev/null
+++ b/test-suite/output/TranspModtype.out
@@ -0,0 +1,10 @@
+TrM.A = M.A
+     : Set
+
+OpM.A = M.A
+     : Set
+
+TrM.B = M.B
+     : Set
+
+*** [ OpM.B : Set ]
diff --git a/test-suite/output/TranspModtype.v b/test-suite/output/TranspModtype.v
new file mode 100644
index 00000000..27b1fb9f
--- /dev/null
+++ b/test-suite/output/TranspModtype.v
@@ -0,0 +1,22 @@
+Module Type SIG.
+  Axiom A:Set.
+  Axiom B:Set.
+End SIG.
+
+Module M:SIG.
+  Definition A:=nat.
+  Definition B:=nat.
+End 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 TrM := TranspId M.
+Module OpM := OpaqueId M.
+
+Print TrM.A.
+Print OpM.A.
+Print TrM.B.
+Print OpM.B.
diff --git a/test-suite/output/ZSyntax.out b/test-suite/output/ZSyntax.out
new file mode 100644
index 00000000..0fdc5b7e
--- /dev/null
+++ b/test-suite/output/ZSyntax.out
@@ -0,0 +1,26 @@
+`32`
+     : 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`
+     : Z
+`0+(inject_nat (plus (0) (0)))`
+     : Z
+`(inject_nat (0)) = 0`
+     : Prop
+`0+(inject_nat (11))`
+     : Z
diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v
new file mode 100644
index 00000000..49442b75
--- /dev/null
+++ b/test-suite/output/ZSyntax.v
@@ -0,0 +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`.
+
+(* Submitted by Pierre Casteran *)
+Require Arith.
+Check (Zplus `0` (inject_nat (11))).
diff --git a/test-suite/output/implicits.out b/test-suite/output/implicits.out
new file mode 100644
index 00000000..e4837199
--- /dev/null
+++ b/test-suite/output/implicits.out
@@ -0,0 +1,4 @@
+(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
new file mode 100644
index 00000000..d7ea7227
--- /dev/null
+++ b/test-suite/output/implicits.v
@@ -0,0 +1,13 @@
+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.v8
new file mode 100644
index 00000000..21a985bc
--- /dev/null
+++ b/test-suite/success/Abstract.v8
@@ -0,0 +1,26 @@
+
+(* Cf coqbugs #546 *)
+
+Require Import Omega.
+
+Section S.
+
+Variables n m : nat.
+Variable H : n<m.
+
+Inductive Dummy : nat -> Set :=
+| Dummy0 : Dummy 0
+| Dummy2 : Dummy 2
+| DummyApp : forall i j, Dummy i -> Dummy j -> Dummy (i+j).
+
+Definition Bug : Dummy (2*n).
+Proof.
+induction n.
+ simpl ; apply Dummy0.
+ replace (2 * S n0) with (2*n0 + 2) ; auto with arith.
+  apply DummyApp. 
+   2:exact Dummy2.
+   apply IHn0 ; abstract omega.
+Defined.
+
+End S.
diff --git a/test-suite/success/Case1.v b/test-suite/success/Case1.v
new file mode 100644
index 00000000..2d5a5134
--- /dev/null
+++ b/test-suite/success/Case1.v
@@ -0,0 +1,15 @@
+(* Testing eta-expansion of elimination predicate *)
+
+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.
+End NATIND2.
+
diff --git a/test-suite/success/Case10.v b/test-suite/success/Case10.v
new file mode 100644
index 00000000..73413c47
--- /dev/null
+++ b/test-suite/success/Case10.v
@@ -0,0 +1,26 @@
+(* ============================================== *)
+(*     To test compilation of dependent case      *)
+(*      Multiple Patterns                         *)
+(* ============================================== *)
+Inductive skel: Type :=
+     PROP: skel
+   | PROD: skel->skel->skel.
+
+Parameter Can : skel -> Type.
+Parameter default_can : (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 [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.
diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v
new file mode 100644
index 00000000..580cd87d
--- /dev/null
+++ b/test-suite/success/Case11.v
@@ -0,0 +1,11 @@
+(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *)
+(* Problème rapporté par Solange Coupet *)
+
+Section A.
+
+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.
+
+End A.
diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v
new file mode 100644
index 00000000..284695f4
--- /dev/null
+++ b/test-suite/success/Case12.v
@@ -0,0 +1,60 @@
+(* This example was proposed by Cuihtlauac ALVARADO *)
+
+Require PolyList.
+
+Fixpoint mult2 [n:nat] : nat :=
+Cases n of
+| O => O
+| (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)))).
+
+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}.
+
+Inductive list' : nat -> Set :=
+| nil' : (list' O)
+| cons' : (n:nat)[m:=(mult2 n)](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))
+  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}.
+
+(* 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 }.
diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v
new file mode 100644
index 00000000..71c9191d
--- /dev/null
+++ b/test-suite/success/Case13.v
@@ -0,0 +1,33 @@
+(* Check coercions in patterns *)
+
+Inductive I : Set :=
+  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.
+
+(* Coercion not at the root of pattern *)
+Check [x]Cases x of (C2 O) => O | _ => O end.
+
+(* Unification and coercions inside patterns *)
+Check [x:(option nat)]Cases x of None => O | (Some O) => O | _ => O 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.
+
+(* Coercions with parameters *)
+Inductive listn : nat-> Set := 
+  niln : (listn O) 
+| consn : (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).
+
+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.
diff --git a/test-suite/success/Case14.v b/test-suite/success/Case14.v
new file mode 100644
index 00000000..edecee79
--- /dev/null
+++ b/test-suite/success/Case14.v
@@ -0,0 +1,16 @@
+(* Test of inference of elimination predicate for "if" *)
+(* submitted by Robert R Schneck *)
+
+Axiom bad : false = true.
+
+Definition try1 : False :=
+  <[b:bool][_:false=b](if b then False else True)>
+  Cases bad of 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.
+
+Definition try3 : False :=
+  <[b:bool][_:false=b](([b':bool] if b' then False else True) b)>
+  Cases bad of refl_equal => I end.
diff --git a/test-suite/success/Case15.v b/test-suite/success/Case15.v
new file mode 100644
index 00000000..22944520
--- /dev/null
+++ b/test-suite/success/Case15.v
@@ -0,0 +1,48 @@
+(* Check compilation of multiple pattern-matching on terms non
+   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).
+
+(* Suggested by Pierre Letouzey (PR#207) *)
+Inductive Boite : Set := 
+  boite : (b:bool)(if b then nat else nat*nat)->Boite. 
+
+Definition test := [B:Boite]<nat>Cases B of 
+  (boite true n) => n 
+| (boite false (n,m)) => (plus n m)
+end.
+
+(* Check lazyness of compilation ... future work
+Inductive I : Set := c : (b:bool)(if b then bool else nat)->I.
+
+Check [x]
+  Cases x of
+    (c (true as y) (true as x)) => (if x then y else true)
+  | (c false O) => true | _ => false
+  end.
+
+Check [x]
+  Cases x of 
+    (c true true) => true
+  | (c false O) => true
+  | _ => false
+  end.
+
+(* Devrait produire ceci mais trouver le type intermediaire est coton ! *)
+Check
+  [x:I]
+   Cases x of
+     (c b y) => 
+      (<[b:bool](if b then bool else nat)->bool>if b
+       then [y](if y then true else false)
+       else [y]Cases y of
+              O => true
+            | (S _) => false
+            end y)
+   end.
+*)
diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v
new file mode 100644
index 00000000..3f142fae
--- /dev/null
+++ b/test-suite/success/Case16.v
@@ -0,0 +1,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.
diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v
new file mode 100644
index 00000000..07d64958
--- /dev/null
+++ b/test-suite/success/Case17.v
@@ -0,0 +1,45 @@
+(* Check the synthesis of predicate from a cast in case of matching of
+   the first component (here [list bool]) of a dependent type (here [sigS])
+   (Simplification of an example from file parsing2.v of the Coq'Art
+    exercises) *)
+
+Require Import PolyList.
+
+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)}.
+
+Axiom HHH : (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)}).
+ 
+(* 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)}).
diff --git a/test-suite/success/Case2.v b/test-suite/success/Case2.v
new file mode 100644
index 00000000..0aa7b5be
--- /dev/null
+++ b/test-suite/success/Case2.v
@@ -0,0 +1,11 @@
+(* ============================================== *)
+(*     To test compilation of dependent case      *)
+(*  Nested patterns                               *)
+(* ============================================== *)
+
+Type <[n:nat]n=n>Cases O of 
+                    O => (refl_equal nat O) 
+                  | m => (refl_equal nat m) 
+end.
+
+
diff --git a/test-suite/success/Case5.v b/test-suite/success/Case5.v
new file mode 100644
index 00000000..fe49cdf9
--- /dev/null
+++ b/test-suite/success/Case5.v
@@ -0,0 +1,14 @@
+
+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 O) => (or_intror (S O)=O ? (discr_l O))
+   |  (S (S x)) => (or_intror (S (S x))=O ? (discr_l (S x)))
+ 
+  end.
diff --git a/test-suite/success/Case6.v b/test-suite/success/Case6.v
new file mode 100644
index 00000000..a262251e
--- /dev/null
+++ b/test-suite/success/Case6.v
@@ -0,0 +1,19 @@
+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))   
+      end
+ end.
diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v
new file mode 100644
index 00000000..6e2aea48
--- /dev/null
+++ b/test-suite/success/Case7.v
@@ -0,0 +1,16 @@
+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)).
+
+Parameter inv_Empty : (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.
diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v
new file mode 100644
index 00000000..a5d07405
--- /dev/null
+++ b/test-suite/success/Case9.v
@@ -0,0 +1,55 @@
+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))   
+      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))   
+      end
+ end.
+
diff --git a/test-suite/success/CaseAlias.v b/test-suite/success/CaseAlias.v
new file mode 100644
index 00000000..b5f0e730
--- /dev/null
+++ b/test-suite/success/CaseAlias.v
@@ -0,0 +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 .
+
+Fixpoint f [t : expr] : expr :=
+ Cases t of
+ | (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.
+
diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v
new file mode 100644
index 00000000..6ccd669a
--- /dev/null
+++ b/test-suite/success/Cases.v
@@ -0,0 +1,1597 @@
+(****************************************************************************)
+(* 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.
+
+(* Non dependent form of annotation *)
+Type <nat>Cases O eq of O x => O | (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.
+
+(* Interaction with coercions *)
+Parameter bool2nat : bool -> nat.
+Coercion bool2nat : bool >-> nat.
+Check [x](Cases x of O => true | (S _) => O 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 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 [A:Set] : nat-> Set := 
+  Niln : (Listn A O) 
+| Consn : (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 [n:nat] : nat->Set := 
+    LE_n : (LE n n) | LE_S : (m:nat)(LE n m)->(LE n (S m)).
+
+Require Bool.
+
+
+
+Inductive PropForm : Set := 
+          Fvar : nat -> PropForm
+        | Or   : PropForm -> PropForm -> PropForm .
+
+Section testIFExpr.
+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.
+End testIFExpr.
+
+
+
+Type [x:nat]<nat>Cases x of O => O | x => x end.
+
+Section testlist.
+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 titi :=
+   [a:A][l:list](<list>Cases l of nil => l
+                               | (cons b l) => l end).
+Reset list.
+End testlist.
+
+
+(* To test translation *)
+(* ------------------- *)
+
+
+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 Cases O of
+               (O as b) => b 
+             | (S O)  => O
+             | (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 <nat>Cases O of 
+                          (O as b) => b 
+                        | (S x)  => x end.
+
+Type <nat>Cases O of 
+                          x  => x 
+                       end.
+
+Type  Cases O of 
+                          x  => x 
+                       end.
+
+Type <nat>Cases O of
+                              O => O
+                         | ((S x) as b) => b
+                        end.
+
+Type [x:nat]<nat>Cases x of
+                              O => O
+                         | ((S x) as b) => b
+                        end.
+
+Type [x:nat] Cases x of
+                              O => O
+                         | ((S x) as b) => b
+                        end.
+
+
+Type <nat>Cases O of
+         O => O
+    | (S x) => O
+      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 <nat->nat>Cases O of
+                              O => [n:nat]O
+                         | (S x) =>  [n:nat]O
+                        end.
+
+Type                   Cases O of
+                              O => [n:nat]O
+                         | (S x) =>  [n:nat]O
+                        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 <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  Cases O of
+                              O => O
+                         |  _  => O
+                        end.
+
+Type <nat>Cases O of
+                  O => O
+               |  x => x
+                 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              Cases O (S O) of
+                             O  y => y
+                          | (S x) y => (plus x y) 
+                        end.
+
+
+Type    <nat>Cases O (S O) of
+                      O  x =>  x
+             |      (S y) O =>  y
+             |        x y  => (plus 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 
+          <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         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 [l:(List nat)]<(List nat)>Cases l of 
+                         Nil => (Nil nat)
+                      | (Cons  a l) => l
+                      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 <(List nat)>Cases (Nil nat) of 
+                        (Cons  a l) => l
+                       | x => x
+                      end.
+
+Type              Cases (Nil nat) of 
+                        (Cons  a l) => l
+                       | x => x
+                      end.
+
+Type <(List nat)>Cases (Nil nat) of 
+                         Nil => (Nil nat)
+                      | (Cons  a l) => l
+                      end.
+
+Type             Cases (Nil nat) of 
+                         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 
+   Cases O of 
+      O => O
+    | (S x) => Cases (Nil nat) of 
+                         Nil => x
+                      | (Cons  a l) => (plus 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 
+   <nat>Cases O (Nil nat) of 
+      O       x => O
+    | (S x)  Nil => x
+    | (S x) (Cons  a l) => (plus x a)      
+     end.
+
+
+
+Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
+                         niln => O
+                      |    x  => O
+                      end.
+
+Type [n:nat][l:(listn n)]
+                     Cases l of 
+                         niln => O
+                      |    x  => O
+                      end.
+
+
+Type <[_:nat]nat>Cases niln of 
+                         niln => O
+                      |    x  => O
+                      end.
+
+Type               Cases niln of 
+                         niln => O
+                      |    x  => O
+                      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
+     end.
+
+
+Type  <[n:nat][_:(listn n)]nat>Cases niln of 
+                         (consn m _ niln) => m
+                       | _ => (S O) end.
+
+
+
+Type [n:nat][x:nat][l:(listn n)]<[_:nat]nat>Cases x l of 
+                         O niln => O
+                      |  y  x  => O
+                      end.
+
+Type <[_:nat]nat>Cases O niln of 
+                         O niln => O
+                      |  y  x  => O
+                      end.
+
+
+Type <[_:nat]nat>Cases niln O of 
+                         niln O => O
+                      |  y  x  => O
+                      end.
+
+Type               Cases niln O of 
+                         niln O => O
+                      |  y  x  => O
+                      end.
+
+Type <[_:nat][_:nat]nat>Cases niln niln of 
+                         niln niln => O
+                      |    x  y  => O
+                      end.
+
+Type               Cases niln niln of 
+                         niln niln => O
+                      |    x  y  => O
+                      end.
+
+Type <[_,_,_:nat]nat>Cases niln niln niln of 
+                         niln niln niln => O
+                      |    x  y z  => O
+                      end.
+
+
+Type                 Cases niln niln niln of 
+                         niln niln niln => O
+                      |    x  y z  => O
+                      end.
+
+
+
+Type <[_:nat]nat>Cases (niln) of 
+                         niln  => O
+                      | (consn n a l) => O
+                      end.
+
+Type         Cases (niln) of 
+                         niln  => O
+                      | (consn n a l) => O
+                      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                Cases niln niln of 
+                         niln niln => O
+                      |  niln (consn n a l) => n
+                      |  (consn n a l)  x  => a
+                      end.
+
+
+Type [n:nat][l:(listn n)]<[_:nat]nat>Cases l of 
+                         niln => O
+                      |    x  => O
+                      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.
+         
+
+(* Rows of pattern variables: some tricky cases *)
+Axiom P:nat->Prop; f:(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 [i:nat]
+  <[n:nat;_:bool](P n)>Cases i true of
+        | 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
+  end.
+
+Type [n:nat][l:(listn n)]Cases l of 
+                         niln => O
+                      |    x  => O
+                      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 [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 [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 [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 [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 [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 [A:Set][n:nat][l:(Listn A n)]
+                   <[_:nat](Listn A O)>Cases l of 
+                         (Niln  as b) => b
+                      | (Consn  n a (Niln  as b))=> (Niln A)
+                      | (Consn  n a (Consn m b l)) => (Niln A)
+                      end.
+
+Type [A:Set][n:nat][l:(Listn A n)]
+                    Cases l of 
+                         (Niln  as b) => b
+                      | (Consn  n a (Niln  as b))=> (Niln A)
+                      | (Consn  n a (Consn m b l)) => (Niln A)
+                      end.
+*)
+(******** This example rises an error unconstrained_variables!
+Type [A:Set][n:nat][l:(Listn A n)]
+                    Cases l of 
+                         (Niln  as b) => (Consn A O O b)
+                      | ((Consn  n a Niln) as L) =>  L 
+                      | (Consn  n a _)  =>  (Consn A O O (Niln A))
+                      end.
+**********)
+
+(* 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 [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 [n:nat][l:(listn n)]
+             <[_:nat](listn n)>Cases l of 
+                         (niln as b) => l 
+                      |  _  => l
+                      end.
+
+
+Type [n:nat][l:(listn n)]
+                     Cases l of 
+                         (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 [A:Set][n:nat][l:(Listn A n)]
+                       Cases l of 
+                         (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 [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 [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 [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 <[_:nat]nat>Cases (niln) of 
+                         niln  => O
+                      | (consn n a niln) => O
+                      | (consn n a (consn m b l)) => (plus 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 <[_,_:nat]nat>Cases (LeO O) of 
+                         (LeO x)  => x
+                      | (LeS n m h) => (plus n m) 
+                      end.
+
+
+Type               Cases (LeO O) of 
+                         (LeO x)  => x
+                      | (LeS n m h) => (plus n m) 
+                      end.
+
+Type [n:nat][l:(Listn nat n)]
+                     <[_:nat]nat>Cases l of 
+                         Niln  => O
+                      | (Consn n a l) => O
+                      end.
+
+
+Type [n:nat][l:(Listn nat n)]
+                      Cases l of 
+                         Niln  => O
+                      | (Consn n a l) => O
+                      end.
+
+
+Type                Cases (Niln nat) of 
+                         Niln  => O
+                      | (Consn n a l) => O
+                      end.
+
+Type <[_:nat]nat>Cases (LE_n O) of 
+                         LE_n   => O 
+                      | (LE_S m h) => O
+                      end.
+
+
+Type               Cases (LE_n O) of 
+                         LE_n   => O 
+                      | (LE_S m h) => O
+                      end.
+
+
+
+Type               Cases (LE_n O) of 
+                         LE_n   => O 
+                      | (LE_S m h) => O
+                      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               Cases (niln ) of 
+                         niln   => O
+                      | (consn  n a niln) => n
+                      | (consn  n a (consn  m b l)) => (plus 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                Cases (Niln nat) of 
+                         Niln  => O
+                      | (Consn  n a Niln) => n
+                      | (Consn   n a (Consn  m b l)) => (plus 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                 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 <[_,_: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                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 [n,m:nat][h:(Le n m)]
+                    <[_,_:nat]nat>Cases h of 
+                         (LeO x)  => x
+                      | x => O
+                      end.
+
+Type [n,m:nat][h:(Le n m)]
+                     Cases h of 
+                         (LeO x)  => x
+                      | x => O
+                      end.
+
+
+Type [n,m:nat][h:(Le n m)]
+                    <[_,_:nat]nat>Cases h of 
+                        (LeS n m h)  => n
+                      | x => O
+                      end.
+
+
+Type [n,m:nat][h:(Le n m)]
+                      Cases h of 
+                        (LeS n m h)  => n
+                      | x => O
+                      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    [n,m:nat][h:(Le n m)]
+                  Cases h of
+                    (LeO n) => (O,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.
+
+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.
+
+(* 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.
+
+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 length2:= [n:nat] [l:(listn n)]
+        <[_:nat]nat>Cases l of 
+                     (consn n _ (consn m _ _)) => (S (S m))
+                    |(consn n _ _) => (S n)
+                    | _ => O
+             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 length3 :=
+[n:nat][l:(listn n)]
+        <[_:nat]nat>Cases l of 
+                     (consn n _ (consn m _ l)) => (S n)
+                    |(consn n _ _) => (S O)
+                    | _  => O
+                   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.
+
+ 
+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 [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 [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 <[_,_: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                 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 <[_: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                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 [n,m:nat][h:(Le n m)]              Cases h of 
+                                                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 [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 [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 [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 [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.
+
+(* 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.
+
+(** Horrible error message! 
+
+Type [A:Set][n:nat][l:(Listn A n)]
+                        Cases l of 
+                        (Niln as b) => b
+                      | ((Consn _ _ _ ) as b)=>  b
+                      end.
+******)
+
+Type   <[n:nat](listn  n)>Cases niln of 
+               (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 [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 [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 [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 [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 [n,m:nat]
+                      Cases (LeO O) of 
+                        (LeS n m h)  =>(plus n m)
+                      | x => O
+                      end.
+
+Parameter test : (n:nat){(le O n)}+{False}.
+Type  [n:nat]<nat>Cases (test n) of
+                        (left _) => O 
+                        | _ => O end.
+
+
+Type  [n:nat]   <nat> Cases (test n) of
+                          (left _) => O 
+                        | _ => O end.
+
+Type  [n:nat]Cases (test n) of
+                          (left _) => O 
+                        | _ => O 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.
+
+Type    Cases (compare O O) of
+               (* k<i *)  (inleft (left _)) => O
+            |  (* k=i *)  (inleft  _)  => O
+            |  (* k>i *)  (inright  _) => O 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).
+Parameter B : Set.
+
+Type 
+  [P:nat->B->Prop][x:(SStream B P)]<[_:nat->B->Prop]B>Cases x of
+     (scons _ a _ _) => a  end.
+
+
+Type 
+  [P:nat->B->Prop][x:(SStream B P)] Cases x of
+     (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 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.
+
+
+
+Parameter concat : (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.
+
+
+Inductive redexes : Set :=
+    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.
+
+
+Type [n:nat]Cases n of O => O | (S ((S n) as V)) => V | _ => O 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.
+
+Type [h:False]<True>Cases h of end.
+
+Definition is_zero := [n:nat]Cases n of O => True | _ => False end.
+
+Type [n:nat][h:O=(S n)]<[n:nat](is_zero n)>Cases h of refl_equal => I 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.
+
+Definition nlength3 := [n:nat] [l: (listn n)]
+                         Cases l of 
+                            niln  => O
+                         |  (consn O  _ _)  => (S O)
+                         |  (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.
+End titi.
+
+Type Cases niln of 
+    (consn _ a niln) => a
+ |  (consn n _ x)    => O
+ |   niln  => O
+ end.
+
+
+
+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.
+
+
+
+(* ===================================================================== *)
+(* To test pattern matching over a non-dependent inductive type, but     *)
+(* having constructors with some arguments that depend on others         *)
+(* I.e. to test manipulation of elimination predicate                    *)
+(* ===================================================================== *)
+
+
+Parameter LTERM : nat -> Set.
+Mutual Inductive TERM : Type :=
+	  var : TERM
+	| oper : (op:nat) (LTERM op) -> TERM.
+
+Parameter t1, t2:TERM.
+
+Type Cases t1 t2 of 
+   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 .
+
+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.
+
+
+Parameter ordre_total : nat->nat->Prop.
+
+Parameter N_cla:(N:nat){N=O}+{N=(S O)}+{(ge N (S (S O)))}.
+
+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)}.
+
+Type [N:nat](Cases (N_cla N) of
+                         (inright H)=>(Cases (exist_U2 N H) of
+                                               (exist a b)=>a
+                                       end)
+                        |   _       => O
+                       end).
+
+
+
+(* ============================================== *)
+(*     To test compilation of dependent case      *)
+(*  Nested patterns                               *)
+(* ============================================== *)
+
+(* == 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 <[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.
+
+
+
+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.
+
+
+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) (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))   
+      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))
+  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.
+
+
+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) (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))   
+      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.
+
+
+(* ================================================== *)
+(* Pour tester parametres                             *)
+(* ================================================== *)
+
+
+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)).
+
+
+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))
+  end.
+
+
+(* ================================================== *)
+(* Sur les listes                                     *)
+(* ================================================== *)
+
+
+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))
+  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)).
+
+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.
+
+
+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.
+
+ 
+(* ===================================== *)
+
+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)).
+
+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))
+
+
+   | ((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))   
+      end
+ end.
+
+(* ============================================== *)
+(*     To test compilation of dependent case      *)
+(*      Multiple Patterns                         *)
+(* ============================================== *)
+Inductive skel: Type :=
+     PROP: skel
+   | PROD: skel->skel->skel.
+
+Parameter Can : skel -> Type.
+Parameter default_can : (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.
+
+(* 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
+           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.
+
+
+
+(* 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.
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
new file mode 100644
index 00000000..0256280c
--- /dev/null
+++ b/test-suite/success/CasesDep.v
@@ -0,0 +1,405 @@
+(* 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 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)).
+
+Section Folding.
+Variables 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))
+  end.
+End Folding.
+
+(* -------------------------------------------------------------------- *)
+(*   Example to test patterns matching on dependent families            *)
+(* This exemple extracted from the developement done by Nacira Chabane  *)
+(* (equipe Paris 6)                                                     *)
+(* -------------------------------------------------------------------- *)
+
+
+Require Prelude.
+Require Logic_Type.
+
+Section Orderings.
+   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,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).
+Inductive Equivalence : Prop :=
+         Build_Equivalence:
+           Reflexive -> Transitive -> Symmetric -> Equivalence.
+   
+   Inductive PER : Prop :=
+         Build_PER: Symmetric -> Transitive -> PER.
+   
+End Orderings.
+
+(***** Setoid  *******)
+
+Inductive Setoid : Type 
+  := Build_Setoid : (S:Type)(R:(Relation S))(Equivalence ? R) -> Setoid.
+
+Definition elem := [A:Setoid] let (S,R,e)=A in S.
+
+Grammar constr constr1 :=
+ elem  [ "|" constr0($s) "|"] -> [ (elem $s) ].
+
+Definition equal := [A:Setoid]
+   <[s:Setoid](Relation |s|)>let (S,R,e)=A in R.
+
+Grammar constr constr1 :=
+ equal   [ constr0($c) "=" "%" "S" constr0($c2) ] -> 
+         [ (equal ? $c $c2) ].
+
+
+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)).
+
+Section Maps.
+Variables A,B: Setoid.
+
+Definition Map_law := [f:|A| -> |B|]
+    (x,y:|A|) x =%S y -> (f x) =%S (f y).
+
+Inductive Map : Type :=
+    Build_Map : (f:|A| -> |B|)(p:(Map_law f))Map.
+
+Definition explicit_ap := [m:Map] <|A| -> |B|>Match m with 
+         [f:?][p:?]f end.
+
+Axiom pres : (m:Map)(Map_law (explicit_ap m)).
+
+Definition ext := [f,g:Map]
+         (x:|A|) (explicit_ap f x) =%S (explicit_ap g x).
+
+Axiom Equiv_map_eq : (Equivalence Map ext).
+
+Definition Map_setoid := (Build_Setoid Map ext Equiv_map_eq).
+
+End Maps.
+
+Notation ap := (explicit_ap ? ?). 
+
+Grammar constr constr8 :=
+  map_setoid [ constr7($c1) "=>" constr8($c2) ] 
+                 -> [ (Map_setoid $c1 $c2) ].
+
+
+Definition ap2 := [A,B,C:Setoid][f:|(A=>(B=>C))|][a:|A|] (ap (ap f a)).
+
+
+(*****    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).
+
+(* The predecessor function *)
+
+Definition pred : posint->posint
+     := [n:posint](<posint>Case n of (* Z *) Z 
+                            (* Suc u *) [u:posint]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)).
+
+
+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.
+
+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).
+
+
+(*******  Dsetoid *****)
+
+Definition Decidable :=[A:Type][R:(Relation A)]
+		(x,y:A)(R x y) \/ ~(R x y).
+
+
+Record DSetoid : Type :=
+{Set_of : Setoid;
+ prf_decid : (Decidable |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)).
+
+(* Dsetoide des posint*)
+
+Definition Set_of_posint := (Build_Setoid posint (eqT posint) eqT_equiv).
+
+Definition Dposint := (Build_DSetoid Set_of_posint Eq_posint_deci).
+
+
+
+(**************************************)
+
+
+(* Definition des signatures *)
+(* une signature est un ensemble d'operateurs muni
+ de l'arite de chaque operateur *)
+
+
+Section Sig.
+
+Record Signature :Type :=
+{Sigma : DSetoid; 
+ Arity : (Map (Set_of Sigma) (Set_of Dposint))}.
+
+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)).
+
+
+
+(* -------------------------------------------------------------------- *)
+(*                  Examples                                            *)
+(* -------------------------------------------------------------------- *)
+
+
+Parameter t1,t2: TERM.
+
+Type 
+ Cases t1 t2 of 
+ | (var  v1) (var v2) => True
+ | (oper op1 l1) (oper op2 l2) => False
+ | _ _ => False 
+ end.
+
+
+
+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 Cases l1 l2 of
+    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 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.
+
+
+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.
+
+
+(* ---------------------------------------------------------------- *)
+(*                Version with simple patterns                      *)
+(* ---------------------------------------------------------------- *)
+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.
+
+
+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.
+
+(* ---------------------------------------------------------------- *)
+(*                  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.
+
+
+(* ------------------------------------------------------------------ *)
+
+End Sig.
+
+(* Exemple soumis par Bruno *)
+
+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
+  end.
diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v
new file mode 100644
index 00000000..5d183528
--- /dev/null
+++ b/test-suite/success/Check.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* Compiling the theories allows to test parsing and typing but not printing *)
+(* This file tests that pretty-printing does not fail                        *)
+(* Test of exact output is not specified                                     *)
+
+Check O.
+Check S.
+Check nat.
diff --git a/test-suite/success/Conjecture.v b/test-suite/success/Conjecture.v
new file mode 100644
index 00000000..6db5859b
--- /dev/null
+++ b/test-suite/success/Conjecture.v
@@ -0,0 +1,13 @@
+(* Check keywords Conjecture and Admitted are recognized *)
+
+Conjecture c : (n:nat)n=O.
+
+Check c.
+
+Theorem d : (n:nat)n=O.
+Proof.
+  NewInduction n.
+  Reflexivity.
+  Assert H:False.
+  2:NewDestruct H.
+Admitted.
diff --git a/test-suite/success/DHyp.v b/test-suite/success/DHyp.v
new file mode 100644
index 00000000..73907bc4
--- /dev/null
+++ b/test-suite/success/DHyp.v
@@ -0,0 +1,14 @@
+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
new file mode 100644
index 00000000..21a3ab5d
--- /dev/null
+++ b/test-suite/success/Decompose.v
@@ -0,0 +1,7 @@
+(* 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 *)
+
+Abort.
diff --git a/test-suite/success/Destruct.v b/test-suite/success/Destruct.v
new file mode 100644
index 00000000..fdd929bb
--- /dev/null
+++ b/test-suite/success/Destruct.v
@@ -0,0 +1,13 @@
+(* 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
new file mode 100644
index 00000000..5d12098f
--- /dev/null
+++ b/test-suite/success/DiscrR.v
@@ -0,0 +1,41 @@
+Require Reals.
+Require DiscrR.
+
+Lemma ex0: ``1<>0``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex1: ``0<>2``.
+Proof.
+  DiscrR.
+Save.
+Lemma ex2: ``4<>3``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex3: ``3<>5``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex4: ``-1<>0``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex5: ``-2<>-3``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex6: ``8<>-3``.
+Proof.
+  DiscrR.
+Save.
+
+Lemma ex7: ``-8<>3``.
+Proof.
+  DiscrR.
+Save.
diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v
new file mode 100644
index 00000000..39d2f4bb
--- /dev/null
+++ b/test-suite/success/Discriminate.v
@@ -0,0 +1,11 @@
+(* Check the behaviour of Discriminate *)
+
+(* Check that Discriminate tries Intro until *)
+
+Lemma l1 : O=(S O)->False.   
+Discriminate 1.
+Qed.
+
+Lemma l2 : (H:O=(S O))H==H.   
+Discriminate H.
+Qed.
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
new file mode 100644
index 00000000..c203b739
--- /dev/null
+++ b/test-suite/success/Field.v
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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,v 1.1.16.1 2004/07/16 19:30:58 herbelin Exp $ *)
+
+(**** Tests of Field with real numbers ****)
+
+Require Reals.
+
+(* Example 1 *)
+Goal (eps:R)``eps*1/(2+2)+eps*1/(2+2) == eps*1/2``.
+Proof.
+  Intros.
+  Field.
+Abort.
+
+(* 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)``.
+Proof.
+  Intros.
+  Field.
+Abort.
+ 
+(* Example 3 *)
+Goal (a,b:R)``1/(a*b)*1/1/b == 1/a``.
+Proof.
+  Intros.
+  Field.
+Abort.
+ 
+(* Example 4 *)
+Goal (a,b:R)``a <> 0``->``b <> 0``->``1/(a*b)/1/b == 1/a``.
+Proof.
+  Intros.
+  Field.
+Abort.
+ 
+(* Example 5 *)
+Goal (a:R)``1 == 1*1/a*a``.
+Proof.
+  Intros.
+  Field.
+Abort.
+ 
+(* Example 6 *)
+Goal (a,b:R)``b == b*/a*a``.
+Proof.
+  Intros.
+  Field.
+Abort.
+ 
+(* Example 7 *)
+Goal (a,b:R)``b == b*1/a*a``.
+Proof.
+  Intros.
+  Field.
+Abort.
+
+(* Example 8 *)
+Goal (x,y:R)``x*((1/x)+x/(x+y)) == -(1/y)*y*(-(x*x/(x+y))-1)``.
+Proof.
+  Intros.
+  Field.
+Abort.
diff --git a/test-suite/success/Fourier.v b/test-suite/success/Fourier.v
new file mode 100644
index 00000000..f1f7ae08
--- /dev/null
+++ b/test-suite/success/Fourier.v
@@ -0,0 +1,16 @@
+Require Rfunctions.
+Require Fourier.
+ 
+Lemma l1:
+ (x, y, z : R)
+  ``(Rabsolu x-z) <= (Rabsolu x-y)+(Rabsolu y-z)``.
+Intros; SplitAbsolu; Fourier.
+Qed.
+ 
+Lemma l2:
+ (x, y : R)
+ ``x < (Rabsolu y)`` ->
+ ``y < 1`` -> ``x >= 0`` -> ``-y <= 1`` ->  ``(Rabsolu x) <= 1``.
+Intros.
+SplitAbsolu; Fourier.
+Qed.
diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v
new file mode 100644
index 00000000..819da259
--- /dev/null
+++ b/test-suite/success/Funind.v
@@ -0,0 +1,440 @@
+
+Definition iszero [n:nat] : bool := Cases n of
+                                    | O => true
+                                    | _ => false
+                                    end.
+
+Functional Scheme iszer_ind := Induction for iszero.
+ 
+Lemma toto : (n:nat) n = 0 -> (iszero n) = true.
+Intros x eg.
+Functional Induction iszero x; Simpl.
+Trivial.
+Subst x.
+Inversion H_eq_.
+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
+         | O => 0
+         | _ => 1
+         end
+  | (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 test11 : (m:nat) (le (ftest 0 m) 2).
+Intros m.
+Functional Induction ftest 0 m.
+Auto. 
+Auto. 
+Qed.
+
+
+Definition lamfix :=
+[m:nat ]
+(Fix trivfun {trivfun [n:nat] : nat := Cases n of
+                              | O => m
+                              | (S p) => (trivfun 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.
+Defined.
+
+
+
+(* polymorphic function *)
+Require PolyList.
+
+Functional Scheme app_ind := Induction for app.
+
+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.
+
+
+
+
+
+Require Export Arith.
+
+
+Fixpoint trivfun [n:nat] : nat :=
+  Cases n of
+  | O => 0
+  | (S m) => (trivfun m)
+  end.
+
+
+(* essaie de parametre variables non locaux:*) 
+
+Parameter varessai : nat.
+
+Lemma first_try : (trivfun varessai) = 0.
+Functional Induction trivfun varessai.
+Trivial.
+Simpl.
+Assumption.
+Defined.
+ 
+
+Functional Scheme triv_ind := Induction for trivfun.
+
+Lemma bisrepetita : (n':nat) (trivfun n') = 0.
+Intros n'.
+Functional Induction trivfun n'.
+Trivial.
+Simpl .
+Assumption.
+Qed.
+
+
+
+
+
+
+
+Fixpoint iseven [n:nat] : bool :=
+  Cases n of
+  | O => true
+  | (S (S m)) => (iseven m)
+  | _ => false
+  end.
+ 
+Fixpoint funex [n:nat] : nat :=
+  Cases (iseven n) of
+  | true => n
+  | false => Cases n of
+             | O => 0
+             | (S r) => (funex r)
+             end
+  end.
+ 
+Fixpoint nat_equal_bool [n:nat]  : nat -> bool :=
+[m:nat]
+  Cases n of
+  | O => Cases m of
+         | O => true
+         | _ => false
+         end
+  | (S p) => Cases m of
+           | O => false
+           | (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.
+
+Apply le_S.
+Apply le_n_S.
+Exact H.
+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))
+  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.
+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.
+Qed.
+
+ 
+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 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 ).
+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 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.
+Qed.
+ 
+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.
+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.
+Qed.
+ 
+ 
+Inductive istrue : bool ->  Prop :=
+  istrue0: (istrue true) .
+ 
+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.
+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.
+Qed.
+ 
+Lemma inf_x_plusxy''': (x : nat)  (le x (plus O x)).
+Intros n.
+(Functional Induction plus O n); Intros;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.
+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
+  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.
+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.
+Qed.
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/test-suite/success/Generalize.v b/test-suite/success/Generalize.v
new file mode 100644
index 00000000..0dc73991
--- /dev/null
+++ b/test-suite/success/Generalize.v
@@ -0,0 +1,7 @@
+(* 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.
+Abort.
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
new file mode 100644
index 00000000..f32753e0
--- /dev/null
+++ b/test-suite/success/Hints.v
@@ -0,0 +1,48 @@
+(* Checks syntax of Hints commands *)
+(* 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.
+
+(* 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.
+
+(* 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 ].
+
+(* Checks that local names are accepted *)
+Section A.
+  Remark Refl : (A:Set)(x:A)x=x. 
+  Proof refl_equal.
+  Definition Sym := sym_equal.
+  Local Trans := trans_equal.
+ 
+  Hint h1 : foo := Resolve Refl.
+  Hint h2 : bar := Resolve Sym.
+  Hint h3 : foo2 := Resolve Trans.
+
+  Hint h2 := Immediate Refl.
+  Hint h2 := Immediate Sym.
+  Hint h2 := Immediate Trans.
+
+  Hint h3 := Unfold Refl.
+  Hint h3 := Unfold Sym.
+  Hint h3 := Unfold Trans.
+
+  Hints Resolve Sym Trans Refl.
+  Hints Immediate Sym Trans Refl.
+  Hints Unfold Sym Trans Refl.
+
+End A.
+
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
new file mode 100644
index 00000000..87431a75
--- /dev/null
+++ b/test-suite/success/Inductive.v
@@ -0,0 +1,34 @@
+(* 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).
+
+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 }.
+
+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.
+
+(* Check implicit parameters of inductive types (submitted by Pierre
+  Casteran and also implicit in #338) *)
+
+Set Implicit Arguments.
+
+CoInductive LList [A:Set] : Set :=
+   | LNil : (LList A)
+   | LCons : A -> (LList A) -> (LList A).
+
+Implicits LNil [1].
+
+Inductive Finite [A:Set] : (LList A) -> Prop :=
+   | Finite_LNil : (Finite LNil)
+   | Finite_LCons : (a:A) (l:(LList A)) (Finite l) -> (Finite (LCons a l)).
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
new file mode 100644
index 00000000..fd80cec6
--- /dev/null
+++ b/test-suite/success/Injection.v
@@ -0,0 +1,34 @@
+(* Check the behaviour of Injection *)
+
+(* Check that Injection tries Intro until *)
+
+Lemma l1 : (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).
+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.
+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.
+Qed.
+
diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v
new file mode 100644
index 00000000..a9e4a843
--- /dev/null
+++ b/test-suite/success/Inversion.v
@@ -0,0 +1,85 @@
+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.
+Abort.
+
+(* Submitted by Pierre Casteran (bug #540) *)
+
+Set Implicit Arguments.
+Parameter rule: Set -> Type.
+
+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)).
+
+Implicits NL [1].
+
+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')). 
+
+
+
+Lemma super_def : (I :Set)(e1, e2: (extension I))
+                 (super_extension  e2 e1) ->
+                 (ru:?) 
+                   (in_extension ru e1) ->
+                   (in_extension ru e2).
+Proof.                 
+ Induction 1.
+ Inversion 1; Auto.
+ Elim magic.
+Qed.
+
+(* Example from Norbert Schirmer on Coq-Club, Sep 2000 *)
+
+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.
+Qed.
+
+(* Submitted by Boris Yakobowski (bug #529) *)
+(* Check that Inversion does not fail due to unnormalized evars *)
+
+Set Implicit Arguments.
+Require Import Bvector.
+
+Inductive I : nat -> Set :=
+| C1 : (I (S O))
+| C2 : (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).
+
+Theorem SUnique : (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.
+Admitted.
diff --git a/test-suite/success/LetIn.v b/test-suite/success/LetIn.v
new file mode 100644
index 00000000..0e0b4435
--- /dev/null
+++ b/test-suite/success/LetIn.v
@@ -0,0 +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.
+
+(* Check casting of let-in *)
+Definition l6 := [P := O : nat]P.
+Definition l7 := [P := True : Prop]P.
+Definition l8 := [P := True : Type]P.
diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v
new file mode 100644
index 00000000..d89ee3be
--- /dev/null
+++ b/test-suite/success/MatchFail.v
@@ -0,0 +1,28 @@
+Require Export ZArith.
+Require Export ZArithRing.
+
+(* Cette tactique a pour objectif de remplacer toute instance
+   de (POS (xI e)) ou de (POS (xO e)) par
+   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)).
+
+Goal (x:positive)(POS (xI (xI x)))=`4*(POS x)+3`.
+Intros.
+Repeat compute_POS.
+Ring.
+Qed.
diff --git a/test-suite/success/Mod_ltac.v b/test-suite/success/Mod_ltac.v
new file mode 100644
index 00000000..1a9f6fc5
--- /dev/null
+++ b/test-suite/success/Mod_ltac.v
@@ -0,0 +1,20 @@
+(* Submitted by Houda Anoun *)
+
+Module toto.
+Tactic Definition titi:=Auto.
+End toto.
+
+Module ti.
+Import toto.
+Tactic Definition equal:=
+Match Context With
+[ |- ?1=?1]-> titi
+| [ |- ?]-> Idtac.
+
+End ti.
+
+Import ti.
+Definition simple:(a:nat) a=a.
+Intro.
+equal.
+Qed.
diff --git a/test-suite/success/Mod_params.v b/test-suite/success/Mod_params.v
new file mode 100644
index 00000000..098de3cf
--- /dev/null
+++ b/test-suite/success/Mod_params.v
@@ -0,0 +1,78 @@
+(* Syntax test - all possible kinds of module parameters *)
+
+Module Type SIG.
+End SIG.
+
+Module Type FSIG[X:SIG].
+End FSIG.
+
+Module F[X:SIG].
+End F.
+
+Module Q.
+End Q.
+
+(*
+#trace Nametab.push;;
+#trace Nametab.push_short_name;;
+#trace Nametab.freeze;;
+#trace Nametab.unfreeze;;
+#trace Nametab.exists_cci;;
+*)
+
+Module M.
+Reset M.
+Module M[X:SIG].
+Reset M.
+Module M[X,Y:SIG].
+Reset M.
+Module M[X:SIG;Y:SIG].
+Reset M.
+Module M[X,Y:SIG;Z1,Z:SIG].
+Reset M.
+Module M[X:SIG][Y:SIG].
+Reset M.
+Module M[X,Y:SIG][Z1,Z:SIG].
+Reset M.
+Module M:SIG.
+Reset M.
+Module M[X:SIG]:SIG.
+Reset M.
+Module M[X,Y:SIG]:SIG.
+Reset M.
+Module M[X:SIG;Y:SIG]:SIG.
+Reset M.
+Module M[X,Y:SIG;Z1,Z:SIG]:SIG.
+Reset M.
+Module M[X:SIG][Y:SIG]:SIG.
+Reset M.
+Module M[X,Y:SIG][Z1,Z:SIG]:SIG.
+Reset M.
+Module M:=(F Q).
+Reset M.
+Module M[X:FSIG]:=(X Q).
+Reset M.
+Module M[X,Y:FSIG]:=(X Q).
+Reset M.
+Module M[X:FSIG;Y:SIG]:=(X Y).
+Reset M.
+Module M[X,Y:FSIG;Z1,Z:SIG]:=(X Z).
+Reset M.
+Module M[X:FSIG][Y:SIG]:=(X Y).
+Reset M.
+Module M[X,Y:FSIG][Z1,Z:SIG]:=(X Z).
+Reset M.
+Module M:SIG:=(F Q).
+Reset M.
+Module M[X:FSIG]:SIG:=(X Q).
+Reset M.
+Module M[X,Y:FSIG]:SIG:=(X Q).
+Reset M.
+Module M[X:FSIG;Y:SIG]:SIG:=(X Y).
+Reset M.
+Module M[X,Y:FSIG;Z1,Z:SIG]:SIG:=(X Z).
+Reset M.
+Module M[X:FSIG][Y:SIG]:SIG:=(X Y).
+Reset M.
+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
new file mode 100644
index 00000000..a472e698
--- /dev/null
+++ b/test-suite/success/Mod_strengthen.v
@@ -0,0 +1,64 @@
+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.
+End Sub.
+
+Module Type Main.
+  Declare Module M:Sub.
+End Main.
+
+
+Module A <: Main.
+  Module M <: Sub.
+    Lemma Refl1 : (x:nat) x=x.
+      Intros;Reflexivity.
+    Qed.
+    Axiom Refl2 : (x:nat) x=x.
+    Lemma Refl3 : (x:nat) x=x.
+      Intros;Reflexivity.
+    Defined.
+    Inductive T : Set := A : T.
+  End M.
+End A.
+
+
+
+(* first test *)
+
+Module F[S:Sub].
+  Module M:=S.
+End F.
+
+Module B <: Main with Module M:=A.M := F A.M.
+
+
+
+(* second test *)
+
+Lemma r1 : (A.M.Refl1 == B.M.Refl1).
+Proof.
+  Reflexivity.
+Qed.
+
+Lemma r2 : (A.M.Refl2 == B.M.Refl2).
+Proof.
+  Reflexivity.
+Qed.
+
+Lemma r3 : (A.M.Refl3 == B.M.Refl3).
+Proof.
+  Reflexivity.
+Qed.
+
+Lemma t : (A.M.T == B.M.T).
+Proof.
+  Reflexivity.
+Qed.
+
+Lemma a : (A.M.A == B.M.A).
+Proof.
+  Reflexivity.
+Qed.
+
diff --git a/test-suite/success/NatRing.v b/test-suite/success/NatRing.v
new file mode 100644
index 00000000..6a1eeccc
--- /dev/null
+++ b/test-suite/success/NatRing.v
@@ -0,0 +1,10 @@
+Require ArithRing.
+
+Lemma l1 : (S (S O))=(plus (S O) (S O)).
+NatRing.
+Qed.
+
+Lemma l2 : (x:nat)(S (S x))=(plus (S O) (S x)).
+Intro.
+NatRing.
+Qed.
\ No newline at end of file
diff --git a/test-suite/success/Omega.v b/test-suite/success/Omega.v
new file mode 100644
index 00000000..c324919f
--- /dev/null
+++ b/test-suite/success/Omega.v
@@ -0,0 +1,89 @@
+
+Require Omega.
+
+(* Submitted by Xavier Urbain 18 Jan 2002 *)
+
+Lemma lem1 : (x,y:Z) 
+  `-5 < x < 5` ->
+  `-5 < y` ->
+  `-5 < x+y+5`.
+Proof.
+Intros x y.
+Omega.
+Qed.
+
+(* Proposed by Pierre Crégut *)
+
+Lemma lem2 : (x:Z) `x < 4` -> `x > 2` -> `x=3`.
+Intro.
+Omega.
+Qed.
+
+(* Proposed by Jean-Christophe Filliâtre *)
+
+Lemma lem3 : (x,y:Z) `x = y` -> `x+x = y+y`.
+Proof.
+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.
+Qed.
+End A.
+
+(* Proposed by Yves Bertot: because a section var, L was wrongly renamed L0 *)
+(* 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.
+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.
+Qed.
+
+(* Adapted from an example in Nijmegen/FTA/ftc/RefSeparating (Oct 2002) *)
+Require 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.
+Qed.
+End C.
+
+(* Problem of dependencies *)
+Require Omega.
+Lemma lem8 : (H:O=O->O=O) H=H -> O=O.
+Intros; Omega.
+Qed.
+
+(* Bug that what caused by the use of intro_using in Omega *)
+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).
+Intros; Omega.
+Qed.
+
diff --git a/test-suite/success/PPFix.v8 b/test-suite/success/PPFix.v8
new file mode 100644
index 00000000..1ecbae3a
--- /dev/null
+++ b/test-suite/success/PPFix.v8
@@ -0,0 +1,8 @@
+
+(* To test PP of fixpoints *)
+Require Import Arith.
+Check fix a(n: nat): n<5 -> nat :=
+  match n return n<5 -> nat with
+    | 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
new file mode 100644
index 00000000..4554a843
--- /dev/null
+++ b/test-suite/success/Print.v
@@ -0,0 +1,20 @@
+Print Tables.
+Print ML Path.
+Print ML Modules.
+Print LoadPath.
+Print Graph.
+Print Coercions.
+Print Classes.
+Print nat.
+Print Proof O.
+Print All.
+Print Grammar constr constr.
+Inspect 10.
+
+Section A.
+Coercion f := [x]True : nat -> Prop.
+Print Coercion Paths nat SORTCLASS.
+
+Print Section A.
+Print.
+
diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v
new file mode 100644
index 00000000..7f5cd800
--- /dev/null
+++ b/test-suite/success/Projection.v
@@ -0,0 +1,45 @@
+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).
+
+(* v8
+Check fun s:S => s.(Dom).
+Check fun s:S => s.(Op).
+Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b.
+*)
+
+Set Implicit Arguments.
+Unset Strict Implicits. 
+
+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).
+
+(* v8
+Check fun s:S' => s.(Dom').
+Check fun s:S' => s.(Op').
+Check fun (s:S') (a b:s.(Dom')) => _.(Op') a b.
+Check fun (s:S') (a b:s.(Dom')) => s.(Op') a b.
+
+Set Implicit Arguments.
+Unset Strict Implicits. 
+
+Structure S' (A:Set) : Type := 
+ {Dom'     : Type;
+  Op'      : A -> Dom' -> Dom'}.
+
+Check fun s:S' nat => s.(Dom').
+Check fun s:S' nat => s.(Op').
+Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => _.(@Op' nat) a b.
+Check fun (s:S' nat) (a:nat) (b:s.(Dom')) => s.(Op') a b.
+*)
diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v
new file mode 100644
index 00000000..f3a13634
--- /dev/null
+++ b/test-suite/success/Record.v
@@ -0,0 +1,3 @@
+(* Nijmegen expects redefinition of sorts *)
+Definition CProp := Prop.
+Record test : CProp := { n:nat }.
diff --git a/test-suite/success/Reg.v b/test-suite/success/Reg.v
new file mode 100644
index 00000000..eaa0690c
--- /dev/null
+++ b/test-suite/success/Reg.v
@@ -0,0 +1,136 @@
+Require 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.
+
+Lemma essai0 : (continuity_pt [x:R]``(x+2)/(y x)+x/(y x)`` R0).
+Assert H := d_y.
+Assert H0 := n_y.
+Reg.
+Qed.
+
+Lemma essai1 : (derivable_pt [x:R]``/2*(sin x)`` ``1``).
+Reg.
+Qed.
+
+Lemma essai2 : (continuity [x:R]``(Rsqr x)*(cos (x*x))+x``).
+Reg.
+Qed.
+
+Lemma essai3 : (derivable_pt [x:R]``x*((Rsqr x)+3)`` R0).
+Reg.
+Qed.
+
+Lemma essai4 : (derivable [x:R]``(x+x)*(sin x)``).
+Reg.
+Qed.
+
+Lemma essai5 : (derivable [x:R]``1+(sin (2*x+3))*(cos (cos x))``).
+Reg.
+Qed.
+
+Lemma essai6 : (derivable [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.
+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].
+Qed.
+
+Lemma essai9 : (derivable_pt (plus_fct id sin) R1).
+Reg.
+Qed.
+
+Lemma essai10 : (derivable_pt [x:R]``x+2`` R0).
+Reg.
+Qed.
+
+Lemma essai11 : (derive_pt [x:R]``x+2`` R0 essai10)==R1.
+Reg.
+Qed.
+
+Lemma essai12 : (derivable [x:R]``x+(Rsqr (x+2))``).
+Reg.
+Qed.
+
+Lemma essai13 : (derive_pt [x:R]``x+(Rsqr (x+2))`` R0 (essai12 R0)) == ``5``.
+Reg.
+Qed.
+
+Lemma essai14 : (derivable_pt [x:R]``2*x+x`` ``2``).
+Reg.
+Qed.
+
+Lemma essai15 : (derive_pt [x:R]``2*x+x`` ``2`` essai14) == ``3``.
+Reg.
+Qed.
+
+Lemma essai16 : (derivable_pt [x:R]``x+(sin x)`` R0).
+Reg.
+Qed.
+
+Lemma essai17 : (derive_pt [x:R]``x+(sin x)`` R0 essai16)==``2``.
+Reg.
+Rewrite cos_0.
+Reflexivity.
+Qed.
+
+Lemma essai18 : (derivable_pt [x:R]``x+(y x)`` ``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.
+Qed.
+
+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.
+Qed.
+
+Lemma essai21 : (derive_pt [x:R]``(z (y x))`` R0 essai20) == R1.
+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.
+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].
+Qed.
diff --git a/test-suite/success/Remark.v b/test-suite/success/Remark.v
new file mode 100644
index 00000000..2dd6a211
--- /dev/null
+++ b/test-suite/success/Remark.v
@@ -0,0 +1,12 @@
+(* Test obsolete, Remark est maintenant global
+Section A.
+Section B.
+Section C.
+Remark t : True. Proof I.
+End C.
+Locate C.t.
+End B.
+Locate B.C.t.
+End A.
+Locate A.B.C.t.
+*)
diff --git a/test-suite/success/Rename.v b/test-suite/success/Rename.v
new file mode 100644
index 00000000..edb20a81
--- /dev/null
+++ b/test-suite/success/Rename.v
@@ -0,0 +1,5 @@
+Goal (n:nat)(n=O)->(n=O).
+Intros.
+Rename n into p.
+NewInduction p; Auto.
+Qed.
diff --git a/test-suite/success/Require.v b/test-suite/success/Require.v
new file mode 100644
index 00000000..654808fc
--- /dev/null
+++ b/test-suite/success/Require.v
@@ -0,0 +1,3 @@
+Require Coq.Arith.Plus.
+Read Module Coq.Arith.Minus.
+Locate Library Coq.Arith.Minus.
diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v
new file mode 100644
index 00000000..55d8343e
--- /dev/null
+++ b/test-suite/success/Scopes.v
@@ -0,0 +1,8 @@
+(* Check exportation of Argument Scopes even without import of modules *)
+
+Require Import ZArith.
+
+Module A.
+Definition opp := Zopp.
+End A.
+Check (A.opp 3).
diff --git a/test-suite/success/Simplify_eq.v b/test-suite/success/Simplify_eq.v
new file mode 100644
index 00000000..41aa77ef
--- /dev/null
+++ b/test-suite/success/Simplify_eq.v
@@ -0,0 +1,13 @@
+(* Check the behaviour of Simplify_eq *)
+
+(* Check that Simplify_eq tries Intro until *)
+
+Lemma l1 : O=(S O)->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).
+Qed.
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
new file mode 100644
index 00000000..883a82ab
--- /dev/null
+++ b/test-suite/success/Tauto.v
@@ -0,0 +1,240 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Tauto.v,v 1.10.8.1 2004/07/16 19:30:59 herbelin Exp $ *)
+
+(**** Tactics Tauto and Intuition ****)
+
+(**** Tauto:
+  Tactic for automating proof in Intuionnistic Propositional Calculus, based on
+  the contraction-free LJT* of Dickhoff ****)
+
+(**** Intuition:
+  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.
+
+Lemma Ex_Wallen:(A->(B/\C)) -> ((A->B)\/(A->C)).
+Proof.
+  Tauto.
+Save.
+
+Lemma Ex_Klenne:~(~(A \/ ~A)).
+Proof.
+  Tauto.
+Save.
+
+Lemma Ex_Klenne':(n:nat)(~(~((even n) \/ ~(even n)))).
+Proof.
+  Tauto.
+Save.
+
+Lemma Ex_Klenne'':~(~(((n:nat)(even n)) \/ ~((m:nat)(even m)))).
+Proof.
+  Tauto.
+Save.
+
+Lemma tauto:((x:nat)(P x)) -> ((y:nat)(P y)).
+Proof.
+  Tauto.
+Save.
+
+Lemma tauto1:(A -> A).
+Proof.
+  Tauto.
+Save.
+
+Lemma tauto2:(A -> B -> C) -> (A -> B) -> A -> C.
+Proof.
+  Tauto.
+Save.
+
+Lemma a:(x0: (A \/ B))(x1:(B /\ C))(A -> B).
+Proof.
+  Tauto.
+Save.
+
+Lemma a2:((A -> (B /\ C)) -> ((A -> B) \/ (A -> C))).
+Proof.
+  Tauto.
+Save.
+
+Lemma a4:(~A -> ~A).
+Proof.
+  Tauto.
+Save.
+
+Lemma e2:~(~(A \/ ~A)).
+Proof.
+  Tauto.
+Save.
+
+Lemma e4:~(~((A \/ B) -> (A \/ B))).
+Proof.
+  Tauto.
+Save.
+
+Lemma y0:(x0:A)(x1: ~A)(x2:(A -> B))(x3:(A \/ B))(x4:(A /\ B))(A -> False).
+Proof.
+  Tauto.
+Save.
+
+Lemma y1:(x0:((A /\ B) /\ C))B.
+Proof.
+  Tauto.
+Save.
+
+Lemma y2:(x0:A)(x1:B)(C \/ B).
+Proof.
+  Tauto.
+Save.
+
+Lemma y3:(x0:(A /\ B))(B /\ A).
+Proof.
+  Tauto.
+Save.
+
+Lemma y5:(x0:(A \/ B))(B \/ A).
+Proof.
+  Tauto.
+Save.
+
+Lemma y6:(x0:(A -> B))(x1:A) B.
+Proof.
+  Tauto.
+Save.
+
+Lemma y7:(x0 : ((A /\ B) -> C))(x1 : B)(x2 : A) C.
+Proof.
+  Tauto.
+Save.
+
+Lemma y8:(x0 : ((A \/ B) -> C))(x1 : A) C.
+Proof.
+  Tauto.
+Save.
+
+Lemma y9:(x0 : ((A \/ B) -> C))(x1 : B) C.
+Proof.
+  Tauto.
+Save.
+
+Lemma y10:(x0 : ((A -> B) -> C))(x1 : B) C.
+Proof.
+  Tauto.
+Save.
+
+(* This example took much time with the old version of Tauto *)
+Lemma critical_example0:(~~B->B)->(A->B)->~~A->B.
+Proof.
+  Tauto.
+Save.
+
+(* Same remark as previously *)
+Lemma critical_example1:(~~B->B)->(~B->~A)->~~A->B.
+Proof.
+  Tauto.
+Save.
+
+(* 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).
+Proof.
+  Tauto.
+Save.
+
+(* This example was a bug *)
+Lemma old_bug0:(~A<->B)->(~(C\/E)<->D/\F)->~(C\/A\/E)<->D/\B/\F.
+Proof.
+  Tauto.
+Save.
+
+(* Another bug *)
+Lemma old_bug1:((A->B->False)->False) -> (B->False) -> False.
+Proof.
+  Tauto.
+Save.
+
+(* A bug again *)
+Lemma old_bug2:
+  ((((C->False)->A)->((B->False)->A)->False)->False) ->
+  (((C->B->False)->False)->False) ->
+  ~A->A.
+Proof.
+  Tauto.
+Save.
+
+(* A bug from CNF form *)
+Lemma old_bug3:
+  ((~A\/B)/\(~B\/B)/\(~A\/~B)/\(~B\/~B)->False)->~((A->B)->B)->False.
+Proof.
+  Tauto.
+Save.
+
+(* 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.
+Proof.
+  Tauto.
+Save.
+
+(* 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).
+Proof.
+  Tauto.
+Save.
+
+
+(*  A private club has the following rules :
+ *
+ *  . rule 1 : Every non-scottish member wears red socks
+ *  . rule 2 : Every member wears a kilt or doesn't wear red socks
+ *  . rule 3 : The married members don't go out on sunday
+ *  . rule 4 : A member goes out on sunday if and only if he is scottish
+ *  . rule 5 : Every member who wears a kilt is scottish and married
+ *  . rule 6 : Every scottish member wears a kilt
+ *
+ *  Actually, no one can be accepted !
+ *)
+
+Section club.
+
+Variable Scottish, RedSocks, WearKilt, Married, GoOutSunday : Prop.
+
+Hypothesis rule1 : ~Scottish -> RedSocks.
+Hypothesis rule2 : WearKilt \/ ~RedSocks.
+Hypothesis rule3 : Married -> ~GoOutSunday.
+Hypothesis rule4 : GoOutSunday <-> Scottish.
+Hypothesis rule5 : WearKilt -> (Scottish /\ Married).
+Hypothesis rule6 : Scottish -> WearKilt.
+
+Lemma NoMember : False.
+Tauto.
+Save.
+
+End club.
+
+(**** Use of Intuition ****)
+Lemma intu0:(((x:nat)(P x)) /\ B) ->
+              (((y:nat)(P y)) /\ (P O)) \/ (B /\ (P O)).
+Proof.
+  Intuition.
+Save.
+
+Lemma intu1:((A:Prop)A\/~A)->(x,y:nat)(x=y\/~x=y).
+Proof.
+  Intuition.
+Save.
+
diff --git a/test-suite/success/Try.v b/test-suite/success/Try.v
new file mode 100644
index 00000000..05cab1e6
--- /dev/null
+++ b/test-suite/success/Try.v
@@ -0,0 +1,8 @@
+(* To shorten interactive scripts, it is better that Try catches
+   non-existent names in Unfold [cf bug #263] *)
+
+Lemma lem1 : True.
+Try (Unfold i_dont_exist).
+Trivial.
+Qed.
+
diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v
new file mode 100644
index 00000000..4d898da9
--- /dev/null
+++ b/test-suite/success/cc.v
@@ -0,0 +1,83 @@
+
+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.
+
+(* 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.
+
+(* 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.
+
+(* 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.
+
+
+(* 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.
+
+(* 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 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.
+
+(* Examples with discrimination rule *)
+
+Theorem discr1 : true=false->False.
+Intros.
+Congruence.
+Save.
+
+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.
diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v
new file mode 100644
index 00000000..98b613ba
--- /dev/null
+++ b/test-suite/success/coercions.v
@@ -0,0 +1,11 @@
+(* Interaction between coercions and casts *)
+(*   Example provided by Eduardo Gimenez   *)
+
+Parameter Z,S:Set.
+
+Parameter f: S  -> Z.
+Coercion  f: S >-> Z.
+
+Parameter g : Z -> Z.
+
+Check [s](g (s::S)).
diff --git a/test-suite/success/coqbugs0181.v b/test-suite/success/coqbugs0181.v
new file mode 100644
index 00000000..21f906a6
--- /dev/null
+++ b/test-suite/success/coqbugs0181.v
@@ -0,0 +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).
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
new file mode 100644
index 00000000..97f7ccf0
--- /dev/null
+++ b/test-suite/success/eauto.v
@@ -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        *)
+(************************************************************************)
+Require PolyList.
+
+Parameter in_list : (list nat*nat)->nat->Prop.
+Definition not_in_list : (list nat*nat)->nat->Prop
+	:= [l,n]~(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.
+
+(* 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 *) 
+Qed.
diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v
new file mode 100644
index 00000000..f826df9a
--- /dev/null
+++ b/test-suite/success/eqdecide.v
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Inductive T : Set := A: T | B :T->T.
+
+Lemma lem1 : (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.
+Qed.
+
+Lemma lem3 : (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.
+Qed.
+
diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v
new file mode 100644
index 00000000..a7b6d6d8
--- /dev/null
+++ b/test-suite/success/evars.v
@@ -0,0 +1,23 @@
+(* 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)))).
+
+(* 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)).
+
+(* 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).
+
+(* Checks that solvable ? in the lambda prefix of the definition are harmless*)
+Parameter A1,A2,F,B,C : Set.
+Parameter f : F -> A1 -> B.
+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).
+
diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v
new file mode 100644
index 00000000..374029bb
--- /dev/null
+++ b/test-suite/success/fix.v
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* Ancien bug signale par Laurent Thery sur la condition de garde *)
+
+Require Import Bool.
+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.
+Defined.
+
+
+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.
+
diff --git a/test-suite/success/if.v b/test-suite/success/if.v
new file mode 100644
index 00000000..85cd1f11
--- /dev/null
+++ b/test-suite/success/if.v
@@ -0,0 +1,5 @@
+(* The synthesis of the elimination predicate may fail if algebric *)
+(* universes are not cautiously treated *)
+
+Check [b:bool]if b then Type else nat.
+
diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v
new file mode 100644
index 00000000..c597f9bf
--- /dev/null
+++ b/test-suite/success/implicit.v
@@ -0,0 +1,31 @@
+(* Implicit on section variables *)
+
+Set Implicit Arguments.
+
+(* 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).
+
+(* Example submitted by Christine *)
+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.
+
+End Spec.
+
+(* Example submitted by Frédéric (interesting in v8 syntax) *)
+
+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)).
+*)
diff --git a/test-suite/success/import_lib.v b/test-suite/success/import_lib.v
new file mode 100644
index 00000000..d031691d
--- /dev/null
+++ b/test-suite/success/import_lib.v
@@ -0,0 +1,202 @@
+Definition le_trans:=O.
+
+
+Module Test_Read.     
+  Module M.  
+    Read Module Le.        (* Reading without importing *)
+
+    Check Le.le_trans.
+
+    Lemma th0 : le_trans = O.
+      Reflexivity.
+    Qed.
+  End M.
+
+  Check Le.le_trans. 
+
+  Lemma th0 : le_trans = O.
+    Reflexivity.
+  Qed.
+
+  Import M.
+
+  Lemma th1 : le_trans = O.
+    Reflexivity.
+  Qed.
+End Test_Read.
+
+
+(****************************************************************)
+
+Definition le_decide := (S O).  (* from Arith/Compare *)
+Definition min := O.            (* from Arith/Min *)
+
+Module Test_Require.
+  
+  Module M.
+    Require Compare.              (* Imports Min as well *)
+  
+    Lemma th1 : le_decide = Compare.le_decide.
+      Reflexivity.
+    Qed.
+  
+    Lemma th2 : min = Min.min.
+      Reflexivity.
+    Qed.
+  
+  End M.
+  
+  (* Checks that Compare and List are loaded *)
+  Check Compare.le_decide.
+  Check Min.min.
+  
+  
+  (* Checks that Compare and List are _not_ imported *)
+  Lemma th1 : le_decide = (S O).
+    Reflexivity.
+  Qed.
+  
+  Lemma th2 : min = O.
+    Reflexivity.
+  Qed.
+  
+  (* It should still be the case after Import M *)
+  Import M.
+  
+  Lemma th3 : le_decide = (S O).
+    Reflexivity.
+  Qed.
+  
+  Lemma th4 : min = O.
+    Reflexivity.
+  Qed.
+
+End Test_Require.  
+
+(****************************************************************)
+
+Module Test_Import.
+  Module M.
+    Import Compare.              (* Imports Min as well *)
+  
+    Lemma th1 : le_decide = Compare.le_decide.
+      Reflexivity.
+    Qed.
+  
+    Lemma th2 : min = Min.min.
+      Reflexivity.
+    Qed.
+  
+  End M.
+  
+  (* Checks that Compare and List are loaded *)
+  Check Compare.le_decide.
+  Check Min.min.
+  
+  
+  (* Checks that Compare and List are _not_ imported *)
+  Lemma th1 : le_decide = (S O).
+    Reflexivity.
+  Qed.
+  
+  Lemma th2 : min = O.
+    Reflexivity.
+  Qed.
+  
+  (* It should still be the case after Import M *)
+  Import M.
+  
+  Lemma th3 : le_decide = (S O).
+    Reflexivity.
+  Qed.
+  
+  Lemma th4 : min = O.
+    Reflexivity.
+  Qed.
+End Test_Import.
+
+(************************************************************************)
+
+Module Test_Export.
+  Module M.
+    Export Compare.              (* Exports Min as well *)
+
+    Lemma th1 : le_decide = Compare.le_decide.
+      Reflexivity.
+    Qed.
+
+    Lemma th2 : min = Min.min.
+      Reflexivity.
+    Qed.
+
+  End M.
+
+
+  (* Checks that Compare and List are _not_ imported *)
+  Lemma th1 : le_decide = (S O).
+    Reflexivity.
+  Qed.
+
+  Lemma th2 : min = O.
+    Reflexivity.
+  Qed.
+
+
+  (* After Import M they should be imported as well *)
+
+  Import M.
+
+  Lemma th3 : le_decide = Compare.le_decide.
+    Reflexivity.
+  Qed.
+
+  Lemma th4 : min = Min.min.
+    Reflexivity.
+  Qed.
+End Test_Export.
+
+
+(************************************************************************)
+
+Module Test_Require_Export.
+
+  Definition mult_sym:=(S O).    (* from Arith/Mult *)
+  Definition plus_sym:=O.        (* from Arith/Plus *)
+
+  Module M.
+    Require Export Mult.         (* Exports Plus as well *)
+
+    Lemma th1 : mult_sym = Mult.mult_sym.
+      Reflexivity.
+    Qed.
+
+    Lemma th2 : plus_sym = Plus.plus_sym.
+      Reflexivity.
+    Qed.
+
+  End M.
+
+
+  (* Checks that Mult and Plus are _not_ imported *)
+  Lemma th1 : mult_sym = (S O).
+    Reflexivity.
+  Qed.
+
+  Lemma th2 : plus_sym = O.
+    Reflexivity.
+  Qed.
+
+
+  (* After Import M they should be imported as well *)
+
+  Import M.
+
+  Lemma th3 : mult_sym = Mult.mult_sym.
+    Reflexivity.
+  Qed.
+
+  Lemma th4 : plus_sym = Plus.plus_sym.
+    Reflexivity.
+  Qed.
+
+End Test_Require_Export.
diff --git a/test-suite/success/import_mod.v b/test-suite/success/import_mod.v
new file mode 100644
index 00000000..b4a8af46
--- /dev/null
+++ b/test-suite/success/import_mod.v
@@ -0,0 +1,75 @@
+
+Definition p:=O.
+Definition m:=O.
+
+Module Test_Import.
+  Module P.
+    Definition p:=(S O).
+  End P.
+
+  Module M.
+    Import P.
+    Definition m:=p.
+  End M.
+
+  Module N.
+    Import M.
+
+    Lemma th0 : p=O.
+      Reflexivity.
+    Qed.
+
+  End N.
+
+
+  (* M and P should be closed *)
+  Lemma th1 : m=O /\ p=O.
+    Split; Reflexivity.
+  Qed.
+
+
+  Import N.
+
+  (* M and P should still be closed *)
+  Lemma th2 : m=O /\ p=O.
+    Split; Reflexivity.
+  Qed.
+End Test_Import.
+
+
+(********************************************************************)
+
+
+Module Test_Export.
+  Module P.
+    Definition p:=(S O).
+  End P.
+
+  Module M.
+    Export P.
+    Definition m:=p.
+  End M.
+
+  Module N.
+    Export M.
+
+    Lemma th0 : p=(S O).
+      Reflexivity.
+    Qed.
+
+  End N.
+
+
+  (* M and P should be closed *)
+  Lemma th1 : m=O /\ p=O.
+    Split; Reflexivity.
+  Qed.
+
+
+  Import N.
+
+  (* M and P should now be opened *)
+  Lemma th2 : m=(S O) /\ p=(S O).
+    Split; Reflexivity.
+  Qed.
+End Test_Export.
diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v
new file mode 100644
index 00000000..a391b804
--- /dev/null
+++ b/test-suite/success/inds_type_sec.v
@@ -0,0 +1,10 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+Section S.
+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
new file mode 100644
index 00000000..9ae498d2
--- /dev/null
+++ b/test-suite/success/induct.v
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* Teste des definitions inductives imbriquees *)
+
+Require PolyList.
+
+Inductive X : Set := 
+    cons1 : (list X)->X.
+
+Inductive Y : Set := 
+    cons2 : (list Y*Y)->Y.
+
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
new file mode 100644
index 00000000..55aa110d
--- /dev/null
+++ b/test-suite/success/ltac.v
@@ -0,0 +1,70 @@
+(* The tactic language *)
+
+(* Submitted by Pierre Crégut *)
+(* Checks substitution of x *)
+Tactic Definition f x := Unfold x; Idtac.
+ 
+Lemma lem1 : (plus O O) = O.
+f plus.
+Reflexivity.
+Qed.
+
+(* Submitted by Pierre Crégut *)
+(* Check syntactic correctness *)
+Recursive Tactic Definition F x := Idtac; (G x)
+And G y := Idtac; (F y).
+
+(* Check that Match Context keeps a closure *)
+Tactic Definition U := Let a = 'I In Match Context With [ |- ? ] -> Apply a.
+
+Lemma lem2 : True.
+U.
+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.
+
+Lemma lem3 : True -> False -> True -> False.
+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.
+
+Lemma lem4 : (True->False) -> (False->False) -> False.
+Intros H H0.
+Z. (* Apply H0 *)
+Y. (* Apply H *)
+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).
+Qed.
+
+Lemma back2 : (0)=(0)->(0)=(1)->(1)=(1)->(0)=(0).
+Intros; Match Context With [_:(O)=?1;_:(1)=(1)|-? ] -> Exact (refl_equal ? ?1).
+Qed.
+
+Lemma back3 : (0)=(0)->(1)=(1)->(0)=(1)->(0)=(0).
+Intros; Match Context With [_:(O)=?1;_:(1)=(1)|-? ] -> Exact (refl_equal ? ?1).
+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.
+Qed.
diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v
new file mode 100644
index 00000000..e932f50c
--- /dev/null
+++ b/test-suite/success/mutual_ind.v
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(* Definition mutuellement inductive et dependante *)
+
+Require Export PolyList.
+
+ 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;
+    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
+  }.
+
+ 
+ Variable F : signature.
+
+  Definition vsym := (sort F)*nat.
+
+  Definition vsym_sort := (fst (sort F) nat).
+  Definition vsym_nat := (snd (sort F) 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)).
+
diff --git a/test-suite/success/options.v b/test-suite/success/options.v
new file mode 100644
index 00000000..9e9af4fa
--- /dev/null
+++ b/test-suite/success/options.v
@@ -0,0 +1,34 @@
+(* Check that the syntax for options works *)
+Set Implicit Arguments.
+Unset Implicit Arguments.
+Test Implicit Arguments.
+
+Set Printing Coercions.
+Unset Printing Coercions.
+Test Printing Coercions.
+
+Set Silent.
+Unset Silent.
+Test Silent.
+
+Set Printing Depth 100.
+Print Table Printing Depth.
+
+Parameter i : bool -> nat.
+Coercion i : bool >-> nat.
+Set Printing Coercion i.
+Unset Printing Coercion i.
+Test Printing Coercion i.
+
+Print Table Printing Let.
+Print Table Printing If.
+Remove Printing Let sig.
+Remove Printing If bool.
+
+Unset Printing Synth.
+Set Printing Synth.
+Test Printing Synth.
+
+Unset Printing Wildcard.
+Set Printing Wildcard.
+Test Printing Wildcard.
diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v
new file mode 100644
index 00000000..ad4eed5a
--- /dev/null
+++ b/test-suite/success/refine.v
@@ -0,0 +1,30 @@
+
+(* Refine and let-in's *)
+
+Goal (EX x:nat | x=O).
+Refine let y = (plus O O) 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.
+Save test2.
+
+Goal nat.
+Refine let y = O in (plus O ?).
+Exact (S O).
+Save test3.
+
+(* Example submitted by Yves on coqdev *)
+
+Require PolyList.
+
+Goal (l:(list nat))l=l.
+Proof.
+Refine [l]<[l]l=l>
+       Cases l of
+       | nil => ?
+       | (cons O l0) => ?
+       | (cons (S _) l0) => ?
+       end.
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
new file mode 100644
index 00000000..2d2b2af8
--- /dev/null
+++ b/test-suite/success/setoid_test.v
@@ -0,0 +1,104 @@
+Require Setoid.
+
+Parameter A : Set.
+
+Axiom eq_dec : (a,b :A) {a=b}+{~a=b}.
+
+Inductive 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.
+
+Definition same [s,t:set] : Prop :=
+(a:A) (In a s) <-> (In a t).
+
+Lemma setoid_set : (Setoid_Theory set same).
+
+Unfold same; Split.
+Red; Auto.
+
+Red.
+Intros.
+Elim (H a); Auto.
+
+Intros.
+Elim (H a); Elim (H0 a).
+Split; Auto.
+Save.
+
+Add Setoid set same setoid_set.
+
+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.
+
+Add Morphism Add : Add_ext.
+Split; Apply add_aux.
+Assumption.
+
+Rewrite H.
+Apply Seq_refl.
+Exact setoid_set.
+Save.
+
+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 : (a:A)(s:set) ~(In a (remove a (Add a Empty))).
+
+Intros.
+Setoid_replace (remove a (Add a Empty)) with Empty.
+Unfold same.
+Split.
+Simpl.
+Intro H; Elim H.
+
+Simpl.
+Case (eq_dec a a).
+Intros e ff; Elim ff.
+
+Intros; Absurd a=a; Trivial.
+
+Auto.
+Save.
+
+Parameter P :set -> Prop.
+Parameter P_ext : (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.
+
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
new file mode 100644
index 00000000..de75dfce
--- /dev/null
+++ b/test-suite/success/unfold.v
@@ -0,0 +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        *)
+(************************************************************************)
+(* Test le Hint Unfold sur des var locales *)
+
+Section toto.
+Local EQ:=eq.
+Goal (EQ nat O O).
+Hints Unfold EQ.
+Auto.
+Save.
diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v
new file mode 100644
index 00000000..0a4b284f
--- /dev/null
+++ b/test-suite/success/univers.v
@@ -0,0 +1,19 @@
+(* This requires cumulativity *)
+
+Definition Type2 := Type.
+Definition Type1 := Type : Type2.
+
+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.
+Qed.
+
+Lemma lem3 : (P:Prop)P.
+Intro P ; Pattern P.
+Apply lem2.
+Abort.
diff --git a/test-suite/tactics/TestRefine.v b/test-suite/tactics/TestRefine.v
new file mode 100644
index 00000000..f752c5bc
--- /dev/null
+++ b/test-suite/tactics/TestRefine.v
@@ -0,0 +1,203 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Petit bench vite fait, mal fait *)
+
+Require Refine.
+
+
+(************************************************************************)
+
+Lemma essai : (x:nat)x=x.
+
+Refine (([x0:nat]Cases x0 of
+    O => ?
+  | (S p) => ?
+  end) :: (x:nat)x=x).  (* x0=x0 et x0=x0 *)
+
+Restart.
+
+Refine [x0:nat]<[n:nat]n=n>Case x0 of ? [p:nat]? end. (* OK *)
+
+Restart.
+
+Refine [x0:nat]<[n:nat]n=n>Cases x0 of O => ? | (S p) => ? end. (* OK *)
+
+Restart.
+
+(**
+Refine [x0:nat]Cases x0 of O => ? | (S p) => ? end. (* cannot be executed *)
+**)
+
+Abort.
+
+
+(************************************************************************)
+
+Lemma T : nat. 
+
+Refine (S ?).
+
+Abort.
+
+
+(************************************************************************)
+
+Lemma essai2 : (x:nat)x=x.
+
+Refine Fix f{f/1 : (x:nat)x=x := [x:nat]? }.
+
+Restart.
+
+Refine Fix f{f/1 : (x:nat)x=x :=
+  [x:nat]<[n:nat](eq nat n n)>Case x of ? [p:nat]? end}.
+
+Restart.
+
+Refine Fix f{f/1 : (x:nat)x=x :=
+  [x:nat]<[n:nat]n=n>Cases x of 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}.
+
+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}.
+
+Abort.
+
+
+(************************************************************************)
+
+Lemma essai : nat.
+
+Parameter f : nat*nat -> nat -> nat. 
+
+Refine (f ? ([x:nat](? :: nat) O)).
+
+Restart.
+
+Refine (f ? O).
+
+Abort.
+
+
+(************************************************************************)
+
+Parameter P : nat -> Prop.
+
+Lemma essai : { x:nat | x=(S O) }.
+
+Refine (exist nat ? (S O) ?).  (* 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) }).
+
+Restart.
+
+Refine (exist nat [x:nat](x=(S O)) (S O) ?).
+
+Abort.
+
+
+(************************************************************************)
+
+Lemma essai : (n:nat){ x:nat | x=(S n) }.
+
+Refine [n:nat]<[n:nat]{x:nat|x=(S n)}>Case n of ? [p:nat]? end.
+
+Restart.
+
+Refine (([n:nat]Case n of ? [p:nat]? end) :: (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.
+
+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}.
+
+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}.
+
+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.
+
+
+
+(* Quelques essais de recurrence bien fondée *)
+
+Require Wf.
+Require Wf_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.
+
+Abort.
+
+
+Require Compare_dec.
+Require 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).
+(*********
+Refine (well_founded_induction
+       nat
+       lt ?
+       [_:nat]nat
+       [x0:nat][fib:(x:nat)(lt x x0)->nat]
+         Cases x0 of 
+      	   O     => (S O)
+      	 | (S O) => (S O)
+      	 | (S (S p)) => (plus (fib (pred x0) ?)
+      	       	       	      (fib (pred (pred x0)) ?))
+	 end).
+***********)
+Exact lt_wf.
+Auto.
+Apply lt_trans with m:=(pred x0); Auto.
+Save.
+
+
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
new file mode 100755
index 00000000..d44efb56
--- /dev/null
+++ b/theories/Arith/Arith.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Arith.v,v 1.11.2.1 2004/07/16 19:30:59 herbelin Exp $ i*)
+
+Require Export Le.
+Require Export Lt.
+Require Export Plus.
+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.
\ No newline at end of file
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
new file mode 100755
index 00000000..448ce002
--- /dev/null
+++ b/theories/Arith/Between.v
@@ -0,0 +1,189 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:30:59 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+
+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 :
+      forall k l (n:nat),
+        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.
+
+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.
+
+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
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
new file mode 100644
index 00000000..55dfd47f
--- /dev/null
+++ b/theories/Arith/Bool_nat.v
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:30:59 herbelin Exp $ *)
+
+Require Export Compare_dec.
+Require Export Peano_dec.
+Require Import Sumbool.
+
+Open Local Scope nat_scope.
+
+Implicit Types 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 := sumbool_not _ _ (zerop n).
+Definition lt_ge_dec : forall x y, {x < y} + {x >= y} :=
+  fun n m => sumbool_not _ _ (le_lt_dec m n).
+
+Definition nat_lt_ge_bool x y := bool_of_sumbool (lt_ge_dec x y).
+Definition nat_ge_lt_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (lt_ge_dec x y)).
+
+Definition nat_le_gt_bool x y := bool_of_sumbool (le_gt_dec x y).
+Definition nat_gt_le_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (le_gt_dec x y)).
+
+Definition nat_eq_bool x y := bool_of_sumbool (eq_nat_dec x y).
+Definition nat_noteq_bool x y :=
+  bool_of_sumbool (sumbool_not _ _ (eq_nat_dec x y)).
+
+Definition zerop_bool x := bool_of_sumbool (zerop x).
+Definition notzerop_bool x := bool_of_sumbool (notzerop x).
\ No newline at end of file
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
new file mode 100755
index 00000000..46827bae
--- /dev/null
+++ b/theories/Arith/Compare.v
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:00 herbelin Exp $ 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 Peano_dec.
+Require Import Compare_dec.
+
+Definition le_or_le_S := le_le_S_dec.
+
+Definition Pcompare := gt_eq_gt_dec.
+
+Lemma le_dec : forall n m, {n <= m} + {m <= n}.
+Proof le_ge_dec.
+
+Definition lt_or_eq n m := {m > n} + {n = m}.
+
+Lemma le_decide : forall n m, n <= m -> lt_or_eq n m.
+Proof le_lt_eq_dec.
+
+Lemma le_le_S_eq : forall n m, n <= m -> S n <= m \/ n = m.
+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))).
+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.
+Qed.
+
+Require Export Wf_nat.
+
+Require Export Min.
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
new file mode 100755
index 00000000..ea21437d
--- /dev/null
+++ b/theories/Arith/Compare_dec.v
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.13.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+Require Import Gt.
+Require Import Decidable.
+
+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.
+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.
+Defined.
+
+Lemma gt_eq_gt_dec : forall n m, {m > n} + {n = m} + {n > m}.
+Proof lt_eq_lt_dec.
+
+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.
+Defined.
+
+Definition le_le_S_dec : forall n m, {n <= m} + {S m <= n}.
+Proof.
+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.
+Defined.
+
+Definition le_gt_dec : forall n m, {n <= m} + {n > m}.
+Proof.
+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.
+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 ].
+Qed.
+
+Theorem dec_lt : forall n m, decidable (n < m).
+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.
+Qed.
+
+Theorem dec_ge : forall n m, decidable (n >= m).
+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 ].
+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 ].
+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 ].
+Qed.
+
+Theorem not_ge : forall n m, ~ n >= m -> n < m.
+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). 
+Qed.
diff --git a/theories/Arith/Div.v b/theories/Arith/Div.v
new file mode 100755
index 00000000..adb5593d
--- /dev/null
+++ b/theories/Arith/Div.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: Div.v,v 1.8.2.1 2004/07/16 19:31:00 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/theories/Arith/Div2.v b/theories/Arith/Div2.v
new file mode 100644
index 00000000..c005f061
--- /dev/null
+++ b/theories/Arith/Div2.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.15.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Lt.
+Require Import Plus.
+Require Import Compare_dec.
+Require Import Even.
+
+Open Local Scope nat_scope.
+
+Implicit Type n : nat.
+
+(** Here we define [n/2] and prove some of its properties *)
+
+Fixpoint div2 n : nat :=
+  match n with
+  | O => 0
+  | S O => 0
+  | 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 :
+ 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.
+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.
+Qed.
+
+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)).
+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.
+Qed.
+
+(** Specializations *)
+
+Lemma even_div2 : forall n, even n -> div2 n = div2 (S n).
+Proof fun n => proj1 (proj1 (even_odd_div2 n)).
+
+Lemma div2_even : forall n, div2 n = div2 (S n) -> even n.
+Proof fun n => proj2 (proj1 (even_odd_div2 n)).
+
+Lemma odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n).
+Proof fun n => proj1 (proj2 (even_odd_div2 n)).
+
+Lemma div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n.
+Proof fun n => proj2 (proj2 (even_odd_div2 n)).
+
+Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.
+
+(** Properties related to the double ([2n]) *)
+
+Definition double n := n + n.
+
+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.
+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.
+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))).
+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.
+Qed.
+
+
+(** Specializations *)
+
+Lemma even_double : forall n, even n -> n = double (div2 n).
+Proof fun n => proj1 (proj1 (even_odd_double n)).
+
+Lemma double_even : forall n, n = double (div2 n) -> even n.
+Proof fun n => proj2 (proj1 (even_odd_double n)).
+
+Lemma odd_double : forall n, odd n -> n = S (double (div2 n)).
+Proof fun n => proj1 (proj2 (even_odd_double n)).
+
+Lemma double_odd : forall n, n = S (double (div2 n)) -> odd n.
+Proof fun n => proj2 (proj2 (even_odd_double n)).
+
+Hint 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 : forall n, even n -> {p : nat | n = double p}.
+Proof.
+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.
+Qed.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
new file mode 100755
index 00000000..2e99e068
--- /dev/null
+++ b/theories/Arith/EqNat.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: EqNat.v,v 1.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Equality on natural numbers *)
+
+Open Local Scope nat_scope.
+
+Implicit Types m n x y : nat.
+
+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
+  end.
+
+Theorem eq_nat_refl : forall n, eq_nat n n.
+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.
+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.
+Qed.
+Hint Immediate eq_nat_eq: arith v62.
+
+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.
+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.
+Defined.
+
+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
+  end.
+
+Lemma beq_nat_refl : forall n, true = beq_nat n n.
+Proof.
+  intro x; induction x; simpl in |- *; auto.
+Qed.
+
+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.
+Defined.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
new file mode 100644
index 00000000..e50e3d70
--- /dev/null
+++ b/theories/Arith/Euclid.v
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Mult.
+Require Import Compare_dec.
+Require Import Wf_nat.
+
+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.
+
+
+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.
+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.
+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
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
new file mode 100644
index 00000000..f7a2ad71
--- /dev/null
+++ b/theories/Arith/Even.v
@@ -0,0 +1,305 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:00 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. *)
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+Inductive even : nat -> Prop :=
+  | even_O : even 0
+  | even_S : forall n, odd n -> even (S n)
+with odd : nat -> Prop :=
+    odd_S : forall n, even n -> odd (S n).
+
+Hint Constructors even: arith.
+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.
+Qed.
+
+Lemma even_odd_dec : forall n, {even n} + {odd n}.
+Proof.
+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.
+Qed.
+
+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).
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+Hint Resolve odd_plus_l odd_plus_r: arith.
+ 
+Lemma even_mult_aux :
+ 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
new file mode 100644
index 00000000..4db211e4
--- /dev/null
+++ b/theories/Arith/Factorial.v
@@ -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: Factorial.v,v 1.5.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Plus.
+Require Import Mult.
+Require Import Lt.
+Open Local Scope nat_scope.
+
+(** Factorial *)
+
+Fixpoint fact (n:nat) : nat :=
+  match n with
+  | 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.
+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.
+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
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
new file mode 100755
index 00000000..299c664d
--- /dev/null
+++ b/theories/Arith/Gt.v
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Require Import Lt.
+Require Import Plus.
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Order and successor *)
+
+Theorem gt_Sn_O : forall n, S n > 0.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_Sn_O: arith v62.
+
+Theorem gt_Sn_n : forall n, S n > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_Sn_n: arith v62.
+
+Theorem gt_n_S : forall n m, n > m -> S n > S m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_n_S: arith v62.
+
+Lemma gt_S_n : forall n m, S m > S n -> m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate gt_S_n: arith v62.
+
+Theorem gt_S : forall n m, S n > m -> n > m \/ m = n.
+Proof.
+  intros n m H; unfold gt in |- *; apply le_lt_or_eq; auto with arith.
+Qed.
+
+Lemma gt_pred : forall n m, m > S n -> pred m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate gt_pred: arith v62.
+
+(** Irreflexivity *)
+
+Lemma gt_irrefl : forall n, ~ n > n.
+Proof lt_irrefl.
+Hint Resolve gt_irrefl: arith v62.
+
+(** 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 *)
+
+Lemma le_not_gt : forall n m, n <= m -> ~ n > m.
+Proof le_not_lt.
+Hint Resolve le_not_gt: arith v62.
+
+Lemma gt_not_le : forall n m, n > m -> ~ n <= m.
+Proof.
+auto with arith.
+Qed.
+
+Hint Resolve gt_not_le: arith v62.
+
+Theorem le_S_gt : forall n m, S n <= m -> m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Immediate le_S_gt: arith v62.
+
+Lemma gt_S_le : forall n m, S m > n -> n <= m.
+Proof.
+  intros n p; exact (lt_n_Sm_le n p).
+Qed.
+Hint Immediate gt_S_le: arith v62.
+
+Lemma gt_le_S : forall n m, m > n -> S n <= m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve gt_le_S: arith v62.
+
+Lemma le_gt_S : forall n m, n <= m -> S m > n.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve le_gt_S: arith v62.
+
+(** Transitivity *)
+
+Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
+Proof.
+  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+Qed.
+
+Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p.
+Proof.
+  red in |- *; intros; apply le_lt_trans with m; auto with arith.
+Qed.
+
+Lemma gt_trans : forall n m p, n > m -> m > p -> n > p.
+Proof.
+  red in |- *; intros n m p H1 H2.
+  apply lt_trans with m; auto with arith.
+Qed.
+
+Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p.
+Proof.
+  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+Qed.
+
+Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
+
+(** 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 *)
+
+Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
+Proof.
+  red in |- *; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
+Qed.
+
+Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
+Proof.
+  auto with arith.
+Qed.
+Hint Resolve plus_gt_compat_l: arith v62.
\ No newline at end of file
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
new file mode 100755
index 00000000..a5378cff
--- /dev/null
+++ b/theories/Arith/Le.v
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Order on natural numbers *)
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Reflexivity *)
+
+Theorem le_refl : forall n, n <= n.
+Proof.
+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 *)
+
+Theorem le_n_S : forall n m, n <= m -> S n <= S m.
+Proof.
+  induction 1; auto.
+Qed.
+
+Theorem le_n_Sn : forall n, n <= S n.
+Proof.
+  auto.
+Qed.
+
+Theorem le_O_n : forall n, 0 <= n.
+Proof.
+  induction n; auto.
+Qed.
+
+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.
+Proof.
+induction n; auto with arith.
+Qed.
+Hint Resolve le_pred_n: 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.
+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.
+Qed.
+Hint Immediate le_S_n: arith v62.
+
+Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
+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.
+Qed.
+
+(** Comparison to 0 *)
+
+Theorem le_Sn_O : forall n, ~ S n <= 0.
+Proof.
+red in |- *; intros n H.
+change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve le_Sn_O: arith v62.
+
+Theorem le_n_O_eq : forall n, n <= 0 -> 0 = n.
+Proof.
+induction n; auto with arith.
+intro; contradiction le_Sn_O with n.
+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.
+
+(** 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.
+Qed.
+Hint Immediate le_antisym: arith v62.
+
+(** A different elimination principle for the order on natural numbers *)
+
+Lemma le_elim_rel :
+ forall P:nat -> nat -> Prop,
+   (forall p, P 0 p) ->
+   (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
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
new file mode 100755
index 00000000..e1b3e4b8
--- /dev/null
+++ b/theories/Arith/Lt.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Le.
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Irreflexivity *)
+
+Theorem lt_irrefl : forall n, ~ n < n.
+Proof le_Sn_n.
+Hint Resolve lt_irrefl: arith v62.
+
+(** Relationship between [le] and [lt] *) 
+
+Theorem lt_le_S : forall n m, n < m -> S n <= m.
+Proof.
+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.
+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.
+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.
+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).
+Qed.
+Hint Immediate le_not_lt lt_not_le: arith v62.
+
+(** Asymmetry *)
+
+Theorem lt_asym : forall n m, n < m -> ~ m < n.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+(** Order and successor *)
+
+Theorem lt_n_Sn : forall n, n < S n.
+Proof.
+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.
+Qed.
+Hint Resolve lt_S: arith v62.
+
+Theorem lt_n_S : forall n m, n < m -> S n < S m.
+Proof.
+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.
+Qed.
+Hint Immediate lt_S_n: arith v62.
+
+Theorem lt_O_Sn : forall n, 0 < S n.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve lt_O_Sn: arith v62.
+
+Theorem lt_n_O : forall n, ~ n < 0.
+Proof le_Sn_O.
+Hint Resolve lt_n_O: arith v62.
+
+(** Predecessor *)
+
+Lemma S_pred : forall n m, m < n -> n = S (pred n).
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Lemma lt_pred : forall n m, S n < m -> n < pred m.
+Proof.
+induction 1; simpl in |- *; auto with arith.
+Qed.
+Hint Immediate lt_pred: arith v62.
+
+Lemma lt_pred_n_n : forall n, 0 < n -> pred n < n.
+destruct 1; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve lt_pred_n_n: arith v62.
+
+(** Transitivity properties *)
+
+Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
+Proof.
+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.
+Qed.
+
+Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
+Proof.
+induction 2; auto with arith.
+Qed.
+
+Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62.
+
+(** Large = strict or equal *)
+
+Theorem le_lt_or_eq : forall n m, n <= m -> n < m \/ n = m.
+Proof.
+induction 1; auto with arith.
+Qed.
+
+Theorem lt_le_weak : forall n m, n < m -> n <= m.
+Proof.
+auto with arith.
+Qed.
+Hint Immediate lt_le_weak: arith v62.
+
+(** 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.
+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.
+Qed.
+
+(** 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.
+Qed.
+Hint Immediate neq_O_lt: arith v62.
+
+Theorem lt_O_neq : forall n, 0 < n -> 0 <> n.
+Proof.
+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
new file mode 100755
index 00000000..82673ed0
--- /dev/null
+++ b/theories/Arith/Max.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Arith.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+(** 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')
+  end.
+
+(** Simplifications of [max] *)
+
+Lemma max_SS : forall n m, S (max n m) = max (S n) (S m).
+Proof.
+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.
+Qed.
+
+(** [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.
+Qed.
+
+Lemma max_r : forall n m, n <= m -> max n m = m.
+Proof.
+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.
+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.
+Qed.
+Hint 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 : 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.
+Qed.
+
+Lemma max_case : forall n m (P:nat -> Set), 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.
+Qed.
+
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
new file mode 100755
index 00000000..912e7ba3
--- /dev/null
+++ b/theories/Arith/Min.v
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Min.v,v 1.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Arith.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n : nat.
+
+(** 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')
+  end.
+
+(** Simplifications of [min] *)
+
+Lemma min_SS : forall n m, S (min n m) = min (S n) (S m).
+Proof.
+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.
+Qed.
+
+(** [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.
+Qed.
+
+Lemma min_r : forall n m, m <= n -> min n m = m.
+Proof.
+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.
+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.
+Qed.
+Hint 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 : 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.
+Qed.
+
+Lemma min_case : forall n m (P:nat -> Set), 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.
+
+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
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
new file mode 100755
index 00000000..ba9a46ad
--- /dev/null
+++ b/theories/Arith/Minus.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Subtraction (difference between two natural numbers) *)
+
+Require Import Lt.
+Require Import Le.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** 0 is right neutral *)
+
+Lemma minus_n_O : forall n, n = n - 0.
+Proof.
+induction n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_n_O: arith v62.
+
+(** 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.
+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.
+Qed.
+
+(** Diagonal *)
+
+Lemma minus_n_n : forall n, 0 = n - n.
+Proof.
+induction n; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_n_n: arith v62.
+
+(** Simplification *)
+
+Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
+Proof.
+  induction p; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve minus_plus_simpl_l_reverse: arith v62.
+
+(** 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.
+Qed.
+Hint Immediate plus_minus: arith v62.
+
+Lemma minus_plus : forall n m, n + m - n = m.
+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.
+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.
+Qed.
+Hint Resolve le_plus_minus_r: arith v62.
+
+(** 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 ].
+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.
+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.
+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
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
new file mode 100755
index 00000000..abfade57
--- /dev/null
+++ b/theories/Arith/Mult.v
@@ -0,0 +1,211 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.21.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Export Plus.
+Require Export Minus.
+Require Export Lt.
+Require Export Le.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+(** Zero property *)
+
+Lemma mult_0_r : forall n, n * 0 = 0.
+Proof.
+intro; symmetry  in |- *; apply mult_n_O.
+Qed.
+
+Lemma mult_0_l : forall n, 0 * n = 0.
+Proof.
+reflexivity.
+Qed.
+
+(** Distributivity *)
+
+Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
+Proof.
+intros; elim n; simpl in |- *; intros; auto with arith.
+elim plus_assoc; elim H; auto with arith.
+Qed.
+Hint Resolve mult_plus_distr_r: arith v62.
+
+Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
+Proof.
+  induction n. trivial.
+  intros. simpl in |- *. rewrite (IHn m p). apply sym_eq. apply plus_permute_2_in_4.
+Qed.
+
+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.
+
+(** Associativity *)
+
+Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
+Proof.
+intros; elim n; intros; simpl in |- *; auto with arith.
+rewrite mult_plus_distr_r.
+elim H; auto with arith.
+Qed.
+Hint Resolve mult_assoc_reverse: arith v62.
+
+Lemma mult_assoc : forall n m p, n * (m * p) = n * m * p.
+Proof.
+auto with arith.
+Qed.
+Hint Resolve mult_assoc: arith v62.
+
+(** Commutativity *)
+
+Lemma mult_comm : forall n m, n * m = m * n.
+Proof.
+intros; elim n; intros; simpl in |- *; auto with arith.
+elim mult_n_Sm.
+elim H; apply plus_comm.
+Qed.
+Hint Resolve mult_comm: arith v62.
+
+(** 1 is neutral *)
+
+Lemma mult_1_l : forall n, 1 * n = n.
+Proof.
+simpl in |- *; auto with arith.
+Qed.
+Hint Resolve mult_1_l: arith v62.
+
+Lemma mult_1_r : forall n, n * 1 = n.
+Proof.
+intro; elim mult_comm; auto with arith.
+Qed.
+Hint Resolve mult_1_r: arith v62.
+
+(** Compatibility with orders *)
+
+Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n.
+Proof.
+induction m; simpl in |- *; auto with arith.
+Qed.
+Hint Resolve mult_O_le: arith v62.
+
+Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m.
+Proof.
+  induction p as [| p IHp]. intros. simpl in |- *. apply le_n.
+  intros. simpl in |- *. apply plus_le_compat. assumption.
+  apply IHp. assumption.
+Qed.
+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.
+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.
+Qed.
+
+Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
+Proof.
+  intro m; induction m. intros. simpl in |- *. rewrite <- plus_n_O. rewrite <- plus_n_O. assumption.
+  intros. exact (plus_lt_compat _ _ _ _ H (IHm _ _ H)).
+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.
+Qed.
+
+Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
+Proof.
+  intros m n p H. elim (le_or_lt n p). trivial.
+  intro H0. cut (S m * n < S m * n). intro. elim (lt_irrefl _ H1).
+  apply le_lt_trans with (m := S m * p). assumption.
+  apply mult_S_lt_compat_l. assumption.
+Qed.
+
+(** 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.
+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:nat) m n {struct n} : nat :=
+  match n with
+  | 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.
+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.
+Qed.
+
+(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] 
+    and [mult] and simplify *)
+
+Ltac tail_simpl :=
+  repeat rewrite <- plus_tail_plus; repeat rewrite <- mult_tail_mult;
+   simpl in |- *. 
\ No newline at end of file
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
new file mode 100755
index 00000000..01204ee6
--- /dev/null
+++ b/theories/Arith/Peano_dec.v
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+Require Import Decidable.
+
+Open Local Scope nat_scope.
+
+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.
+Defined.
+
+Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}.
+Proof.
+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.
+Defined.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
new file mode 100755
index 00000000..e4ac631e
--- /dev/null
+++ b/theories/Arith/Plus.v
@@ -0,0 +1,202 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.18.2.1 2004/07/16 19:31:00 herbelin Exp $ i*)
+
+(** Properties of addition *)
+
+Require Import Le.
+Require Import Lt.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p q : nat.
+
+(** Zero is neutral *)
+
+Lemma plus_0_l : forall n, 0 + n = n.
+Proof.
+reflexivity.
+Qed.
+
+Lemma plus_0_r : forall n, n + 0 = n.
+Proof.
+intro; symmetry  in |- *; apply plus_n_O.
+Qed.
+
+(** 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.
+Qed.
+Hint Immediate plus_comm: arith v62.
+
+(** 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.
+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.
+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.
+Qed.
+
+Lemma plus_assoc_reverse : forall n m p, n + m + p = n + (m + p).
+Proof.
+auto with arith.
+Qed.
+Hint Resolve plus_assoc_reverse: arith v62.
+
+(** 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.
+Qed.
+
+Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
+Proof.
+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.
+Qed.
+
+(** 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q.
+Proof.
+  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. rewrite plus_Snm_nSm.
+  apply plus_le_compat; assumption.
+Qed.
+
+Lemma plus_lt_le_compat : forall n m p q, n < m -> p <= q -> n + p < m + q.
+Proof.
+  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. apply plus_le_compat; assumption.
+Qed.
+
+Lemma plus_lt_compat : forall n m p q, n < m -> p < q -> n + p < m + q.
+Proof.
+  intros. apply plus_lt_le_compat. assumption.
+  apply lt_le_weak. assumption.
+Qed.
+
+(** Inversion lemmas *)
+
+Lemma plus_is_O : forall n m, n + m = 0 -> n = 0 /\ m = 0.
+Proof.
+  intro m; destruct m as [| n]; auto.
+  intros. discriminate H.
+Qed.
+
+Definition plus_is_one :
+  forall m n, m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}.
+Proof.
+  intro m; destruct m as [| n]; auto.
+  destruct n; auto.
+  intros. 
+  simpl in H. discriminate H.
+Defined.
+
+(** Derived properties *)
+
+Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q).
+Proof.
+  intros m n p q. 
+  rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q).
+  rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc.
+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 {struct n} : nat :=
+  match n with
+  | O => q
+  | S p => plus_acc (S q) p
+  end.
+
+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
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
new file mode 100755
index 00000000..8bf237b5
--- /dev/null
+++ b/theories/Arith/Wf_nat.v
@@ -0,0 +1,206 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:31:01 herbelin Exp $ i*)
+
+(** Well-founded relations and natural numbers *)
+
+Require Import Lt.
+
+Open Local Scope nat_scope.
+
+Implicit Types m n p : nat.
+
+Section Well_founded_Nat.
+
+Variable A : Set.
+
+Variable f : A -> nat.
+Definition ltof (a b:A) := f a < f b.
+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.
+
+Theorem well_founded_gtof : well_founded 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 :
+ 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.
+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.
+Proof.
+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.
+Proof.
+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.
+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 : 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.
+
+End Well_founded_Nat.
+
+Lemma lt_wf : well_founded lt.
+Proof well_founded_ltof nat (fun m => m).
+
+Lemma lt_wf_rec1 :
+ 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).
+Defined.
+
+Lemma lt_wf_rec :
+ 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).
+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.
+Qed.
+
+Lemma gt_wf_rec :
+ forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
+Proof.
+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.
+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.
+Defined.
+
+Lemma lt_wf_double_ind :
+ 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.
+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.
+
+
+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
diff --git a/theories/Arith/intro.tex b/theories/Arith/intro.tex
new file mode 100755
index 00000000..655de34c
--- /dev/null
+++ b/theories/Arith/intro.tex
@@ -0,0 +1,55 @@
+\section{Arith}\label{Arith}
+
+The {\tt Arith} library deals with various arithmetical notions and 
+their properties.
+
+\subsection*{Standard {\tt Arith} library}
+
+The following files are automatically loaded by {\tt Require Arith}.
+
+\begin{itemize}
+
+\item {\tt Le.v} states and proves properties of the large order {\tt le}.
+
+\item {\tt Lt.v} states and proves properties of the strict order {\tt 
+lt} (especially, the relationship with {\tt le}).
+
+\item {\tt Plus.v} states and proves properties on the addition.
+
+\item {\tt Gt.v} states and proves properties on the strict order {\tt gt}.
+
+\item {\tt Minus.v} defines the difference on 
+{\tt nat} and proves properties of it. On {\tt nat}, {\tt (minus n p)} is 
+{\tt O} if {\tt n} $<$ {\tt p}.
+
+\item {\tt Mult.v} states and proves properties on the multiplication.
+
+\item {\tt Between.v} defines modalities on {\tt nat} and proves properties 
+of them.
+
+\end{itemize}
+
+\subsection*{Additional {\tt Arith} library}
+
+\begin{itemize}
+
+\item {\tt Compare.v}, {\tt Compare\_dec.v} and {\tt Peano\_dec.v} state
+and prove various decidability results on {\tt nat}.
+
+\item {\tt Wf\_nat.v} states and proves various induction and recursion 
+principles on {\tt nat}. Especially, recursion for objects measurable by 
+a natural number and recursion on {\tt nat * nat} are provided.
+
+\item {\tt Min.v} defines the minimum of two natural numbers and proves 
+properties of it. 
+
+\item {\tt Eqnat.v} defines a specific equality on {\tt nat} and shows 
+the equivalence with Leibniz' equality.
+
+\item {\tt Euclid.v} proves that the euclidean
+division specification is realisable. Conversely, {\tt Div.v} exhibits
+two different algorithms and semi-automatically reconstruct the proof of
+their correctness. These files emphasize the extraction of program vs
+reconstruction of proofs paradigm.
+
+\end{itemize}
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
new file mode 100755
index 00000000..854eb9e3
--- /dev/null
+++ b/theories/Bool/Bool.v
@@ -0,0 +1,543 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.29.2.1 2004/07/16 19:31:01 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) :=
+  match b with
+  | 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.
+
+Lemma Is_true_eq_right : forall x:bool, true = x -> Is_true x.
+Proof.
+  intros; rewrite <- H; auto with bool.
+Qed.
+
+Hint Immediate Is_true_eq_right Is_true_eq_left: bool.
+
+(*******************)
+(** 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.
+Qed.
+Hint Resolve diff_true_false: bool v62.
+
+Lemma diff_false_true : false <> true.
+Proof.
+red in |- *; intros H; apply diff_true_false.
+symmetry  in |- *.
+assumption.
+Qed.
+Hint Resolve diff_false_true: bool v62.
+
+Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False.
+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.
+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.
+Qed.
+
+(**********************)
+(** Order on booleans *)
+(**********************)
+
+Definition leb (b1 b2:bool) :=
+  match b1 with
+  | true => b2 = true
+  | false => True
+  end.
+Hint Unfold leb: bool v62.
+
+(*************)
+(** Equality *)
+(*************)
+
+Definition eqb (b1 b2:bool) : bool :=
+  match b1, b2 with
+  | 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.
+Qed.
+
+Lemma eqb_reflx : forall b:bool, eqb b b = true.
+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.
+Qed.
+
+
+(************************)
+(** Logical combinators *)
+(************************)
+ 
+Definition ifb (b1 b2 b3:bool) : bool :=
+  match b1 with
+  | true => b2
+  | false => b3
+  end.
+
+Definition andb (b1 b2:bool) : bool := ifb b1 b2 false.
+
+Definition orb (b1 b2:bool) : bool := ifb b1 true b2.
+
+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
+  end.
+
+Definition negb (b:bool) := match b with
+                            | true => false
+                            | false => true
+                            end.
+
+Infix "||" := orb (at level 50, left associativity) : bool_scope.
+Infix "&&" := andb (at level 40, left associativity) : bool_scope.
+
+Open Scope bool_scope.
+
+Delimit Scope bool_scope with bool.
+
+Bind Scope bool_scope with bool.
+
+(**************************)
+(** Lemmas about [negb]   *)
+(**************************)
+
+Lemma negb_intro : forall b:bool, b = negb (negb b).
+Proof.
+destruct b; reflexivity.
+Qed.
+
+Lemma negb_elim : forall b:bool, negb (negb b) = b.
+Proof.
+destruct b; reflexivity.
+Qed.
+       
+Lemma negb_orb : forall b1 b2:bool, negb (b1 || b2) = negb b1 && negb b2.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma negb_andb : forall b1 b2:bool, negb (b1 && b2) = negb b1 || negb b2.
+Proof.
+  destruct b1; destruct b2; simpl in |- *; reflexivity.
+Qed.
+
+Lemma negb_sym : forall b b':bool, b' = negb b -> b = negb b'.
+Proof.
+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.
+Qed.
+
+Lemma eqb_negb1 : forall b:bool, eqb (negb b) b = false.
+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.
+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).
+Proof.
+  destruct b; trivial.
+Qed.
+
+
+(****************************)
+(** A few lemmas about [or] *)
+(****************************)
+
+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_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.
+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.
+Qed.
+Hint Resolve orb_true_intro: bool v62.
+
+Lemma orb_b_true : forall b:bool, b || true = true.
+auto with bool.
+Qed.
+Hint Resolve orb_b_true: bool v62.
+
+Lemma orb_true_b : forall b:bool, true || b = true.
+trivial with bool.
+Qed.
+
+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_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.
+Qed.
+Hint Resolve orb_false_intro: bool v62.
+
+Lemma orb_b_false : forall b:bool, b || false = b.
+Proof.
+  destruct b; trivial with bool.
+Qed.
+Hint Resolve orb_b_false: bool v62.
+
+Lemma orb_false_b : forall b:bool, false || b = b.
+Proof.
+  destruct b; trivial with bool.
+Qed.
+Hint Resolve orb_false_b: bool v62.
+
+Lemma orb_false_elim :
+ forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false.
+Proof.
+  destruct b1.
+  intros; elim diff_true_false; auto with bool.
+  destruct b2.
+  intros; elim diff_true_false; auto with bool.
+  auto with bool.
+Qed.
+
+Lemma orb_neg_b : forall b:bool, b || negb b = true.
+Proof.
+  destruct b; reflexivity.
+Qed.
+Hint Resolve orb_neg_b: bool v62.
+
+Lemma orb_comm : forall b1 b2:bool, b1 || b2 = b2 || b1.
+destruct b1; destruct b2; reflexivity.
+Qed.
+
+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 orb_b_false orb_false_b: bool v62.
+
+(*****************************)
+(** A few lemmas about [and] *)
+(*****************************)
+
+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.
+Qed.
+Hint Resolve andb_prop: bool v62.
+
+Definition 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.
+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.
+Qed.
+
+Lemma andb_false_intro2 : forall b1 b2:bool, b2 = false -> b1 && b2 = false.
+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.
+Qed.
+
+Lemma andb_false_b : forall b:bool, false && b = false.
+trivial with bool.
+Qed.
+
+Lemma andb_b_true : forall b:bool, b && true = b.
+destruct b; auto with bool.
+Qed.
+
+Lemma andb_true_b : forall b:bool, true && b = b.
+trivial with bool.
+Qed.
+
+Definition andb_false_elim :
+  forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}.
+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.
+Qed.   
+Hint Resolve andb_neg_b: bool v62.
+
+Lemma andb_comm : forall b1 b2:bool, b1 && b2 = b2 && b1.
+destruct b1; destruct b2; reflexivity.
+Qed.
+
+Lemma andb_assoc : forall b1 b2 b3:bool, b1 && (b2 && b3) = b1 && b2 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Hint Resolve andb_comm andb_assoc: bool v62.
+
+(*******************************)
+(** Properties of [xorb]       *)
+(*******************************)
+
+Lemma xorb_false : forall b:bool, xorb b false = b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma false_xorb : forall b:bool, xorb false b = b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma xorb_true : forall b:bool, xorb b true = negb b.
+Proof.
+  trivial.
+Qed.
+
+Lemma true_xorb : forall b:bool, xorb true b = negb b.
+Proof.
+  destruct b; trivial.
+Qed.
+
+Lemma xorb_nilpotent : forall b:bool, xorb b b = false.
+Proof.
+  destruct b; trivial.
+Qed.
+
+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'').
+Proof.
+  destruct b; destruct b'; destruct b''; trivial.
+Qed.
+
+Lemma xorb_eq : forall b b':bool, xorb b b' = false -> b = b'.
+Proof.
+  destruct b; destruct b'; trivial.
+  unfold xorb in |- *. intros. rewrite H. reflexivity.
+Qed.
+
+Lemma xorb_move_l_r_1 :
+ 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'.
+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''.
+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'.
+Proof.
+  intros. rewrite H. rewrite xorb_assoc. rewrite xorb_nilpotent. apply xorb_false.
+Qed.
+
+(*******************************)
+(** De Morgan's law            *)
+(*******************************)
+
+Lemma demorgan1 :
+ forall b1 b2 b3:bool, b1 && (b2 || b3) = b1 && b2 || b1 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan2 :
+ forall b1 b2 b3:bool, (b1 || b2) && b3 = b1 && b3 || b2 && b3.
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan3 :
+ forall b1 b2 b3:bool, b1 || b2 && b3 = (b1 || b2) && (b1 || b3).
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+Lemma demorgan4 :
+ forall b1 b2 b3:bool, b1 && b2 || b3 = (b1 || b3) && (b2 || b3).
+destruct b1; destruct b2; destruct b3; reflexivity.
+Qed.
+
+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.
+
+
+(** Misc. equalities between booleans (to be used by Auto) *)
+
+Lemma bool_1 : forall b1 b2:bool, (b1 = true <-> b2 = true) -> b1 = b2. 
+Proof. 
+ intros b1 b2; case b1; case b2; intuition.
+Qed.
+
+Lemma bool_2 : forall b1 b2:bool, b1 = b2 -> b1 = true -> b2 = true.
+Proof. 
+ intros b1 b2; case b1; case b2; intuition.
+Qed. 
+
+Lemma bool_3 : forall b:bool, negb b <> true -> b = true.
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_4 : forall b:bool, b = true -> negb b <> true.  
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_5 : forall b:bool, negb b = true -> b <> true.
+Proof.
+  destruct b; intuition.
+Qed.
+
+Lemma bool_6 : forall b:bool, b <> true -> negb b = true.  
+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
new file mode 100644
index 00000000..e038b3da
--- /dev/null
+++ b/theories/Bool/BoolEq.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:02 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 : forall x:A, true = beq x x.
+
+  Variable beq_eq : forall x y:A, true = beq x y -> x = y.
+
+  Definition beq_eq_true : forall 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 : forall 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 : forall x y:A, false = beq x y -> x <> y.
+  Proof.
+    exact
+     (fun (x y:A) (H:false = beq x y) (e:x = y) => beq_eq_not_false x y e H).
+  Defined.
+
+  Definition exists_beq_eq : forall x y:A, {b : bool | b = beq x y}.
+  Proof.
+    intros.
+    exists (beq x y).
+    constructor.
+  Defined.
+
+  Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y.
+  Proof.
+    intros x y H.
+    symmetry  in |- *.
+    apply not_true_is_false.
+    intro.
+    apply H.
+    apply beq_eq.
+    symmetry  in |- *.
+    assumption.
+  Defined.
+
+  Definition eq_dec : forall 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/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
new file mode 100644
index 00000000..51d940cf
--- /dev/null
+++ b/theories/Bool/Bvector.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Bvector.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
+
+Require Export Bool.
+Require Export Sumbool.
+Require Import Arith.
+
+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 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.
+Defined.
+
+Definition Vtail : forall n:nat, vector (S n) -> vector n.
+Proof.
+	intros n v; inversion v; 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).
+Defined.
+
+Definition Vconst : forall (a:A) (n:nat), vector n.
+Proof.
+	induction n as [| n v].
+	exact Vnil.
+
+	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)).
+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)).
+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)).
+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 *.
+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)).
+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)).
+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.
+
+	inversion v; inversion v0.
+	exact (Vcons (g a a0) n (h H0 H2)).
+Defined.
+
+End VECTORS.
+
+(* suppressed: incompatible with Coq-Art book 
+Implicit Arguments Vnil [A].
+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).
+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) {struct p} :
+ Bvector (S n) :=
+  match p with
+  | 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) :=
+  match p with
+  | 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) :=
+  match p with
+  | 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
new file mode 100755
index 00000000..1998fb8e
--- /dev/null
+++ b/theories/Bool/DecBool.v
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: DecBool.v,v 1.6.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+Definition ifdec (A B:Prop) (C:Set) (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.
+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.
+Qed.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
new file mode 100755
index 00000000..a00449d8
--- /dev/null
+++ b/theories/Bool/IfProp.v
@@ -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: IfProp.v,v 1.7.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Import Bool.
+
+Inductive IfProp (A B:Prop) : bool -> Prop :=
+  | Iftrue : A -> IfProp A B true
+  | Iffalse : B -> IfProp A B false.
+
+Hint Resolve Iftrue Iffalse: bool v62.
+
+Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A.
+destruct 1; intros; auto with bool.
+case diff_true_false; auto with bool.
+Qed.
+
+Lemma Iffalse_inv :
+ forall (A B:Prop) (b:bool), IfProp A B b -> b = false -> B.
+destruct 1; intros; auto with bool.
+case diff_true_false; trivial with bool.
+Qed.
+
+Lemma IfProp_true : forall A B:Prop, IfProp A B true -> A.
+intros.
+inversion H.
+assumption.
+Qed.
+
+Lemma IfProp_false : forall A B:Prop, IfProp A B false -> B.
+intros.
+inversion H.
+assumption.
+Qed.
+
+Lemma IfProp_or : forall (A B:Prop) (b:bool), IfProp A B b -> A \/ B.
+destruct 1; auto with bool.
+Qed.
+
+Lemma IfProp_sum : forall (A B:Prop) (b:bool), IfProp A B b -> {A} + {B}.
+destruct b; intro H.
+left; inversion H; auto with bool.
+right; inversion H; auto with bool.
+Qed.
\ No newline at end of file
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
new file mode 100644
index 00000000..8188f038
--- /dev/null
+++ b/theories/Bool/Sumbool.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        *)
+(************************************************************************)
+
+(*i $Id: Sumbool.v,v 1.12.2.1 2004/07/16 19:31:03 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 : forall b:bool, {b = true} + {b = false}.
+Proof.
+  destruct b; auto.
+Defined.
+
+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.
+Defined.
+
+Definition bool_eq_ind :
+  forall (b:bool) (P:bool -> Prop),
+    (b = true -> P true) -> (b = false -> P false) -> P b.
+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.
+
+End connectives.
+
+Hint 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 :
+  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 ].
+Defined.
+Implicit Arguments bool_of_sumbool.
\ No newline at end of file
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
new file mode 100755
index 00000000..b654e556
--- /dev/null
+++ b/theories/Bool/Zerob.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Zerob.v,v 1.8.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Require Import Arith.
+Require Import Bool.
+
+Open Local Scope nat_scope.
+
+Definition zerob (n:nat) : bool :=
+  match n with
+  | O => true
+  | S _ => false
+  end.
+
+Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true.
+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 ].
+Qed.
+
+Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false.
+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 ].
+Qed.
\ No newline at end of file
diff --git a/theories/Bool/intro.tex b/theories/Bool/intro.tex
new file mode 100644
index 00000000..22ee38aa
--- /dev/null
+++ b/theories/Bool/intro.tex
@@ -0,0 +1,16 @@
+\section{Bool}\label{Bool}
+
+The BOOL library includes the following files:
+
+\begin{itemize}
+
+\item {\tt Bool.v} defines standard operations on booleans and states
+  and proves simple facts on them.
+\item {\tt IfProp.v} defines a disjunction which contains its proof
+  and states its properties.
+\item {\tt Zerob.v} defines the test against 0 on natural numbers and
+  states and proves properties of it.
+\item {\tt Orb.v} states and proves facts on the boolean or.
+\item {\tt DecBool.v} defines a conditional from a proof of
+  decidability and states its properties.
+\end{itemize}
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
new file mode 100755
index 00000000..6aeabe13
--- /dev/null
+++ b/theories/Init/Datatypes.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Datatypes.v,v 1.26.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+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] *)
+
+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.
+
+Delimit 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 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 *)
+
+Inductive option (A:Set) : Set :=
+  | 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] *)
+(* 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.
+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.
+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).
+Proof.
+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.
+Proof.
+destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
+rewrite Hfst; rewrite Hsnd; reflexivity. 
+Qed.
+
+
+(** Comparison *)
+
+Inductive comparison : Set :=
+  | Eq : comparison
+  | Lt : comparison
+  | Gt : comparison.
+
+Definition CompOpp (r:comparison) :=
+  match r with
+  | Eq => Eq
+  | Lt => Gt
+  | Gt => Lt
+  end.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
new file mode 100755
index 00000000..bae8d4a1
--- /dev/null
+++ b/theories/Init/Logic.v
@@ -0,0 +1,279 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.29.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+Require Import Notations.
+
+(** * Propositional connectives *)
+
+(** [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.
+
+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 
+      [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 : A /\ B -> A.
+  Proof.
+  destruct 1; trivial.
+  Qed.
+
+  Theorem proj2 : A /\ B -> B.
+  Proof.
+  destruct 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) := (A -> B) /\ (B -> A).
+
+Notation "A <-> B" := (iff A B) : type_scope.
+
+Section Equivalence.
+
+Theorem iff_refl : forall A:Prop, A <-> A.
+  Proof.
+    split; auto.
+  Qed.
+
+Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
+  Proof.
+    intros A B C [H1 H2] [H3 H4]; split; auto.
+  Qed.
+
+Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
+  Proof.
+    intros A B [H1 H2]; split; auto.
+  Qed.
+
+End Equivalence.
+
+(** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
+    either [P] and [Q], or [~P] and [Q] *)
+
+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.
+*)
+
+Inductive ex (A:Type) (P:A -> Prop) : Prop :=
+    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.
+
+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.
+Notation "'exists' x : t , p" := (ex (fun x:t => p))
+  (at level 200, x ident, 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.
+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 ']'")
+  : type_scope.
+
+
+(** Derived rules for universal quantification *)
+
+Section universal_quantification.
+
+  Variable A : Type.
+  Variable P : A -> Prop.
+
+  Theorem inst : forall x:A, all (fun x => P x) -> P x.
+  Proof.
+  unfold all in |- *; auto.
+  Qed.
+
+  Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
+  Proof.
+  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].
+    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] *)
+
+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" := (x = y :>_) : type_scope.
+Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
+Notation "x <> y" := (x <> y :>_) : type_scope.
+
+Implicit Arguments eq_ind [A].
+Implicit Arguments eq_rec [A].
+Implicit Arguments eq_rect [A].
+
+Hint Resolve I conj or_introl or_intror refl_equal: core v62.
+Hint Resolve ex_intro ex_intro2: core v62.
+
+Section Logic_lemmas.
+
+  Theorem absurd : forall A C:Prop, A -> ~ A -> C.
+  Proof.
+    unfold not in |- *; intros A C h1 h2.
+    destruct (h2 h1).
+  Qed.
+
+  Section equality.
+    Variables A B : Type.
+    Variable f : A -> B.
+    Variables x y z : A.
+
+    Theorem sym_eq : x = y -> y = x.
+    Proof.
+     destruct 1; trivial.
+    Defined.
+    Opaque sym_eq.
+
+    Theorem trans_eq : x = y -> y = z -> x = z.
+    Proof.
+     destruct 2; trivial.
+    Defined.
+    Opaque trans_eq.
+
+    Theorem f_equal : x = y -> f x = f y.
+    Proof.
+     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.
+    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.
+  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.
+  Defined.
+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.
+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.
+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.
+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.
+Proof.
+  destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
+Qed.
+
+Hint Immediate sym_eq sym_not_eq: core v62.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
new file mode 100755
index 00000000..0e62e842
--- /dev/null
+++ b/theories/Init/Logic_Type.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Logic_Type.v,v 1.19.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** This module defines quantification on the world [Type]
+    ([Logic.v] was defining it on the world [Set]) *)
+
+Require Import Datatypes.
+Require Export Logic.
+
+Definition notT (A:Type) := A -> False.
+
+Section identity_is_a_congruence.
+
+ Variables A B : Type.
+ Variable f : A -> B.
+
+ Variables x y z : A.
+ 
+ Lemma sym_id : identity x y -> identity y x.
+ Proof.
+  destruct 1; trivial.
+ Qed.
+
+ Lemma trans_id : identity x y -> identity y z -> identity x z.
+ Proof.
+  destruct 2; trivial.
+ Qed.
+
+ Lemma congr_id : identity x y -> identity (f x) (f y).
+ Proof.
+  destruct 1; trivial.
+ Qed.
+
+ Lemma sym_not_id : notT (identity x y) -> notT (identity y x).
+ Proof.
+  red in |- *; intros H H'; apply H; destruct H'; trivial.
+ Qed.
+
+End identity_is_a_congruence.
+
+Definition identity_ind_r :
+  forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
+ intros A x P H y H0; case sym_id with (1 := H0); trivial.
+Defined.
+
+Definition identity_rec_r :
+  forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
+ intros A x P H y H0; case sym_id with (1 := H0); trivial.
+Defined.
+
+Definition identity_rect_r :
+  forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
+ 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
new file mode 100644
index 00000000..2e7cb1fc
--- /dev/null
+++ b/theories/Init/Notations.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        *)
+(************************************************************************)
+
+(*i $Id: Notations.v,v 1.24.2.1 2004/07/16 19:31:03 herbelin Exp $ i*)
+
+(** These are the notations whose level and associativity is imposed by Coq *)
+
+(** Notations for logical connectives *)
+
+Reserved Notation "x <-> y" (at level 95, no associativity).
+Reserved Notation "x /\ y" (at level 80, right associativity).
+Reserved Notation "x \/ y" (at level 85, right associativity).
+Reserved Notation "~ x" (at level 75, right associativity).
+
+(** Notations for equality and inequalities *)
+
+Reserved Notation "x = y  :> T"
+(at level 70, y at next level, no associativity).
+Reserved Notation "x = y" (at level 70, no associativity).
+Reserved Notation "x = y = z"
+(at level 70, no associativity, y at next level).
+
+Reserved Notation "x <> y  :> T"
+(at level 70, y at next level, no associativity).
+Reserved Notation "x <> y" (at level 70, no associativity).
+
+Reserved Notation "x <= y" (at level 70, no associativity).
+Reserved Notation "x < y" (at level 70, no associativity).
+Reserved Notation "x >= y" (at level 70, no associativity).
+Reserved Notation "x > y" (at level 70, no associativity).
+
+Reserved Notation "x <= y <= z" (at level 70, y at next level).
+Reserved Notation "x <= y < z" (at level 70, y at next level).
+Reserved Notation "x < y < z" (at level 70, y at next level).
+Reserved Notation "x < y <= z" (at level 70, y at next level).
+
+(** Arithmetical notations (also used for type constructors) *)
+
+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 / y" (at level 40, left associativity).
+Reserved Notation "- x" (at level 35, right associativity).
+Reserved Notation "/ x" (at level 35, right associativity).
+Reserved Notation "x ^ y" (at level 30, right associativity).
+
+(** Notations for pairs *)
+
+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 *)
+
+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 : A  |  P }" (at level 0, x at level 99).
+Reserved Notation "{ x : A  |  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).
+
+Delimit Scope type_scope with type.
+Delimit Scope core_scope with core.
+
+Open Scope core_scope.
+Open Scope type_scope.
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
new file mode 100755
index 00000000..789a020f
--- /dev/null
+++ b/theories/Init/Peano.v
@@ -0,0 +1,210 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.23.2.1 2004/07/16 19:31:03 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 Import Notations.
+Require Import Datatypes.
+Require Import Logic.
+
+Open Scope nat_scope.
+
+Definition eq_S := f_equal S.
+
+Hint Resolve (f_equal S): v62.
+Hint Resolve (f_equal (A:=nat)): core.
+
+(** The predecessor function *)
+
+Definition pred (n:nat) : nat := match n with
+                                 | O => 0
+                                 | S u => u
+                                 end.
+Hint Resolve (f_equal pred): v62.
+
+Theorem pred_Sn : forall n:nat, n = pred (S n).
+Proof.
+  auto.
+Qed.
+
+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.
+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.
+Qed.
+Hint Resolve not_eq_S: core v62.
+
+Definition IsSucc (n:nat) : Prop :=
+  match n with
+  | O => False
+  | S p => True
+  end.
+
+
+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 ].
+Qed.
+Hint Resolve O_S: core v62.
+
+Theorem n_Sn : forall n:nat, n <> S n.
+Proof.
+  induction n; auto.
+Qed.
+Hint Resolve n_Sn: core v62.
+
+(** Addition *)
+
+Fixpoint plus (n m:nat) {struct n} : nat :=
+  match n with
+  | O => m
+  | S p => S (plus p m)
+  end.
+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.
+Qed.
+Hint Resolve plus_n_O: core v62.
+
+Lemma plus_O_n : forall n:nat, 0 + n = n.
+Proof.
+  auto.
+Qed.
+
+Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m.
+Proof.
+  intros n m; induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve plus_n_Sm: core v62.
+
+Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m).
+Proof.
+  auto.
+Qed.
+
+(** Multiplication *)
+
+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.
+
+Infix "*" := mult : nat_scope.
+
+Lemma mult_n_O : forall n:nat, 0 = n * 0.
+Proof.
+  induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve mult_n_O: core v62.
+
+Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m.
+Proof.
+  intros; induction n as [| p H]; simpl in |- *; auto.
+  destruct H; rewrite <- plus_n_Sm; apply (f_equal S).
+  pattern m at 1 3 in |- *; elim m; simpl in |- *; auto.
+Qed.
+Hint Resolve mult_n_Sm: core v62.
+
+(** Definition of subtraction on [nat] : [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. 
+
+Infix "-" := 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 : forall m:nat, le n m -> le n (S m).
+
+Infix "<=" := le : nat_scope.
+
+Hint Constructors le: core v62.
+(*i equivalent to : "Hints Resolve le_n le_S : core v62." i*)
+
+Definition lt (n m:nat) := S n <= m.
+Hint Unfold lt: core v62.
+
+Infix "<" := lt : nat_scope.
+
+Definition ge (n m:nat) := m <= n.
+Hint Unfold ge: core v62.
+
+Infix ">=" := ge : nat_scope.
+
+Definition gt (n m:nat) := m < n.
+Hint Unfold gt: core v62.
+
+Infix ">" := gt : nat_scope.
+
+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.
+Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope.
+
+(** Pattern-Matching on natural numbers *)
+
+Theorem nat_case :
+ forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n.
+Proof.
+  induction n; auto.
+Qed.
+
+(** Principle of double induction *)
+
+Theorem nat_double_ind :
+ forall R:nat -> nat -> Prop,
+   (forall n:nat, R 0 n) ->
+   (forall n:nat, R (S n) 0) ->
+   (forall n m:nat, R n m -> R (S n) (S m)) -> forall n m:nat, R n m.
+Proof.
+  induction n; auto.
+  destruct m as [| n0]; auto.
+Qed.
+
+(** Notations *)
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
new file mode 100755
index 00000000..2fe520c4
--- /dev/null
+++ b/theories/Init/Prelude.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Prelude.v,v 1.11.2.1 2004/07/16 19:31:03 herbelin Exp $ 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
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
new file mode 100755
index 00000000..6855e689
--- /dev/null
+++ b/theories/Init/Specif.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.25.2.1 2004/07/16 19:31:04 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** Basic specifications : Sets containing logical information *)
+
+Require Import Notations.
+Require Import Datatypes.
+Require Import 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 : forall x:A, P x -> sig (A:=A) P.
+
+Inductive sig2 (A:Set) (P Q:A -> Prop) : Set :=
+    exist2 : forall x:A, P x -> Q x -> sig2 (A:=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 : forall x:A, P x -> sigS (A:=A) P.
+
+Inductive sigS2 (A:Set) (P Q:A -> Set) : Set :=
+    existS2 : forall x:A, P x -> Q x -> sigS2 (A:=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 (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)) :
+  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 P) := match e with
+                                    | exist a b => a
+                                    end.
+
+  Definition proj2_sig (e:sig P) :=
+    match e return P (proj1_sig e) with
+    | 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 (x:sigS P) : A := match x with
+                                      | existS a _ => a
+                                      end.
+  Definition projS2 (x:sigS P) : P (projS1 x) :=
+    match x return P (projS1 x) with
+    | 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.
+
+Add Printing If sumbool.
+
+Inductive sumor (A:Set) (B:Prop) : Set :=
+  | inleft : A -> A + {B}
+  | inright : B -> A + {B} 
+ where "A + { B }" := (sumor A B) : type_scope.
+
+Add Printing If sumor.
+
+(** 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 :
+   (forall x:S, sig (fun y:S' => R x y)) ->
+   sig (fun f:S -> S' => forall z:S, R z (f z)).
+  Proof.
+   intro H.
+   exists (fun z:S => match H z with
+                      | exist y _ => y
+                      end).
+   intro z; destruct (H z); trivial.
+  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)).
+  Proof.
+    intro H.
+    exists (fun z:S => match H z with
+                       | existS y _ => y
+                       end).
+    intro z; destruct (H z); trivial.
+  Qed.
+
+  Lemma bool_choice :
+   (forall x:S, {R1 x} + {R2 x}) ->
+   sig
+     (fun f:S -> bool =>
+        forall x:S, f x = true /\ R1 x \/ f x = false /\ R2 x).
+  Proof.
+    intro H.
+    exists
+     (fun z:S => match H z with
+                 | left _ => true
+                 | right _ => false
+                 end).
+    intro z; destruct (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.
+
+Implicit Arguments error [A].
+
+Definition except := False_rec. (* for compatibility with previous versions *)
+
+Implicit Arguments except [P].
+
+Theorem absurd_set : forall (A:Prop) (C:Set), A -> ~ A -> C.
+Proof.
+  intros A C h1 h2.
+  apply False_rec.
+  apply (h2 h1).
+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.
+
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
new file mode 100755
index 00000000..7ab3723d
--- /dev/null
+++ b/theories/Init/Wf.v
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.
+
+(*i $Id: Wf.v,v 1.17.2.1 2004/07/16 19:31:04 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 Import Notations.
+Require Import Logic.
+Require Import Datatypes.
+
+(** Well-founded induction principle on Prop *)
+
+Section 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 : forall x:A, (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 :
+     [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.
+
+  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)).
+
+ 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 : 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)).
+
+ End AccIter.
+
+ (** A relation is well-founded if every element is accessible *)
+
+ Definition well_founded := forall a:A, Acc a.
+
+ (** well-founded induction on Set and Prop *)
+
+ Hypothesis Rwf : well_founded.
+
+ Theorem well_founded_induction_type :
+  forall P:A -> Type,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  intros; apply (Acc_iter P); auto.
+ Defined.
+
+ Theorem well_founded_induction :
+  forall P:A -> Set,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  exact (fun P:A -> Set => well_founded_induction_type P).
+ Defined.
+
+ Theorem well_founded_ind :
+  forall P:A -> Prop,
+    (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a.
+ Proof.
+  exact (fun P:A -> Prop => well_founded_induction_type P).
+ Defined.
+
+(** Building fixpoints  *) 
+
+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)).
+
+Definition Fix (x:A) := Fix_F (Rwf x).
+
+(** Proof that [well_founded_induction] satisfies the fixpoint equation. 
+    It requires an extra property of the functional *)
+
+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.
+
+Scheme Acc_inv_dep := Induction for Acc Sort Prop.
+
+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.
+
+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_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.
+
+End FixPoint.
+
+End Well_founded. 
+
+(** A recursor over pairs *)
+
+Section Well_founded_2.
+
+  Variables A B : Set.
+  Variable R : A * B -> A * B -> Prop.
+
+  Variable P : A -> B -> Type. 
+  Variable
+    F :
+      forall (x:A) (x':B),
+        (forall (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')) {struct a} : 
+   P x x' :=
+    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)).
+
+  Hypothesis Rwf : well_founded R.
+
+  Theorem well_founded_induction_type_2 :
+   (forall (x:A) (x':B),
+      (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x') ->
+   forall (a:A) (b:B), P a b.
+  Proof.
+   intros; apply Acc_iter_2; auto.
+  Defined.
+
+End Well_founded_2.
diff --git a/theories/IntMap/.depend b/theories/IntMap/.depend
new file mode 100644
index 00000000..8c90ac99
--- /dev/null
+++ b/theories/IntMap/.depend
@@ -0,0 +1,48 @@
+Mapsubset.vo: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo
+Mapsubset.vi: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo
+Maplists.vo: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo
+Maplists.vi: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo
+Mapiter.vo: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo
+Mapiter.vi: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo
+Mapfold.vo: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo
+Mapfold.vi: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo
+Mapcard.vo: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo
+Mapcard.vi: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo
+Mapcanon.vo: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo
+Mapcanon.vi: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo
+Mapc.vo: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo
+Mapc.vi: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo
+Mapaxioms.vo: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Mapaxioms.vi: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Map.vo: Map.v Addr.vo Adist.vo Addec.vo
+Map.vi: Map.v Addr.vo Adist.vo Addec.vo
+Lsort.vo: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo
+Lsort.vi: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo
+Fset.vo: Fset.v Addr.vo Adist.vo Addec.vo Map.vo
+Fset.vi: Fset.v Addr.vo Adist.vo Addec.vo Map.vo
+Allmaps.vo: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo
+Allmaps.vi: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo
+Adist.vo: Adist.v Addr.vo
+Adist.vi: Adist.v Addr.vo
+Addr.vo: Addr.v
+Addr.vi: Addr.v
+Addec.vo: Addec.v Addr.vo
+Addec.vi: Addec.v Addr.vo
+Adalloc.vo: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Adalloc.vi: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo
+Mapsubset.html: Mapsubset.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html
+Maplists.html: Maplists.v Addr.html Addec.html Map.html Fset.html Mapaxioms.html Mapsubset.html Mapcard.html Mapcanon.html Mapc.html Mapiter.html Mapfold.html
+Mapiter.html: Mapiter.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html
+Mapfold.html: Mapfold.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Lsort.html Mapsubset.html
+Mapcard.html: Mapcard.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Mapsubset.html Lsort.html
+Mapcanon.html: Mapcanon.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Lsort.html Mapsubset.html Mapcard.html
+Mapc.html: Mapc.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html Mapiter.html Mapsubset.html Lsort.html Mapcard.html Mapcanon.html
+Mapaxioms.html: Mapaxioms.v Addr.html Adist.html Addec.html Map.html Fset.html
+Map.html: Map.v Addr.html Adist.html Addec.html
+Lsort.html: Lsort.v Addr.html Adist.html Addec.html Map.html Mapiter.html
+Fset.html: Fset.v Addr.html Adist.html Addec.html Map.html
+Allmaps.html: Allmaps.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Mapsubset.html Lsort.html Mapfold.html Mapcard.html Mapcanon.html Mapc.html Maplists.html Adalloc.html
+Adist.html: Adist.v Addr.html
+Addr.html: Addr.v
+Addec.html: Addec.v Addr.html
+Adalloc.html: Adalloc.v Addr.html Adist.html Addec.html Map.html Fset.html
diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v
new file mode 100644
index 00000000..9fde8f5f
--- /dev/null
+++ b/theories/IntMap/Adalloc.v
@@ -0,0 +1,365 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Arith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+
+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
+    | 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 :
+   forall m:Map A, MapGet A m (ad_alloc_opt m) = NONE A.
+  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.
+    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)))
+  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.
+  Qed.
+
+  Lemma ad_alloc_opt_allocates :
+   forall m:Map A, in_dom A (ad_alloc_opt m) m = false.
+  Proof.
+    unfold in_dom in |- *. 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 :
+   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}.
+  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.
+    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 :
+   forall (m:Map A) (a:ad),
+     ad_le (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.
+  Qed.
+
+End AdAlloc.
diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v
new file mode 100644
index 00000000..7dba9ef6
--- /dev/null
+++ b/theories/IntMap/Addec.v
@@ -0,0 +1,193 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..1370d72d
--- /dev/null
+++ b/theories/IntMap/Addr.v
@@ -0,0 +1,491 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/Adist.v b/theories/IntMap/Adist.v
new file mode 100644
index 00000000..cdb4c885
--- /dev/null
+++ b/theories/IntMap/Adist.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: Adist.v,v 1.9.2.1 2004/07/16 19:31:04 herbelin Exp $	      i*)
+
+Require Import Bool.
+Require Import ZArith.
+Require Import Arith.
+Require Import Min.
+Require Import Addr.
+
+Fixpoint ad_plength_1 (p:positive) : nat :=
+  match p with
+  | xH => 0
+  | xI _ => 0
+  | xO p' => S (ad_plength_1 p')
+  end.
+
+Inductive natinf : Set :=
+  | infty : natinf
+  | ni : nat -> natinf.
+
+Definition ad_plength (a:ad) :=
+  match a with
+  | ad_z => infty
+  | ad_x p => ni (ad_plength_1 p)
+  end.
+
+Lemma ad_plength_infty : forall a:ad, ad_plength a = infty -> a = ad_z.
+Proof.
+  simple induction a; trivial. 
+  unfold ad_plength 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.
+Proof.
+  simple induction a; trivial. 
+  simple induction p. simple induction n. intros. inversion H1.
+  simple induction k. simpl in H1. discriminate H1.
+  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.
+  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.
+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 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.
+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.
+  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.
+  exact H3.
+  intro. case n. trivial.
+  intros. simpl in H0. discriminate H0.
+Qed.
+
+Definition ni_min (d d':natinf) :=
+  match d with
+  | infty => d'
+  | ni n => match d' with
+            | infty => d
+            | ni n' => ni (min n n')
+            end
+  end.
+
+Lemma ni_min_idemp : forall d:natinf, ni_min d d = d.
+Proof.
+  simple induction d; trivial.
+  unfold ni_min in |- *.
+  simple induction n; trivial.
+  intros.
+  simpl in |- *.
+  inversion H.
+  rewrite H1.
+  rewrite H1.
+  reflexivity.
+Qed.
+
+Lemma ni_min_comm : forall d d':natinf, ni_min d d' = ni_min d' d.
+Proof.
+  simple induction d. simple induction d'; trivial.
+  simple induction d'; trivial. elim n. simple induction n0; trivial.
+  intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0).
+  intro. unfold ni_min in |- *. simpl in |- *. rewrite H1. reflexivity.
+  cut (ni (min n0 n2) = ni (min n2 n0)). intros.
+  inversion H1; trivial.
+  exact (H n2).
+Qed.
+
+Lemma ni_min_assoc :
+ forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d'').
+Proof.
+  simple induction d; trivial. simple induction d'; trivial. 
+  simple induction d''; trivial.
+  unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
+  intro. rewrite H. reflexivity.
+  generalize n0 n1. elim n; trivial. 
+  simple induction n3; trivial. simple induction n5; trivial.
+  intros. simpl in |- *. auto.
+Qed.
+
+Lemma ni_min_O_l : forall d:natinf, ni_min (ni 0) d = ni 0.
+Proof.
+  simple induction d; trivial.
+Qed.
+
+Lemma ni_min_O_r : forall d:natinf, ni_min d (ni 0) = ni 0.
+Proof.
+  intros. rewrite ni_min_comm. apply ni_min_O_l.
+Qed.
+
+Lemma ni_min_inf_l : forall d:natinf, ni_min infty d = d.
+Proof.
+  trivial.
+Qed.
+
+Lemma ni_min_inf_r : forall d:natinf, ni_min d infty = d.
+Proof.
+  simple induction d; trivial.
+Qed.
+
+Definition ni_le (d d':natinf) := ni_min d d' = d.
+
+Lemma ni_le_refl : forall d:natinf, ni_le d d.
+Proof.
+  exact ni_min_idemp.
+Qed.
+
+Lemma ni_le_antisym : forall d d':natinf, ni_le d d' -> ni_le d' d -> d = d'.
+Proof.
+  unfold ni_le in |- *. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial.
+Qed.
+
+Lemma ni_le_trans :
+ forall d d' d'':natinf, ni_le d d' -> ni_le d' d'' -> ni_le d d''.
+Proof.
+  unfold ni_le in |- *. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity.
+Qed.
+
+Lemma ni_le_min_1 : forall d d':natinf, ni_le (ni_min d d') d.
+Proof.
+  unfold ni_le in |- *. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc.
+  rewrite ni_min_idemp. reflexivity.
+Qed.
+
+Lemma ni_le_min_2 : forall d d':natinf, ni_le (ni_min d d') d'.
+Proof.
+  unfold ni_le in |- *. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity.
+Qed.
+
+Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'.
+Proof.
+  simple induction d. intro. right. exact (ni_min_inf_l d').
+  simple induction d'. left. exact (ni_min_inf_r (ni n)).
+  unfold ni_min in |- *. cut (forall 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.
+  simple induction n1. right. reflexivity.
+  intros. case (H n2). intro. left. simpl in |- *. rewrite H1. reflexivity.
+  intro. right. simpl in |- *. rewrite H1. reflexivity.
+Qed.
+
+Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d.
+Proof.
+  unfold ni_le in |- *. intros. rewrite (ni_min_comm d' d). apply ni_min_case.
+Qed.
+
+Lemma ni_le_min_induc :
+ forall d d' dm:natinf,
+   ni_le dm d ->
+   ni_le dm d' ->
+   (forall 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 in |- *. rewrite ni_min_comm. exact H2.
+  apply ni_le_refl.
+  exact H0.
+Qed.
+
+Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n).
+Proof.
+  cut (forall m n:nat, m <= n -> min m n = m).
+  intros. unfold ni_le, ni_min in |- *. rewrite (H m n H0). reflexivity.
+  simple induction m. trivial.
+  simple induction n0. intro. inversion H0.
+  intros. simpl in |- *. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
+Qed.
+
+Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n.
+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).
+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).
+  rewrite
+   (ad_plength_one (ad_x p) (ad_plength_1 p)
+      (refl_equal (ad_plength (ad_x 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).
+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).
+  rewrite
+   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
+      (refl_equal (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 : forall a:ad, ad_pdist a a = infty.
+Proof.
+  intros. unfold ad_pdist in |- *. rewrite ad_xor_nilpotent. reflexivity.
+Qed.
+
+Lemma ad_pdist_eq_2 : forall 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 : forall a a':ad, ad_pdist a a' = ad_pdist a' a.
+Proof.
+  unfold ad_pdist in |- *. 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 :
+ forall a a':ad,
+   ni_le (ad_plength a) (ad_plength a') ->
+   ni_le (ad_plength a) (ad_plength (ad_xor 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).
+  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 |- *.
+  rewrite
+   (ad_plength_zeros (ad_x p) (ad_plength_1 p)
+      (refl_equal (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 :
+ forall 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 :
+ forall 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 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.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Allmaps.v b/theories/IntMap/Allmaps.v
new file mode 100644
index 00000000..68744220
--- /dev/null
+++ b/theories/IntMap/Allmaps.v
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:31:04 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.
\ No newline at end of file
diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v
new file mode 100644
index 00000000..8d217be9
--- /dev/null
+++ b/theories/IntMap/Fset.v
@@ -0,0 +1,371 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 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 Map.
+
+Section Dom.
+
+  Variables A B : Set.
+
+  Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A :=
+    match m with
+    | M0 => fun _:Map B => M0 A
+    | M1 a y =>
+        fun m':Map B => match MapGet B m' a with
+                        | NONE => M0 A
+                        | _ => m
+                        end
+    | M2 m1 m2 =>
+        fun m':Map B =>
+          match m' with
+          | M0 => M0 A
+          | M1 a' y' =>
+              match MapGet A m a' with
+              | 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 :
+   forall (m:Map A) (m':Map B),
+     eqm A (MapGet A (MapDomRestrTo m m'))
+       (fun a0:ad =>
+          match MapGet B m' a0 with
+          | NONE => NONE A
+          | _ => 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.
+    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).
+    simple induction m'. trivial.
+    unfold MapDomRestrTo in |- *. 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 =
+    match MapGet B (M2 B m2 m3) a with
+    | NONE => NONE A
+    | 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 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 :=
+    match m with
+    | M0 => fun _:Map B => M0 A
+    | M1 a y =>
+        fun m':Map B => match MapGet B m' a with
+                        | NONE => m
+                        | _ => M0 A
+                        end
+    | M2 m1 m2 =>
+        fun m':Map B =>
+          match m' with
+          | 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 :
+   forall (m:Map A) (m':Map B),
+     eqm A (MapGet A (MapDomRestrBy m m'))
+       (fun a0:ad =>
+          match MapGet B m' a0 with
+          | NONE => MapGet A m a0
+          | _ => NONE A
+          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).
+    case (MapGet B m' a1); trivial.
+    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).
+    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
+    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 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) :=
+    match MapGet A m a with
+    | NONE => false
+    | _ => true
+    end.
+
+  Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = ad_eq a a0.
+  Proof.
+    unfold in_dom in |- *. intros. simpl in |- *. case (ad_eq 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.
+  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.
+  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}.
+  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.
+  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.
+    trivial.
+  Qed.
+
+  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).
+  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.
+    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 :
+   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).
+  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.
+    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 :
+   forall (m:Map A) (a0 a:ad),
+     in_dom a (MapRemove A m a0) = andb (negb (ad_eq 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.
+    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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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.
+
+  Variables A B : Set.
+
+  Lemma in_dom_restrto :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 in |- *. rewrite andb_b_false. reflexivity.
+    intro H. rewrite H. unfold negb in |- *. 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 :=
+    match m with
+    | M0 => M0 unit
+    | M1 a _ => M1 unit a tt
+    | M2 m m' => M2 unit (MapDom m) (MapDom m')
+    end.
+
+  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.
+  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.
+    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.
+    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}.
+  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).
+    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.
+    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.
+  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 :
+   forall (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 :
+   forall (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 in |- *. rewrite H0.
+    reflexivity.
+    intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity.
+  Qed.
+
+  Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'.
+
+  Lemma in_FSet_union :
+   forall (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 (s s':FSet) : FSet := MapDomRestrTo unit unit s s'.
+
+  Lemma in_FSet_inter :
+   forall (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 (s s':FSet) : FSet := MapDomRestrBy unit unit s s'.
+
+  Lemma in_FSet_diff :
+   forall (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 (s s':FSet) : FSet := MapDelta unit s s'.
+
+  Lemma in_FSet_delta :
+   forall (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 : forall s:FSet, MapDom unit s = s.
+Proof.
+  simple induction s. trivial.
+  simpl in |- *. intros a t. elim t. reflexivity.
+  intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v
new file mode 100644
index 00000000..48972872
--- /dev/null
+++ b/theories/IntMap/Lsort.v
@@ -0,0 +1,628 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import List.
+Require Import Mapiter.
+
+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')
+        end
+    end.
+
+  Fixpoint alist_nth_ad (n:nat) (l:alist A) {struct l} : ad :=
+    match l with
+    | nil => ad_z (* dummy *)
+    | (a, y) :: l' => match n with
+                      | O => a
+                      | S n' => alist_nth_ad n' l'
+                      end
+    end.
+
+  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.
+
+  Lemma alist_sorted_imp_1 :
+   forall l:alist A, alist_sorted l = true -> alist_sorted_1 l.
+  Proof.
+    unfold alist_sorted_1 in |- *. simple induction l. intros. elim (le_Sn_O (S n) H0).
+    intro r. elim r. intros a y. simple induction l0. intros. simpl in H1.
+    elim (le_Sn_O n (le_S_n (S n) 0 H1)).
+    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))
+      (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) 
+  in |- *.
+    apply H0. exact (proj2 (andb_prop _ _ H1)).
+    apply le_S_n. exact H3.
+  Qed.
+
+  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.
+
+  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.
+    assumption.
+    apply H. assumption.
+  Qed.
+
+  Lemma alist_sorted_2_imp :
+   forall l:alist A, alist_sorted_2 l -> alist_sorted l = true.
+  Proof.
+    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)
+     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.
+    apply H0. intros. apply (H1 (S m) (S n)). apply le_n_S. assumption.
+    exact (le_n_S _ _ H3).
+  Qed.
+
+  Lemma app_length :
+   forall (C:Set) (l l':list C), length (l ++ l') = length l + length l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l'). reflexivity.
+  Qed.
+
+  Lemma aapp_length :
+   forall l l':alist A, length (aapp A l l') = length l + length l'.
+  Proof.
+    exact (app_length (ad * A)).
+  Qed.
+
+  Lemma alist_nth_ad_aapp_1 :
+   forall (l l':alist A) (n:nat),
+     S n <= length l -> alist_nth_ad n (aapp A l l') = alist_nth_ad n l.
+  Proof.
+    simple induction l. intros. elim (le_Sn_O n H).
+    intro r. elim r. intros a y l' H l''. simple induction n. trivial.
+    intros. simpl in |- *. apply H. apply le_S_n. exact H1.
+  Qed.
+
+  Lemma alist_nth_ad_aapp_2 :
+   forall (l l':alist A) (n:nat),
+     S n <= length l' ->
+     alist_nth_ad (length l + n) (aapp A l l') = alist_nth_ad n l'.
+  Proof.
+    simple induction l. trivial.
+    intro r. elim r. intros a y l' H l'' n H0. simpl in |- *. apply H. exact H0.
+  Qed.
+
+  Lemma interval_split :
+   forall p q n:nat,
+     S n <= p + q -> {n' : nat | S n' <= q /\ n = p + n'} + {S n <= p}.
+  Proof.
+    simple induction p. simpl in |- *. intros. left. split with n. split; [ assumption | reflexivity ].
+    intros p' H q. simple 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 :
+   forall l l':alist A,
+     alist_sorted_2 l ->
+     alist_sorted_2 l' ->
+     (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) ->
+     alist_sorted_2 (aapp A l l').
+  Proof.
+    unfold alist_sorted_2, lt in |- *. 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 (S (length l) + m' <= length l + n') in H2.
+    rewrite (plus_Snm_nSm (length l) m') in H2. exact ((fun p n m:nat => plus_le_reg_l n m p) (length l) (S m') n' H2).
+    exact H10.
+    intro H8. rewrite H7 in H2. cut (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 (length l + m')).
+    apply le_trans with (m := 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 :
+   forall (l:alist A) (n:nat),
+     S n <= length l ->
+     {y : A | alist_semantics A l (alist_nth_ad n l) = SOME A 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.
+    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)).
+    reflexivity.
+    intro H3. split with y0. simpl in |- *. rewrite H3. assumption.
+  Qed.
+
+  Lemma alist_of_Map_nth_ad :
+   forall (m:Map A) (pf:ad -> ad) (l:alist A),
+     l =
+     MapFold1 A (alist A) (anil A) (aapp A)
+       (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) pf m ->
+     forall n:nat, 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) :=
+    forall 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 in |- *. intros. rewrite ad_less_def_1. assumption.
+  Qed.
+
+  Lemma ad_double_plus_un_monotonic : ad_monotonic ad_double_plus_un.
+  Proof.
+    unfold ad_monotonic in |- *. intros. rewrite ad_less_def_2. assumption.
+  Qed.
+
+  Lemma ad_comp_monotonic :
+   forall pf pf':ad -> ad,
+     ad_monotonic pf ->
+     ad_monotonic pf' -> ad_monotonic (fun a0:ad => pf (pf' a0)).
+  Proof.
+    unfold ad_monotonic in |- *. intros. apply H. apply H0. exact H1.
+  Qed.
+
+  Lemma ad_comp_double_monotonic :
+   forall pf:ad -> ad,
+     ad_monotonic pf -> ad_monotonic (fun 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 :
+   forall pf:ad -> ad,
+     ad_monotonic pf -> ad_monotonic (fun 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 :
+   forall (m:Map A) (pf:ad -> ad),
+     ad_monotonic pf ->
+     alist_sorted_2
+       (MapFold1 A (alist A) (anil A) (aapp A)
+          (fun (a:ad) (y:A) => acons A (a, y) (anil A)) pf m).
+  Proof.
+    simple induction m. simpl in |- *. intros. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity.
+    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)).
+    exact
+     (H0 (fun a0:ad => pf (ad_double_plus_un a0))
+        (ad_comp_double_plus_un_monotonic pf H1)).
+    intros. elim
+  (alist_of_Map_nth_ad m0 (fun a0:ad => pf (ad_double 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).
+    intros a H4. rewrite H4. elim
+  (alist_of_Map_nth_ad m1 (fun a0:ad => pf (ad_double_plus_un 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) (
+     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 :
+   forall 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 (fun a0:ad => a0)
+        (fun (a a':ad) (p:ad_less a a' = true) => p)).
+  Qed.
+
+  Lemma alist_of_Map_sorts1 :
+   forall 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 :
+   forall 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 :
+   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 ->
+     alist_sorted_2 ((a', y) :: l) ->
+     alist_semantics A ((a', y) :: l) a = NONE A.
+  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.
+    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
+       | 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.
+    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.
+    cut (alist_sorted ((a1, y0) :: (a, y) :: l0) = true). intro H3.
+    exact (proj2 (andb_prop _ _ H3)).
+    apply alist_sorted_2_imp. assumption.
+  Qed.
+
+  Lemma alist_semantics_nth_ad :
+   forall (l:alist A) (a:ad) (y:A),
+     alist_semantics A l a = SOME A 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 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).
+    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).
+  Qed.
+
+  Lemma alist_semantics_tail :
+   forall (l:alist A) (a:ad) (y:A),
+     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).
+  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.
+    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))
+        (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.
+    apply H. apply lt_O_Sn.
+    simpl in |- *. apply le_n_S. assumption.
+    trivial.
+    intro H0. simpl in |- *. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma alist_semantics_same_tail :
+   forall (l l':alist A) (a:ad) (y:A),
+     alist_sorted_2 ((a, y) :: l) ->
+     alist_sorted_2 ((a, y) :: l') ->
+     eqm A (alist_semantics A ((a, y) :: l))
+       (alist_semantics A ((a, y) :: l')) ->
+     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.
+    exact (H1 a0).
+  Qed.
+
+  Lemma alist_sorted_tail :
+   forall (l:alist A) (a:ad) (y:A),
+     alist_sorted_2 ((a, y) :: l) -> alist_sorted_2 l.
+  Proof.
+    unfold alist_sorted_2 in |- *. intros. apply (H (S m) (S n)). apply lt_n_S. assumption.
+    simpl in |- *. apply le_n_S. assumption.
+  Qed.
+
+  Lemma alist_canonical :
+   forall 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 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
+      | false => 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. simple induction l'. intros. simpl in H0.
+    cut
+     (match ad_eq a a with
+      | true => SOME A y
+      | false => 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 ((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.
+    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.
+    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.
+    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.
\ No newline at end of file
diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v
new file mode 100644
index 00000000..da1fa99e
--- /dev/null
+++ b/theories/IntMap/Map.v
@@ -0,0 +1,865 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:04 herbelin Exp $	 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.
+
+
+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 : forall o:option, {y : A | o = SOME y} + {o = NONE}.
+  Proof.
+    simple 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 :=
+    match m with
+    | M0 => fun a:ad => NONE
+    | M1 x y => fun a:ad => if ad_eq 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)
+          end
+    end.
+
+  Definition newMap := M0.
+
+  Definition MapSingleton := M1.
+
+  Definition eqm (g g':ad -> option) := forall a:ad, g a = g' a.
+
+  Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => NONE).
+  Proof.
+    simpl in |- *. unfold eqm in |- *. trivial.
+  Qed.
+
+  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).
+  Proof.
+    simpl in |- *. unfold eqm in |- *. trivial.
+  Qed.
+
+  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.
+  Qed.
+
+  Lemma M1_semantics_2 :
+   forall (a a':ad) (y:A), ad_eq 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)).
+  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)).
+  Proof.
+    unfold eqm in |- *.
+    intros.
+    rewrite <- (H (ad_double 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)).
+  Proof.
+    unfold eqm in |- *. simple induction a; trivial.
+  Qed.
+
+  Lemma Map2_semantics_2_eq :
+   forall (m m':Map) (f:ad -> option),
+     eqm (MapGet (M2 m m')) f ->
+     eqm (MapGet m') (fun a:ad => f (ad_double_plus_un a)).
+  Proof.
+    unfold eqm in |- *.
+    intros.
+    rewrite <- (H (ad_double_plus_un 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).
+  Proof.
+    simple induction a; trivial. simple induction p. intros. discriminate H0.
+    trivial.
+    intros. discriminate H.
+  Qed.
+
+  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).
+  Proof.
+    simple induction a. intros. discriminate H.
+    simple induction p. trivial.
+    intros. discriminate H0.
+    trivial.
+  Qed.
+
+  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)).
+  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 :
+   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).
+  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 :
+   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)
+          end).
+  Proof.
+    unfold eqm in |- *.
+    simple induction a; trivial.
+    simple induction p; trivial.
+  Qed.
+
+  Lemma Map2_semantics_3_eq :
+   forall (m m':Map) (f f':ad -> option),
+     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)
+          end).
+  Proof.
+    unfold eqm in |- *.
+    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) {struct p} :
+   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
+        | 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)
+        end
+    end.
+
+  Lemma MapGet_if_commute :
+   forall (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 :
+   forall (m:Map) (b:bool) (a:ad), MapGet (if b then m else m) a = MapGet m a.
+  Proof.
+    simple induction b; trivial.
+  Qed.
+
+  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).
+  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.
+  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.
+    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'.
+  Proof.
+    simple induction p. intros. unfold MapPut1 in |- *. 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 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.
+    rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
+  Qed.
+
+  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.
+  Proof.
+    intros. rewrite (Map2_semantics_3 m m' a). 
+    case (ad_bit_0 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.
+    apply M1_semantics_2; assumption.
+    intro; case (ad_bit_0 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.
+    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 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.
+    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 :
+   forall (p:positive) (a a':ad) (y y':A),
+     ad_xor a a' = ad_x 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').
+    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 ->
+     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. 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 :=
+    match m with
+    | 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
+          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)
+          end
+    end.
+
+  Lemma MapPut_semantics_1 :
+   forall (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 :
+   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).
+  Proof.
+    simpl in |- *. intros. rewrite (ad_xor_nilpotent a). trivial.
+  Qed.
+
+  Lemma MapPut_semantics_2_2 :
+   forall (a a':ad) (y y':A) (a0 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.
+    simple induction a''. intro. rewrite (ad_xor_eq _ _ H). rewrite MapPut_semantics_2_1.
+    case (ad_eq 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.
+    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).
+  Proof.
+    intros. apply MapPut_semantics_2_2 with (a'' := ad_xor 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').
+  Proof.
+    simple induction a. trivial.
+    simple induction p; trivial.
+  Qed.
+
+  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').
+  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).
+    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 :=
+    match m with
+    | 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
+          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)
+          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').
+  Proof.
+    simple induction a. trivial.
+    simple induction p; trivial.
+  Qed.
+
+  Lemma MapPut_behind_as_before_1 :
+   forall a a' a0:ad,
+     ad_eq 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 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 :
+   forall (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.
+    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).
+    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 :
+   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
+     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).
+    assumption.
+    intro H. simpl in |- *. 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 :
+   forall (m:Map) (a:ad) (y:A),
+     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
+          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.
+    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) :=
+    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
+    | _, _ => 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.
+    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 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.
+    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)). 
+    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 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).
+    reflexivity.
+    intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
+    assumption.
+    intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
+    assumption.
+    intros m1 m2. unfold makeM2 in |- *. exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m').
+  Qed.
+
+  Fixpoint MapRemove (m:Map) : ad -> Map :=
+    match m with
+    | M0 => fun _:ad => M0
+    | M1 a y =>
+        fun a':ad => match ad_eq 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
+    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.
+    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)) 
+  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).
+    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 :=
+    match m with
+    | M0 => 0
+    | M1 _ _ => 1
+    | M2 m m' => MapCard m + MapCard m'
+    end.
+
+  Fixpoint MapMerge (m:Map) : Map -> Map :=
+    match m with
+    | M0 => fun m':Map => m'
+    | M1 a y => fun m':Map => MapPut_behind m' a y
+    | M2 m1 m2 =>
+        fun m':Map =>
+          match m' with
+          | 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 :
+   forall m m':Map,
+     eqm (MapGet (MapMerge m m'))
+       (fun a0:ad =>
+          match MapGet m' a0 with
+          | 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).
+    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 :=
+    match m with
+    | M0 => fun m':Map => m'
+    | M1 a y =>
+        fun m':Map =>
+          match MapGet m' a with
+          | NONE => MapPut m' a y
+          | _ => MapRemove m' a
+          end
+    | M2 m1 m2 =>
+        fun m':Map =>
+          match m' with
+          | M0 => m
+          | M1 a' y' =>
+              match MapGet m a' with
+              | 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 :
+   forall m m':Map, eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m)).
+  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.
+    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.
+    simple induction m'. reflexivity.
+    reflexivity.
+    intros. simpl in |- *. 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 :
+   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.
+  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.
+    rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+  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.
+  Proof.
+    simple induction m. trivial.
+    exact MapDelta_semantics_1_1.
+    simple induction m'. trivial.
+    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.
+    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 :
+   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.
+  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.
+    rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
+  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.
+  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).
+    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.
+  Proof.
+    simple induction m. trivial.
+    exact MapDelta_semantics_2_1.
+    simple 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 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. 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 :
+   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.
+  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.
+    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.
+  Proof.
+    simple induction m. intros. discriminate H.
+    exact MapDelta_semantics_3_1.
+    simple 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 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_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 :
+   forall m m':Map,
+     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
+          end).
+  Proof.
+    unfold eqm in |- *. 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) := match m with
+                                  | M0 => true
+                                  | _ => false
+                                  end.
+
+  Lemma MapEmptyp_correct : MapEmptyp M0 = true.
+  Proof.
+    reflexivity.
+  Qed.
+
+  Lemma MapEmptyp_complete : forall m:Map, MapEmptyp m = true -> m = M0.
+  Proof.
+    simple 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.
\ No newline at end of file
diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v
new file mode 100644
index 00000000..9d09f2a9
--- /dev/null
+++ b/theories/IntMap/Mapaxioms.v
@@ -0,0 +1,763 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+
+Section MapAxioms.
+
+  Variables A B C : Set.
+
+  Lemma eqm_sym : forall f f':ad -> option A, eqm A f f' -> eqm A f' f.
+  Proof.
+    unfold eqm in |- *. intros. rewrite H. reflexivity.
+  Qed.
+
+  Lemma eqm_refl : forall f:ad -> option A, eqm A f f.
+  Proof.
+    unfold eqm in |- *. trivial.
+  Qed.
+
+  Lemma eqm_trans :
+   forall f f' f'':ad -> option A, eqm A f f' -> eqm A f' f'' -> eqm A f f''.
+  Proof.
+    unfold eqm in |- *. intros. rewrite H. exact (H0 a).
+  Qed.
+
+  Definition eqmap (m m':Map A) := eqm A (MapGet A m) (MapGet A m').
+
+  Lemma eqmap_sym : forall m m':Map A, eqmap m m' -> eqmap m' m.
+  Proof.
+    intros. unfold eqmap in |- *. apply eqm_sym. assumption.
+  Qed.
+
+  Lemma eqmap_refl : forall m:Map A, eqmap m m.
+  Proof.
+    intros. unfold eqmap in |- *. apply eqm_refl.
+  Qed.
+
+  Lemma eqmap_trans :
+   forall 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 :
+   forall (m:Map A) (a:ad) (y:A),
+     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.
+  Qed.
+
+  Lemma MapPut_ext :
+   forall m m':Map A,
+     eqmap m m' ->
+     forall (a:ad) (y:A), eqmap (MapPut A m a y) (MapPut A m' a y).
+  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 ].
+  Qed.
+
+  Lemma MapPut_behind_as_Merge :
+   forall (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 in |- *. 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 :
+   forall m m':Map A,
+     eqmap m m' ->
+     forall (a:ad) (y:A),
+       eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 : forall m:Map A, MapMerge A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapMerge_empty_m : forall m:Map A, eqmap (MapMerge A (M0 A) m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapMerge_m_empty_1 : forall m:Map A, MapMerge A m (M0 A) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapMerge_m_empty : forall m:Map A, eqmap (MapMerge A m (M0 A)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite MapMerge_m_empty_1. reflexivity.
+  Qed.
+
+  Lemma MapMerge_empty_l :
+   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.
+    exact (H a).
+  Qed.
+
+  Lemma MapMerge_empty_r :
+   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.
+    exact (H a).
+  Qed.
+
+  Lemma MapMerge_assoc :
+   forall m m' m'':Map A,
+     eqmap (MapMerge A (MapMerge A m m') m'')
+       (MapMerge A m (MapMerge A m' m'')).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 : forall m:Map A, eqmap (MapMerge A m m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapMerge_ext :
+   forall 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 in |- *. 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 :
+   forall 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 :
+   forall 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 :
+   forall 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 in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:B),
+     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).
+    reflexivity.
+    intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity.
+  Qed.
+
+  Lemma MapRemove_ext :
+   forall m m':Map A,
+     eqmap m m' -> forall a:ad, eqmap (MapRemove A m a) (MapRemove A m' a).
+  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 ].
+  Qed.
+
+  Lemma MapDomRestrTo_empty_m_1 :
+   forall m:Map B, MapDomRestrTo A B (M0 A) m = M0 A.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_empty_m :
+   forall m:Map B, eqmap (MapDomRestrTo A B (M0 A) m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_m_empty_1 :
+   forall m:Map A, MapDomRestrTo A B m (M0 B) = M0 A.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_m_empty :
+   forall m:Map A, eqmap (MapDomRestrTo A B m (M0 B)) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_m_empty_1 m). reflexivity.
+  Qed.
+
+  Lemma MapDomRestrTo_assoc :
+   forall (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 in |- *. 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 :
+   forall m:Map A, eqmap (MapDomRestrTo A A m m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDomRestrTo_Dom :
+   forall (m:Map A) (m':Map B),
+     eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m')).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall m:Map B, MapDomRestrBy A B (M0 A) m = M0 A.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_empty_m :
+   forall m:Map B, eqmap (MapDomRestrBy A B (M0 A) m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_m_empty_1 :
+   forall m:Map A, MapDomRestrBy A B m (M0 B) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_m_empty :
+   forall m:Map A, eqmap (MapDomRestrBy A B m (M0 B)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_m_empty_1 m). reflexivity.
+  Qed.
+
+  Lemma MapDomRestrBy_Dom :
+   forall (m:Map A) (m':Map B),
+     eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m')).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall m:Map A, eqmap (MapDomRestrBy A A m m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDomRestrBy_By :
+   forall (m:Map A) (m' 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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 :
+   forall (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 in |- *. 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 : forall m:Map A, MapDelta A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapDelta_empty_m : forall m:Map A, eqmap (MapDelta A (M0 A) m) m.
+  Proof.
+    unfold eqmap, eqm in |- *. trivial.
+  Qed.
+
+  Lemma MapDelta_m_empty_1 : forall m:Map A, MapDelta A m (M0 A) = m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Lemma MapDelta_m_empty : forall m:Map A, eqmap (MapDelta A m (M0 A)) m.
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite MapDelta_m_empty_1. reflexivity.
+  Qed.
+
+  Lemma MapDelta_nilpotent : forall m:Map A, eqmap (MapDelta A m m) (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m a).
+    case (MapGet A m a); trivial.
+  Qed.
+
+  Lemma MapDelta_as_Merge :
+   forall 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 in |- *. 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 :
+   forall 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 in |- *. 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 :
+   forall 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 in |- *. 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 :
+   forall m m':Map A, eqmap (MapDelta A m m') (MapDelta A m' m).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall 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 in |- *. 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 :
+   forall 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 :
+   forall 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 :
+   forall (m:Map A) (m':Map B),
+     eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall (m:Map A) (m':Map B),
+     eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall (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 in |- *. 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 :
+ forall (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 in |- *. 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 :
+ forall (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 :
+ forall (A B:Set) (m1:Map A) (m2 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 :
+ forall (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 in |- *. 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 :
+ forall (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 :
+ forall (A B:Set) (m1:Map A) (m2 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 :
+ forall (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 :
+ forall s s' s'':FSet,
+   eqmap unit (MapDelta _ (MapDelta _ s s') s'')
+     (MapDelta _ s (MapDelta _ s' s'')).
+Proof.
+  unfold eqmap, eqm in |- *. 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 :
+ forall s s':FSet,
+   (forall a:ad, in_FSet a s = in_FSet a s') -> eqmap unit s s'.
+Proof.
+  unfold in_FSet, eqmap, eqm in |- *. 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 :
+ forall 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_comm.
+Qed.
+
+Lemma FSetUnion_assoc :
+ forall 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 : forall s:FSet, eqmap unit (FSetUnion (M0 unit) s) s.
+Proof.
+  exact (MapMerge_empty_m unit).
+Qed.
+
+Lemma FSetUnion_s_M0 : forall s:FSet, eqmap unit (FSetUnion s (M0 unit)) s.
+Proof.
+  exact (MapMerge_m_empty unit).
+Qed.
+
+Lemma FSetUnion_idempotent : forall s:FSet, eqmap unit (FSetUnion s s) s.
+Proof.
+  exact (MapMerge_idempotent unit).
+Qed.
+
+Lemma FSetInter_comm :
+ forall 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_comm.
+Qed.
+
+Lemma FSetInter_assoc :
+ forall 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 :
+ forall s:FSet, eqmap unit (FSetInter (M0 unit) s) (M0 unit).
+Proof.
+  exact (MapDomRestrTo_empty_m unit unit).
+Qed.
+
+Lemma FSetInter_s_M0 :
+ forall s:FSet, eqmap unit (FSetInter s (M0 unit)) (M0 unit).
+Proof.
+  exact (MapDomRestrTo_m_empty unit unit).
+Qed.
+
+Lemma FSetInter_idempotent : forall s:FSet, eqmap unit (FSetInter s s) s.
+Proof.
+  exact (MapDomRestrTo_idempotent unit).
+Qed.
+
+Lemma FSetUnion_Inter_l :
+ forall 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 :
+ forall 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 :
+ forall 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 :
+ forall 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.
\ No newline at end of file
diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v
new file mode 100644
index 00000000..7a394abb
--- /dev/null
+++ b/theories/IntMap/Mapc.v
@@ -0,0 +1,542 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Fset.
+Require Import Mapiter.
+Require Import Mapsubset.
+Require Import List.
+Require Import Lsort.
+Require Import Mapcard.
+Require Import Mapcanon.
+
+Section MapC.
+
+  Variables A B C : Set.
+
+  Lemma MapPut_as_Merge_c :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (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 :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (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 : forall m:Map A, MapMerge A (M0 A) m = m.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapMerge_assoc_c :
+   forall 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 :
+   forall 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 :
+   forall 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 :
+   forall m:Map A,
+     mapcanon A m ->
+     forall (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 :
+   forall (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 :
+   forall 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 :
+   forall (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 :
+   forall (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 :
+   forall (m:Map A) (m' 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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall 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 :
+   forall 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 :
+   forall 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 :
+   forall 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 :
+   forall 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 :
+   forall (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 :
+   forall (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 :
+   forall (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 :
+   forall 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 :
+   forall 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 :
+   forall (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 :
+   forall 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 :
+   forall 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 :
+   forall 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 :
+ forall 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 :
+ forall s s':FSet,
+   mapcanon unit s ->
+   mapcanon unit s' -> (forall 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 :
+ forall s s':FSet,
+   mapcanon unit s -> mapcanon unit s' -> FSetUnion s s' = FSetUnion s' s.
+Proof.
+  intros.
+  apply (mapcanon_unique unit);
+   try (unfold FSetUnion in |- *; apply MapMerge_canon; assumption).
+  apply FSetUnion_comm.
+Qed.
+
+Lemma FSetUnion_assoc_c :
+ forall 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 : forall s:FSet, FSetUnion (M0 unit) s = s.
+Proof.
+  exact (MapMerge_empty_m_c unit).
+Qed.
+
+Lemma FSetUnion_s_M0_c : forall s:FSet, FSetUnion s (M0 unit) = s.
+Proof.
+  exact (MapMerge_m_empty_1 unit).
+Qed.
+
+Lemma FSetUnion_idempotent :
+ forall s:FSet, mapcanon unit s -> FSetUnion s s = s.
+Proof.
+  exact (MapMerge_idempotent_c unit).
+Qed.
+
+Lemma FSetInter_comm_c :
+ forall s s':FSet,
+   mapcanon unit s -> mapcanon unit s' -> FSetInter s s' = FSetInter s' s.
+Proof.
+  intros.
+  apply (mapcanon_unique unit);
+   try (unfold FSetInter in |- *; apply MapDomRestrTo_canon; assumption).
+  apply FSetInter_comm.
+Qed.
+
+Lemma FSetInter_assoc_c :
+ forall 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 : forall s:FSet, FSetInter (M0 unit) s = M0 unit.
+Proof.
+  trivial.
+Qed.
+
+Lemma FSetInter_s_M0_c : forall s:FSet, FSetInter s (M0 unit) = M0 unit.
+Proof.
+  exact (MapDomRestrTo_m_empty_1 unit unit).
+Qed.
+
+Lemma FSetInter_idempotent :
+ forall s:FSet, mapcanon unit s -> FSetInter s s = s.
+Proof.
+  exact (MapDomRestrTo_idempotent_c unit).
+Qed.
+
+Lemma FSetUnion_Inter_l_c :
+ forall 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 in |- *. apply MapMerge_canon; try assumption.
+  unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
+  unfold FSetInter in |- *; unfold FSetUnion in |- *;
+   apply MapDomRestrTo_canon; apply MapMerge_canon; 
+   assumption.
+  apply FSetUnion_Inter_l.
+Qed.
+
+Lemma FSetUnion_Inter_r :
+ forall 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 in |- *. apply MapMerge_canon; try assumption.
+  unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption.
+  unfold FSetInter in |- *; unfold FSetUnion in |- *;
+   apply MapDomRestrTo_canon; apply MapMerge_canon; 
+   assumption.
+  apply FSetUnion_Inter_r.
+Qed.
+
+Lemma FSetInter_Union_l_c :
+ forall 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 in |- *.
+  apply MapDomRestrTo_canon; try assumption. unfold FSetUnion in |- *.
+  apply MapMerge_canon; assumption.
+  unfold FSetUnion in |- *; unfold FSetInter in |- *; apply MapMerge_canon;
+   apply MapDomRestrTo_canon; assumption.
+  apply FSetInter_Union_l.
+Qed.
+
+Lemma FSetInter_Union_r :
+ forall 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 in |- *.
+  apply MapDomRestrTo_canon; try assumption.
+  unfold FSetUnion in |- *. apply MapMerge_canon; unfold FSetInter in |- *; apply MapDomRestrTo_canon;
+  assumption.
+  apply FSetInter_Union_r.
+Qed.
\ No newline at end of file
diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v
new file mode 100644
index 00000000..868fbe5e
--- /dev/null
+++ b/theories/IntMap/Mapcanon.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Fset.
+Require Import List.
+Require Import Lsort.
+Require Import Mapsubset.
+Require Import Mapcard.
+
+Section MapCanon.
+
+  Variable A : Set.
+
+  Inductive mapcanon : Map A -> Prop :=
+    | M0_canon : mapcanon (M0 A)
+    | M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y)
+    | M2_canon :
+        forall m1 m2:Map A,
+          mapcanon m1 ->
+          mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2).
+
+  Lemma mapcanon_M2 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2).
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma mapcanon_M2_1 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1.
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma mapcanon_M2_2 :
+   forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2.
+  Proof.
+    intros. inversion H. assumption.
+  Qed.
+
+  Lemma M2_eqmap_1 :
+   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)).
+  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)).
+  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).
+    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.
+    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.
+    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)).
+    rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
+    simple induction m'. intros. cut (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 (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 :
+   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.
+    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.
+    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.
+    apply M1_canon.
+    simpl in |- *. apply le_n.
+    apply M2_canon. apply M1_canon.
+    apply M1_canon.
+    simpl in |- *. apply le_n.
+  Qed.
+
+  Lemma MapPut_canon :
+   forall m:Map A,
+     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.
+    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 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).
+    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 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).
+  Qed.
+
+  Lemma MapPut_behind_canon :
+   forall m:Map A,
+     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.
+    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 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).
+    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 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).
+  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. 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 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).
+    exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))).
+    simpl in |- *. 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 :=
+    match m with
+    | M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1)
+    | _ => m
+    end.
+
+  Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m).
+  Proof.
+    simple induction m. apply eqmap_refl.
+    intros. apply eqmap_refl.
+    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.
+  Qed.
+
+  Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
+  Proof.
+    simple induction m. apply M0_canon.
+    intros. simpl in |- *. apply M1_canon.
+    intros. simpl in |- *. apply makeM2_canon; assumption.
+  Qed.
+
+  Lemma mapcanon_exists :
+   forall 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 :
+   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.
+    assumption.
+    intros. simpl in |- *. 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 :
+   forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m').
+  Proof.
+    simple induction m. intros. exact H0.
+    simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y).
+    simple induction m'. intros. exact H1.
+    intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y).
+    intros. simpl in |- *. 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 (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *.
+    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 :
+   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).
+    intro. exact (MapRemove_canon m' H0 a).
+    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).
+    intro. exact (MapRemove_canon _ H1 a).
+    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).
+    exact (mapcanon_M2_2 _ _ H4).
+  Qed.
+
+  Variable B : Set.
+
+  Lemma MapDomRestrTo_canon :
+   forall m:Map A,
+     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.
+    intro. apply M1_canon.
+    simple induction m'. exact M0_canon.
+    unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). exact M0_canon.
+    intro. apply M1_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.
+
+  Lemma MapDomRestrBy_canon :
+   forall m:Map A,
+     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.
+    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).
+    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 in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
+    apply H0. exact (mapcanon_M2_2 _ _ H1).
+  Qed.
+
+  Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l).
+  Proof.
+    simple induction l. exact M0_canon.
+    intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption.
+  Qed.
+
+  Lemma MapSubset_c_1 :
+   forall (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 :
+   forall (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 in |- *. rewrite H. apply eqmap_refl.
+  Qed.
+
+End MapCanon.
+
+Section FSetCanon.
+
+  Variable A : Set.
+
+  Lemma MapDom_canon :
+   forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m).
+  Proof.
+    simple induction m. intro. exact (M0_canon unit).
+    intros a y H. exact (M1_canon unit a _).
+    intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1).
+    apply H0. exact (mapcanon_M2_2 A _ _ H1).
+    change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom.
+    exact (mapcanon_M2 A _ _ H1).
+  Qed.
+
+End FSetCanon.
+
+Section MapFoldCanon.
+
+  Variables A B : Set.
+
+  Lemma MapFold_canon_1 :
+   forall m0:Map B,
+     mapcanon B m0 ->
+     forall op:Map B -> Map B -> Map B,
+       (forall m1:Map B,
+          mapcanon B m1 ->
+          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
+       forall f:ad -> A -> Map B,
+         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+         forall (m:Map A) (pf:ad -> ad),
+           mapcanon B (MapFold1 A (Map B) m0 op f pf m).
+  Proof.
+    simple induction m. intro. exact H.
+    intros a y pf. simpl in |- *. apply H1.
+    intros. simpl in |- *. apply H0. apply H2.
+    apply H3.
+  Qed.
+
+  Lemma MapFold_canon :
+   forall m0:Map B,
+     mapcanon B m0 ->
+     forall op:Map B -> Map B -> Map B,
+       (forall m1:Map B,
+          mapcanon B m1 ->
+          forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
+       forall f:ad -> A -> Map B,
+         (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+         forall 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 (fun a:ad => a)).
+  Qed.
+
+  Lemma MapCollect_canon :
+   forall f:ad -> A -> Map B,
+     (forall (a:ad) (y:A), mapcanon B (f a y)) ->
+     forall 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.
\ No newline at end of file
diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v
new file mode 100644
index 00000000..49f9fe91
--- /dev/null
+++ b/theories/IntMap/Mapcard.v
@@ -0,0 +1,764 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Fset.
+Require Import Mapsubset.
+Require Import List.
+Require Import Lsort.
+Require Import Peano_dec.
+
+Section MapCard.
+
+  Variables A B : Set.
+
+  Lemma MapCard_M0 : MapCard A (M0 A) = 0.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapCard_M1 : forall (a:ad) (y:A), MapCard A (M1 A a y) = 1.
+  Proof.
+    trivial.
+  Qed.
+
+  Lemma MapCard_is_O :
+   forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = NONE A.
+  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.
+    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}.
+  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.
+    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 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).
+    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}}.
+  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.
+  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'.
+  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).
+    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 :
+   forall (C:Set) (l:list C),
+     length l = fold_right (fun (_:C) (n:nat) => S n) 0 l.
+  Proof.
+    simple induction l. reflexivity.
+    intros. simpl in |- *. rewrite H. reflexivity.
+  Qed.
+
+  Lemma length_as_fold_2 :
+   forall l:alist A,
+     length l =
+     fold_right (fun (r:ad * A) (n:nat) => let (a, y) := r in 1 + n) 0 l.
+  Proof.
+    simple induction l. reflexivity.
+    intros. simpl in |- *. rewrite H. elim a; reflexivity.
+  Qed.
+
+  Lemma MapCard_as_Fold_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     MapCard A m = MapFold1 A nat 0 plus (fun (_:ad) (_:A) => 1) pf m.
+  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.
+  Qed.
+
+  Lemma MapCard_as_Fold :
+   forall m:Map A,
+     MapCard A m = MapFold A nat 0 plus (fun (_:ad) (_:A) => 1) m.
+  Proof.
+    intro. exact (MapCard_as_Fold_1 m (fun a0:ad => a0)).
+  Qed.
+ 
+  Lemma MapCard_as_length :
+   forall 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 := 0) (f := fun (_:ad) (_:A) => 1). exact plus_assoc_reverse.
+    trivial.
+    intro. rewrite <- plus_n_O. reflexivity.
+  Qed.
+
+  Lemma MapCard_Put1_equals_2 :
+   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.
+  Qed.
+
+  Lemma MapCard_Put_sum :
+   forall (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.
+    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.
+    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 :
+   forall (m:Map A) (a:ad) (y:A), MapCard A (MapPut A m a y) >= MapCard A m.
+  Proof.
+    unfold ge in |- *. 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 :
+   forall (m:Map A) (a:ad) (y: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 H. rewrite H. apply le_n_Sn.
+    intro H. rewrite H. apply le_n.
+  Qed.
+
+  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}.
+  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 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)).
+    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))
+      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.
+    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.
+  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.
+    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 (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.
+    induction a. discriminate H2.
+    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).
+    cut
+     (MapCard A (MapPut A m0 (ad_div_2 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))
+   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.
+    induction p. discriminate H2.
+    reflexivity.
+    discriminate H2.
+  Qed.
+
+  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.
+  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 :
+   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).
+  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 :
+   forall m m':Map A,
+     eqm A (MapGet A m) (MapGet A m') -> MapCard A m = MapCard A m'.
+  Proof.
+    unfold eqm in |- *. 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 in |- *. 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 : forall m:Map A, MapCard A m = MapCard unit (MapDom A m).
+  Proof.
+    simple induction m; trivial. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapCard_Dom_Put_behind :
+   forall (m:Map A) (a:ad) (y:A),
+     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 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 p0. simpl in |- *. rewrite H0. reflexivity.
+    intro p0. simpl in |- *. rewrite H. reflexivity.
+    simpl in |- *. rewrite H0. reflexivity.
+    intro H1. rewrite H1. simpl in |- *. rewrite H. reflexivity.
+  Qed.
+
+  Lemma MapCard_Put_behind_Put :
+   forall (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 :
+   forall (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 :
+   forall m m':Map A, MapCard A (makeM2 A m m') = MapCard A m + MapCard A m'.
+  Proof.
+    intros. rewrite (MapCard_ext _ _ (makeM2_M2 A m m')). reflexivity.
+  Qed.
+ 
+  Lemma MapCard_Remove_sum :
+   forall (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.
+    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.
+    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 :
+   forall (m:Map A) (a:ad), 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 :
+   forall (m:Map A) (a:ad), S (MapCard A (MapRemove A m a)) >= MapCard A m.
+  Proof.
+    unfold ge in |- *. 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 :
+   forall (m:Map A) (a:ad),
+     MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = NONE A.
+  Proof.
+    simple induction m. trivial.
+    simpl in |- *. 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 ((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 (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))
+      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_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}.
+  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).
+    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
+      (S (MapCard A m0) + MapCard A (MapRemove A m1 (ad_div_2 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))))
+      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.
+    change
+      (S (MapCard A (MapRemove A m0 (ad_div_2 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))
+      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.
+  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 :
+   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.
+  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 :
+   forall m m':Map A,
+     MapCard A m + MapCard A m' =
+     MapCard A (MapMerge A m m') + MapCard A (MapDomRestrTo A A m m').
+  Proof.
+    simple induction m. simpl in |- *. intro. apply plus_n_O.
+    simpl in |- *. 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 in |- *. 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
+      (MapCard A m0 + MapCard A m1 + MapCard A m' =
+       MapCard A (MapMerge A (M2 A m0 m1) m') +
+       MapCard A (MapDomRestrTo A A (M2 A m0 m1) m')) 
+     in |- *.
+    elim m'. reflexivity.
+    intros a y. unfold MapMerge in |- *. unfold MapDomRestrTo in |- *.
+    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 in |- *.
+    rewrite <- (plus_Snm_nSm (MapCard A m0 + MapCard A m1) 0). reflexivity.
+    intros. simpl in |- *.
+    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 :
+   forall m m':Map A,
+     MapDisjoint A A m m' ->
+     MapCard A (MapMerge A m m') = 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 :
+   forall (m:Map A) (m':Map B),
+     MapCard A m =
+     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 in |- *. apply MapDom_Split_3.
+  Qed.
+
+  Lemma MapMerge_Card_ub :
+   forall m m':Map A,
+     MapCard A (MapMerge A m m') <= MapCard A m + MapCard A m'.
+  Proof.
+    intros. rewrite MapMerge_Restr_Card. apply le_plus_l.
+  Qed.
+
+  Lemma MapDomRestrTo_Card_ub_l :
+   forall (m:Map A) (m':Map B),
+     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 :
+   forall (m:Map A) (m':Map B),
+     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 :
+   forall m m':Map A,
+     MapCard A (MapMerge A m m') = MapCard A m + MapCard A m' ->
+     MapDisjoint A A m m'.
+  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.
+    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.
+    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.
+    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).
+    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)) =
+       MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) 
+     in H3.
+    rewrite <- H3. simpl in |- *. apply plus_le_compat_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 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.
+    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).
+    rewrite
+     (plus_comm (MapCard A m1 + MapCard A m3) (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_comm (MapCard A m1 + MapCard A m3) (MapCard A (MapMerge A m0 m2)))
+     .
+    change
+      (MapCard A (MapMerge A m0 m2) + MapCard A (MapMerge A m1 m3) =
+       MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) 
+     in H3.
+    rewrite <- H3. apply plus_le_compat_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 in |- *. 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 in |- *. rewrite H7. reflexivity.
+  Qed.
+
+  Lemma MapCard_is_Sn :
+   forall (m:Map A) (n:nat),
+     MapCard _ m = S n -> {a : ad | in_dom _ a m = true}.
+  Proof.
+    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.
+    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 |- *.
+    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.
+
+  Variables A B : Set.
+
+  Lemma MapSubset_card_eq_1 :
+   forall (n:nat) (m:Map A) (m':Map B),
+     MapSubset _ _ m m' ->
+     MapCard _ m = n -> MapCard _ m' = n -> MapSubset _ _ m' m.
+  Proof.
+    simple induction n. intros. unfold MapSubset, in_dom in |- *. 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 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).
+    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).
+    apply sym_eq. assumption.
+    intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity.
+  Qed.
+
+  Lemma MapDomRestrTo_Card_ub_r :
+   forall (m:Map A) (m':Map B),
+     MapCard A (MapDomRestrTo A B m m') <= MapCard B m'.
+  Proof.
+    simple induction m. intro. simpl in |- *. apply le_O_n.
+    intros a y m'. simpl in |- *. 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 in |- *.
+    apply le_n_S. apply le_O_n.
+    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.
+    intro. simpl in |- *. apply le_n.
+    intros. simpl in |- *. rewrite
+  (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3))
+  .
+    apply plus_le_compat. apply H.
+    apply H0.
+  Qed.
+
+End MapCard2.
+
+Section MapCard3.
+
+  Variables A B : Set.
+
+  Lemma MapMerge_Card_lb_l :
+   forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m')).
+    rewrite (plus_comm (MapCard A m') (MapCard A m)).
+    rewrite (plus_comm (MapCard A m') (MapCard A (MapMerge A m m'))).
+    rewrite (MapMerge_Restr_Card A m m'). apply plus_le_compat_l. apply MapDomRestrTo_Card_ub_r.
+  Qed.
+
+  Lemma MapMerge_Card_lb_r :
+   forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m'.
+  Proof.
+    unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m)). rewrite (MapMerge_Restr_Card A m m').
+    rewrite
+     (plus_comm (MapCard A (MapMerge A m m'))
+        (MapCard A (MapDomRestrTo A A m m'))).
+    apply plus_le_compat_r. apply MapDomRestrTo_Card_ub_l.
+  Qed.
+
+  Lemma MapDomRestrBy_Card_lb :
+   forall (m:Map A) (m':Map B),
+     MapCard B m' + MapCard A (MapDomRestrBy A B m m') >= MapCard A m.
+  Proof.
+    unfold ge in |- *. intros. rewrite (MapSplit_Card A B m m'). apply plus_le_compat_r.
+    apply MapDomRestrTo_Card_ub_r.
+  Qed.
+
+  Lemma MapSubset_Card_le :
+   forall (m:Map A) (m':Map B),
+     MapSubset A B m m' -> MapCard A m <= MapCard B m'.
+  Proof.
+    intros. apply le_trans with (m := MapCard B m' + MapCard A (MapDomRestrBy A B m m')).
+    exact (MapDomRestrBy_Card_lb m m').
+    rewrite (MapCard_ext _ _ _ (MapSubset_imp_2 _ _ _ _ H)). simpl in |- *. rewrite <- plus_n_O.
+    apply le_n.
+  Qed.
+
+  Lemma MapSubset_card_eq :
+   forall (m:Map A) (m':Map B),
+     MapSubset _ _ m m' ->
+     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.
\ No newline at end of file
diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v
new file mode 100644
index 00000000..641529ee
--- /dev/null
+++ b/theories/IntMap/Mapfold.v
@@ -0,0 +1,424 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $      i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapiter.
+Require Import Lsort.
+Require Import Mapsubset.
+Require Import List.
+
+Section MapFoldResults.
+
+  Variable A : Set.
+
+  Variable M : Set.
+  Variable neutral : M.
+  Variable op : M -> M -> M.
+
+  Variable nleft : forall a:M, op neutral a = a.
+  Variable nright : forall a:M, op a neutral = a.
+  Variable assoc : forall a b c:M, op (op a b) c = op a (op b c).
+
+  Lemma MapFold_ext :
+   forall (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 :
+   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) ->
+     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.
+  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) ->
+     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).
+  Qed.
+
+  Lemma MapFold1_as_Fold_1 :
+   forall (m:Map A) (f f':ad -> A -> M) (pf pf':ad -> ad),
+     (forall (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.
+    simple induction m. trivial.
+    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))).
+    rewrite
+     (H0 f f' (fun a0:ad => pf (ad_double_plus_un a0))
+        (fun a0:ad => pf' (ad_double_plus_un a0))).
+    reflexivity.
+    intros. apply H1.
+    intros. apply H1.
+  Qed.
+
+  Lemma MapFold1_as_Fold :
+   forall (f:ad -> A -> M) (pf:ad -> ad) (m:Map A),
+     MapFold1 _ _ neutral op f pf m =
+     MapFold _ _ neutral op (fun (a:ad) (y:A) => f (pf a) y) m.
+  Proof.
+    intros. unfold MapFold in |- *. apply MapFold1_as_Fold_1. trivial.
+  Qed.
+
+  Lemma MapFold1_ext :
+   forall (f:ad -> A -> M) (m m':Map A),
+     eqmap A m m' ->
+     forall 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 : forall a b:M, op a b = op b a.
+
+  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 ->
+     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).
+    rewrite negb_elim. reflexivity.
+    assumption.
+    intro H1. rewrite H1. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    reflexivity.
+    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0).
+    rewrite negb_elim. reflexivity.
+    assumption.
+    simpl in |- *. intros. elim (sumbool_of_bool (ad_bit_0 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.
+    assumption.
+    rewrite <- ad_xor_div_2. 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)
+     .
+    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 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.
+    assumption.
+    change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H).
+    rewrite negb_elim. reflexivity.
+    intro H0. rewrite H0. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un.
+    reflexivity.
+    change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_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 ->
+     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 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 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.
+    rewrite
+     (comm (MapFold1 A M neutral op f (fun 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 in |- *. 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 in |- *. rewrite (H (ad_div_2 a) y (fun 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 in |- *. 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 :
+   forall (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 (fun a0:ad => a0) H).
+  Qed.
+
+  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 ->
+     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 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.
+    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.
+    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 :
+   forall (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 (fun a0:ad => a0) H).
+  Qed.
+
+  Lemma MapFold_Merge_disjoint_1 :
+   forall (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.
+    simple induction m1. simpl in |- *. intros. rewrite nleft. reflexivity.
+    intros. unfold MapMerge in |- *. apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf).
+    apply in_dom_none. exact (MapDisjoint_M1_l _ _ m2 a a0 H).
+    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))).
+    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.
+    exact (MapDisjoint_M2_r _ _ _ _ _ _ H3).
+    exact (MapDisjoint_M2_l _ _ _ _ _ _ H3).
+  Qed.
+
+  Lemma MapFold_Merge_disjoint :
+   forall (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 (fun 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 : forall c:N, times neutral c = neutral'.
+  Variable
+    distr :
+      forall (a b:M) (c:N), times (op a b) c = op' (times a c) (times b c).
+
+  Lemma MapFold_distr_r_1 :
+   forall (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' (fun (a:ad) (y:A) => times (f a y) c) pf m.
+  Proof.
+    simple induction m. intros. exact (absorb c).
+    trivial.
+    intros. simpl in |- *. rewrite distr. rewrite H. rewrite H0. reflexivity.
+  Qed.
+
+  Lemma MapFold_distr_r :
+   forall (f:ad -> A -> M) (m:Map A) (c:N),
+     times (MapFold A M neutral op f m) c =
+     MapFold A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) m.
+  Proof.
+    intros. exact (MapFold_distr_r_1 f m c (fun 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 : forall c:N, times c neutral = neutral'.
+  Variable
+    distr :
+      forall (a b:M) (c:N), times c (op a b) = op' (times c a) (times c b).
+
+  Lemma MapFold_distr_l :
+   forall (f:ad -> A -> M) (m:Map A) (c:N),
+     times c (MapFold A M neutral op f m) =
+     MapFold A M' neutral' op' (fun (a:ad) (y:A) => times c (f a y)) m.
+  Proof.
+    intros. apply MapFold_distr_r with (times := fun (a:M) (b:N) => times b a);
+  assumption.
+  Qed.
+
+End MapFoldDistrL.
+
+Section MapFoldExists.
+
+  Variable A : Set.
+
+  Lemma MapFold_orb_1 :
+   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
+     | _ => 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.
+  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
+     | _ => false
+     end.
+  Proof.
+    intros. exact (MapFold_orb_1 f m (fun a:ad => a)).
+  Qed.
+
+End MapFoldExists.
+
+Section DMergeDef.
+
+  Variable A : Set.
+
+  Definition DMerge :=
+    MapFold (Map A) (Map A) (M0 A) (MapMerge A) (fun (_:ad) (m:Map A) => m).
+
+  Lemma in_dom_DMerge_1 :
+   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
+     | _ => false
+     end.
+  Proof.
+    unfold DMerge in |- *. intros.
+    rewrite
+     (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false orb ad
+        (in_dom A) (fun c:ad => refl_equal _) (in_dom_merge A))
+     .
+    apply MapFold_orb.
+  Qed.
+
+  Lemma in_dom_DMerge_2 :
+   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}}.
+  Proof.
+    intros m a. rewrite in_dom_DMerge_1.
+    elim
+     (option_sum _
+        (MapSweep (Map A) (fun (_: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 :
+   forall (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 _ (fun (_: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.
\ No newline at end of file
diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v
new file mode 100644
index 00000000..f5d443cc
--- /dev/null
+++ b/theories/IntMap/Mapiter.v
@@ -0,0 +1,620 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Mapaxioms.
+Require Import Fset.
+Require Import List.
+
+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) {struct m} : 
+   option (ad * A) :=
+    match m with
+    | 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'
+        end
+    end.
+
+  Definition MapSweep (m:Map A) := MapSweep1 (fun a:ad => a) m.
+
+  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.
+  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)).
+    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).
+  Qed.
+
+  Lemma MapSweep_semantics_1 :
+   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'}.
+  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.
+    inversion H. reflexivity.
+    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.
+    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).
+    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.
+  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.
+  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).
+    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)).
+    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.
+    elim
+     (option_sum (ad * A) (MapSweep1 (fun 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 (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.
+    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.
+    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.
+    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.
+    assumption.
+    intro H4. rewrite H4 in H2.
+    elim
+     (MapSweep_semantics_2_1 m1 (fun 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 :
+   forall (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 (fun a0:ad => a0) (fun a0:ad => a0)
+        (fun a0:ad => refl_equal a0) a y H).
+  Qed.
+
+  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.
+  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 H1. rewrite H1. intro. discriminate H2.
+    intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun 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 (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).
+  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.
+  Proof.
+    intros.
+    exact (MapSweep_semantics_3_1 m (fun a0:ad => a0) H a y H0).
+  Qed.
+
+  Lemma MapSweep_semantics_4_1 :
+   forall (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.
+    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.
+    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 (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)).
+    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.
+    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')}}.
+  Proof.
+    intros. exact (MapSweep_semantics_4_1 m (fun 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) {struct m} : Map B :=
+    match m with
+    | 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)
+    end.
+
+  Definition MapCollect (f:ad -> A -> Map B) (m:Map A) :=
+    MapCollect1 f (fun 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) {struct m} : M :=
+      match m with
+      | 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)
+      end.
+
+    Definition MapFold (f:ad -> A -> M) (m:Map A) :=
+      MapFold1 f (fun a:ad => a) m.
+
+    Lemma MapFold_empty : forall f:ad -> A -> M, MapFold f (M0 A) = neutral.
+    Proof.
+      trivial.
+    Qed.
+
+    Lemma MapFold_M1 :
+     forall (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) {struct m} : State * M :=
+      match m with
+      | 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
+          | (state1, x1) =>
+              match
+                MapFold1_state state1
+                  (fun a0:ad => pf (ad_double_plus_un a0)) m2
+              with
+              | (state2, x2) => (state2, op x1 x2)
+              end
+          end
+      end.
+
+    Definition MapFold_state (state:State) :=
+      MapFold1_state state (fun a:ad => a).
+
+    Lemma pair_sp : forall (B C:Set) (x:B * C), x = (fst x, snd x).
+    Proof.
+      simple induction x. trivial.
+    Qed.
+
+    Lemma MapFold_state_stateless_1 :
+     forall (m:Map A) (g:ad -> A -> M) (pf:ad -> ad),
+       (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) ->
+       forall state:State, snd (MapFold1_state state pf m) = MapFold1 g pf m.
+    Proof.
+      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))
+  .
+      rewrite (H g (fun a0:ad => pf (ad_double 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))
+       .
+      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)))
+       .
+      reflexivity.
+    Qed.
+
+    Lemma MapFold_state_stateless :
+     forall g:ad -> A -> M,
+       (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) ->
+       forall (state:State) (m:Map A),
+         snd (MapFold_state state m) = MapFold g m.
+    Proof.
+      intros. exact (MapFold_state_stateless_1 m g (fun a0:ad => a0) H state).
+    Qed.
+
+  End MapFoldDef.
+
+  Lemma MapCollect_as_Fold :
+   forall (f:ad -> A -> Map B) (m:Map A),
+     MapCollect f m = MapFold (Map B) (M0 B) (MapMerge B) f m.
+  Proof.
+    simple induction m; trivial.
+  Qed.
+
+  Definition alist := list (ad * A).
+  Definition anil := nil (A:=(ad * A)).
+  Definition acons := cons (A:=(ad * A)).
+  Definition aapp := app (A:=(ad * A)).
+
+  Definition alist_of_Map :=
+    MapFold alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil).
+
+  Fixpoint alist_semantics (l:alist) : ad -> option A :=
+    match l with
+    | nil => fun _:ad => NONE A
+    | (a, y) :: l' =>
+        fun a0:ad => if ad_eq a a0 then SOME A 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
+     end.
+  Proof.
+    unfold aapp in |- *. simple induction l. trivial.
+    intros. elim a. intros a1 y1. simpl in |- *. case (ad_eq a1 a0). reflexivity.
+    apply H.
+  Qed.
+
+  Lemma alist_of_Map_semantics_1_1 :
+   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'}.
+  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.
+    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)
+         (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.
+    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)
+        (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil)
+           (fun a0:ad => pf (ad_double_plus_un 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.
+  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)).
+  Proof.
+    unfold ad_inj in |- *. intros. apply ad_double_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)).
+  Proof.
+    unfold ad_inj in |- *. intros. apply ad_double_plus_un_inj. exact (H _ _ H0).
+  Qed.
+
+  Lemma alist_of_Map_semantics_1 :
+   forall (m:Map A) (pf:ad -> ad),
+     ad_inj pf ->
+     forall a:ad,
+       MapGet A m a =
+       alist_semantics
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            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.
+    discriminate H0.
+    intro H1. rewrite H1. reflexivity.
+    intros. change
+   (MapGet A (M2 A m0 m1) a =
+    alist_semantics
+      (aapp
+         (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil)
+            (fun a0:ad => pf (ad_double 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)) (
+      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).
+    rewrite <-
+     (H (fun 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
+              (fun (a1:ad) (y:A) => acons (a1, y) anil)
+              (fun 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 (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.
+    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 (fun 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
+              (fun (a1:ad) (y:A) => acons (a1, y) anil)
+              (fun 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 (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.
+    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 :
+   forall m:Map A, eqm A (MapGet A m) (alist_semantics (alist_of_Map m)).
+  Proof.
+    unfold eqm in |- *. intros. exact
+  (alist_of_Map_semantics_1 m (fun a0:ad => a0)
+     (fun (a0 a1:ad) (p:a0 = a1) => p) a).
+  Qed.
+
+  Fixpoint Map_of_alist (l:alist) : Map A :=
+    match l with
+    | nil => M0 A
+    | (a, y) :: l' => MapPut A (Map_of_alist l') a y
+    end.
+
+  Lemma Map_of_alist_semantics :
+   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).
+    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 :
+   forall m:Map A, eqmap A (Map_of_alist (alist_of_Map m)) m.
+  Proof.
+    unfold eqmap in |- *. 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 :
+   forall 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 :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     forall (f:ad -> A -> M) (l l':alist),
+       fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m)
+         neutral (aapp l l') =
+       op
+         (fold_right
+            (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral
+            l)
+         (fold_right
+            (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral
+            l').
+  Proof.
+    simple induction l. simpl in |- *. intro. rewrite H0. reflexivity.
+    intros r l0 H1 l'. elim r. intros a y. simpl in |- *. rewrite H. rewrite (H1 l'). reflexivity.
+  Qed.
+
+  Lemma MapFold_as_fold_1 :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     (forall a:M, op a neutral = a) ->
+     forall (f:ad -> A -> M) (m:Map A) (pf:ad -> ad),
+       MapFold1 M neutral op f pf m =
+       fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m)
+         neutral
+         (MapFold1 alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil) pf
+            m).
+  Proof.
+    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))).
+    reflexivity.
+  Qed.
+
+  Lemma MapFold_as_fold :
+   forall (M:Set) (neutral:M) (op:M -> M -> M),
+     (forall a b c:M, op (op a b) c = op a (op b c)) ->
+     (forall a:M, op neutral a = a) ->
+     (forall a:M, op a neutral = a) ->
+     forall (f:ad -> A -> M) (m:Map A),
+       MapFold M neutral op f m =
+       fold_right (fun (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 (fun a0:ad => a0)).
+  Qed.
+
+  Lemma alist_MapMerge_semantics :
+   forall 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 in |- *. 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 :
+   forall 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 in |- *. 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 :
+   forall 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 in |- *. 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/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v
new file mode 100644
index 00000000..645c3407
--- /dev/null
+++ b/theories/IntMap/Maplists.v
@@ -0,0 +1,437 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:04 herbelin Exp $	 i*)
+
+Require Import Addr.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapsubset.
+Require Import Mapcard.
+Require Import Mapcanon.
+Require Import Mapc.
+Require Import Bool.
+Require Import Sumbool.
+Require Import List.
+Require Import Arith.
+Require Import Mapiter.
+Require Import Mapfold.
+
+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')
+    end.
+
+  Fixpoint ad_list_stutters (l:list ad) : bool :=
+    match l with
+    | nil => false
+    | a :: l' => orb (ad_in_list a l') (ad_list_stutters l')
+    end.
+
+  Lemma ad_in_list_forms_circuit :
+   forall (x:ad) (l:list ad),
+     ad_in_list x l = true ->
+     {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.
+    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.
+
+  Lemma ad_list_stutters_has_circuit :
+   forall l:list ad,
+     ad_list_stutters l = true ->
+     {x : ad & 
+     {l0 : list ad & 
+     {l1 : list ad &  {l2 : list ad | l = l0 ++ x :: l1 ++ x :: l2}}}}.
+  Proof.
+    simple induction l. intro. discriminate H.
+    intros. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. split with a.
+    split with (nil (A:=ad)). simpl in |- *. 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 (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 :=
+    match l with
+    | nil => M0 unit
+    | a :: l' => MapPut _ (Elems l') a tt
+    end.
+
+  Lemma Elems_canon : forall l:list ad, mapcanon _ (Elems l).
+  Proof.
+    simple induction l. exact (M0_canon unit).
+    intros. simpl in |- *. apply MapPut_canon. assumption.
+  Qed.
+
+  Lemma Elems_app :
+   forall l l':list ad, Elems (l ++ l') = FSetUnion (Elems l) (Elems l').
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)).
+    rewrite (MapPut_as_Merge_c unit (Elems (l0 ++ l'))).
+    change
+      (FSetUnion (Elems (l0 ++ l')) (M1 unit a tt) =
+       FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')) 
+     in |- *.
+    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 : forall l:list ad, Elems (rev l) = Elems l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite Elems_app. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)).
+    rewrite H. reflexivity.
+    apply Elems_canon.
+  Qed.
+
+  Lemma ad_in_elems_in_list :
+   forall (l:list ad) (a:ad), in_FSet a (Elems l) = ad_in_list a l.
+  Proof.
+    simple induction l. trivial.
+    simpl in |- *. unfold in_FSet in |- *. intros. rewrite (in_dom_put _ (Elems l0) a tt a0).
+    rewrite (H a0). reflexivity.
+  Qed.
+
+  Lemma ad_list_not_stutters_card :
+   forall l:list ad,
+     ad_list_stutters l = false -> length l = MapCard _ (Elems l).
+  Proof.
+    simple induction l. trivial.
+    simpl in |- *. 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 : forall l:list ad, MapCard _ (Elems l) <= length l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. apply le_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub.
+    apply le_n_S. assumption.
+  Qed.
+
+  Lemma ad_list_stutters_card :
+   forall l:list ad,
+     ad_list_stutters l = true -> MapCard _ (Elems l) < length l.
+  Proof.
+    simple induction l. intro. discriminate H.
+    intros. simpl in |- *. 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 :
+   forall 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 (MapCard _ (Elems l) < length l). intro. rewrite H in H1. elim (lt_irrefl _ H1).
+    exact (ad_list_stutters_card _ H0).
+    trivial.
+  Qed.
+
+  Lemma ad_list_stutters_card_conv :
+   forall l:list ad,
+     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_irrefl _ H).
+  Qed.
+
+  Lemma ad_in_list_l :
+   forall (l l':list ad) (a:ad),
+     ad_in_list a l = true -> ad_in_list a (l ++ l') = true.
+  Proof.
+    simple induction l. intros. discriminate H.
+    intros. simpl in |- *. 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 :
+   forall l l':list ad,
+     ad_list_stutters l = true -> ad_list_stutters (l ++ l') = true.
+  Proof.
+    simple induction l. intros. discriminate H.
+    intros. simpl in |- *. 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 :
+   forall (l l':list ad) (a:ad),
+     ad_in_list a l' = true -> ad_in_list a (l ++ l') = true.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l' a0 H0). apply orb_b_true. 
+  Qed.
+
+  Lemma ad_list_stutters_app_r :
+   forall l l':list ad,
+     ad_list_stutters l' = true -> ad_list_stutters (l ++ l') = true.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l' H0). apply orb_b_true.
+  Qed.
+
+  Lemma ad_list_stutters_app_conv_l :
+   forall l l':list ad,
+     ad_list_stutters (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 :
+   forall l l':list ad,
+     ad_list_stutters (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 :
+   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.
+    intros. simpl in |- *. rewrite (H l' x). apply orb_b_true.
+  Qed.
+
+  Lemma ad_in_list_app :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x (l ++ l') = orb (ad_in_list x l) (ad_in_list x l').
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite <- orb_assoc. rewrite (H l' x). reflexivity.
+  Qed.
+
+  Lemma ad_in_list_rev :
+   forall (l:list ad) (x:ad), ad_in_list x (rev l) = ad_in_list x l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite ad_in_list_app. rewrite (H x). simpl in |- *. rewrite orb_b_false.
+    apply orb_comm.
+  Qed.
+
+  Lemma ad_list_has_circuit_stutters :
+   forall (l0 l1 l2:list ad) (x:ad),
+     ad_list_stutters (l0 ++ x :: l1 ++ x :: l2) = true.
+  Proof.
+    simple induction l0. simpl in |- *. intros. rewrite (ad_in_list_app_1 l1 l2 x). reflexivity.
+    intros. simpl in |- *. rewrite (H l1 l2 x). apply orb_b_true.
+  Qed.
+
+  Lemma ad_list_stutters_prev_l :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x l = true -> ad_list_stutters (l ++ 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 in |- *. apply ad_list_has_circuit_stutters.
+  Qed.
+
+  Lemma ad_list_stutters_prev_conv_l :
+   forall (l l':list ad) (x:ad),
+     ad_list_stutters (l ++ 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 :
+   forall (l l':list ad) (x:ad),
+     ad_in_list x l' = true -> ad_list_stutters (l ++ 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 :
+   forall (l l':list ad) (x:ad),
+     ad_list_stutters (l ++ 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 :
+   forall 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 :
+   forall l l':list ad, length (l ++ l') = length l + length l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (H l'). reflexivity.
+  Qed.
+
+  Lemma ad_list_stutters_permute :
+   forall l l':list ad,
+     ad_list_stutters (l ++ l') = ad_list_stutters (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_comm.
+  Qed.
+
+  Lemma ad_list_rev_length : forall l:list ad, length (rev l) = length l.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite ad_list_app_length. simpl in |- *. rewrite H. rewrite <- plus_Snm_nSm.
+    rewrite <- plus_n_O. reflexivity.
+  Qed.
+
+  Lemma ad_list_stutters_rev :
+   forall 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 :
+   forall (l l':list ad) (x:ad), rev l ++ x :: l' = rev (x :: l) ++ l'.
+  Proof.
+    simple induction l. trivial.
+    intros. simpl in |- *. rewrite (app_ass (rev l0) (a :: nil) (x :: l')). simpl in |- *.
+    rewrite (H (x :: l') a). simpl in |- *.
+    rewrite (app_ass (rev l0) (a :: nil) (x :: nil)). simpl in |- *.
+    rewrite app_ass. simpl in |- *. rewrite app_ass. reflexivity.
+  Qed.
+
+  Section ListOfDomDef.
+
+  Variable A : Set.
+
+  Definition ad_list_of_dom :=
+    MapFold A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil).
+
+  Lemma ad_in_list_of_dom_in_dom :
+   forall (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 in |- *. intros.
+    rewrite
+     (MapFold_distr_l A (list ad) nil (app (A:=ad)) bool false orb ad
+        (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).
+    elim
+     (option_sum _
+        (MapSweep A (fun (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 in |- *.
+    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 (y:=_)).
+  Qed.
+
+  Lemma Elems_of_list_of_dom :
+   forall m:Map A, eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m).
+  Proof.
+    unfold eqmap, eqm in |- *. 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 :
+   forall 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 :
+   forall (m:Map A) (pf:ad -> ad),
+     length
+       (MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil)
+          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))).
+    reflexivity.
+  Qed.
+
+  Lemma ad_list_of_dom_card :
+   forall m:Map A, length (ad_list_of_dom m) = MapCard A m.
+  Proof.
+    exact (fun m:Map A => ad_list_of_dom_card_1 m (fun a:ad => a)).
+  Qed.
+
+  Lemma ad_list_of_dom_not_stutters :
+   forall 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 :
+   forall (A:Set) (m:Map A) (pf:ad -> ad),
+     MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) pf
+       m =
+     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.
+  Qed.
+
+  Lemma ad_list_of_dom_Dom :
+   forall (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 (fun a0:ad => a0)).
+  Qed.
+
+End MapLists.
\ No newline at end of file
diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v
new file mode 100644
index 00000000..33b412e3
--- /dev/null
+++ b/theories/IntMap/Mapsubset.v
@@ -0,0 +1,606 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:05 herbelin Exp $	 i*)
+
+Require Import Bool.
+Require Import Sumbool.
+Require Import Arith.
+Require Import ZArith.
+Require Import Addr.
+Require Import Adist.
+Require Import Addec.
+Require Import Map.
+Require Import Fset.
+Require Import Mapaxioms.
+Require Import Mapiter.
+
+Section MapSubsetDef.
+
+  Variables A B : Set.
+
+  Definition MapSubset (m:Map A) (m':Map B) :=
+    forall a:ad, in_dom A a m = true -> in_dom B a m' = true.
+
+  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
+    | _ => false
+    end.
+
+  Definition MapSubset_2 (m:Map A) (m':Map B) :=
+    eqmap A (MapDomRestrBy A B m m') (M0 A).
+
+  Lemma MapSubset_imp_1 :
+   forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_1 m m' = true.
+  Proof.
+    unfold MapSubset, MapSubset_1 in |- *. intros.
+    elim
+     (option_sum _ (MapSweep A (fun (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 :
+   forall (m:Map A) (m':Map B), MapSubset_1 m m' = true -> MapSubset m m'.
+  Proof.
+    unfold MapSubset, MapSubset_1 in |- *. unfold in_dom at 2 in |- *. intros. elim (option_sum _ (MapGet A m a)).
+    intro H1. elim H1. intros y H2.
+    elim
+     (option_sum _ (MapSweep A (fun (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 :
+   forall m:Map A, eqmap A m (M0 A) -> forall a:ad, in_dom _ a m = false.
+  Proof.
+    unfold eqmap, eqm, in_dom in |- *. intros. rewrite (H a). reflexivity.
+  Qed.
+
+  Lemma map_dom_empty_2 :
+   forall m:Map A, (forall a:ad, in_dom _ a m = false) -> eqmap A m (M0 A).
+  Proof.
+    unfold eqmap, eqm, in_dom in |- *. intros.
+    cut
+     (match MapGet A m a with
+      | NONE => false
+      | SOME _ => true
+      end = false).
+    case (MapGet A m a). trivial.
+    intros. discriminate H0.
+    exact (H a).
+  Qed.
+
+  Lemma MapSubset_imp_2 :
+   forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_2 m m'.
+  Proof.
+    unfold MapSubset, MapSubset_2 in |- *. 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 :
+   forall (m:Map A) (m':Map B), MapSubset_2 m m' -> MapSubset m m'.
+  Proof.
+    unfold MapSubset, MapSubset_2 in |- *. 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.
+
+  Variables A B C : Set.
+
+  Lemma MapSubset_refl : forall m:Map A, MapSubset A A m m.
+  Proof.
+      unfold MapSubset in |- *. trivial.
+  Qed.
+
+  Lemma MapSubset_antisym :
+   forall (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 in |- *. 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 in |- *. 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 in |- *. rewrite H3. reflexivity.
+    intro H2. rewrite H2. exact H1.
+  Qed.
+
+  Lemma MapSubset_trans :
+   forall (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 in |- *. intros. apply H0. apply H. assumption.
+  Qed.
+
+End MapSubsetOrder.
+
+Section FSubsetOrder.
+
+  Lemma FSubset_refl : forall s:FSet, MapSubset _ _ s s.
+  Proof.
+    exact (MapSubset_refl unit).
+  Qed.
+
+  Lemma FSubset_antisym :
+   forall 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 :
+   forall 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.
+
+  Variables A B : Set.
+
+  Lemma MapSubset_Dom_1 :
+   forall (m:Map A) (m':Map B),
+     MapSubset A B m m' -> MapSubset unit unit (MapDom A m) (MapDom B m').
+  Proof.
+    unfold MapSubset in |- *. 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 :
+   forall (m:Map A) (m':Map B),
+     MapSubset unit unit (MapDom A m) (MapDom B m') -> MapSubset A B m m'.
+  Proof.
+    unfold MapSubset in |- *. 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 in |- *. rewrite H3. reflexivity.
+    intro H1. rewrite H1 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapSubset_1_Dom :
+   forall (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 :
+   forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut A m a y).
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Put_mono :
+   forall (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 in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut_behind A m a y).
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Put_behind_mono :
+   forall (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 in |- *. 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 :
+   forall (m:Map A) (a:ad), MapSubset A A (MapRemove A m a) m.
+  Proof.
+    unfold MapSubset in |- *. intros. unfold MapSubset in |- *. intros. rewrite (in_dom_remove _ m a a0) in H.
+    elim (andb_prop _ _ H). trivial.
+  Qed.
+
+  Lemma MapSubset_Remove_mono :
+   forall (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 in |- *. 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 :
+   forall m m':Map A, MapSubset A A m (MapMerge A m m').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. reflexivity.
+  Qed.
+
+  Lemma MapSubset_Merge_r :
+   forall m m':Map A, MapSubset A A m' (MapMerge A m m').
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. apply orb_b_true.
+  Qed.
+
+  Lemma MapSubset_Merge_mono :
+   forall (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 in |- *. 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 :
+   forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrTo A B m m') m.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_DomRestrTo_r :
+   forall (m:Map A) (m':Map B), MapSubset A B (MapDomRestrTo A B m m') m'.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_ext :
+   forall (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 in |- *.
+    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.
+
+  Variables C D : Set.
+
+  Lemma MapSubset_DomRestrTo_mono :
+   forall (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 in |- *. 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 :
+   forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrBy A B m m') m.
+  Proof.
+    unfold MapSubset in |- *. intros. rewrite (in_dom_restrby _ _ m m' a) in H. elim (andb_prop _ _ H).
+    trivial.
+  Qed.
+
+  Lemma MapSubset_DomRestrBy_mono :
+   forall (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 in |- *. 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.
+
+  Variables A B : Set.
+
+  Definition MapDisjoint (m:Map A) (m':Map B) :=
+    forall a:ad, in_dom A a m = true -> in_dom B a m' = true -> False.
+
+  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
+    | _ => false
+    end.
+
+  Definition MapDisjoint_2 (m:Map A) (m':Map B) :=
+    eqmap A (MapDomRestrTo A B m m') (M0 A).
+
+  Lemma MapDisjoint_imp_1 :
+   forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_1 m m' = true.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_1 in |- *. intros.
+    elim (option_sum _ (MapSweep A (fun (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 in_dom at 1 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 :
+   forall (m:Map A) (m':Map B), MapDisjoint_1 m m' = true -> MapDisjoint m m'.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_1 in |- *. intros.
+    elim (option_sum _ (MapSweep A (fun (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 :
+   forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_2 m m'.
+  Proof.
+    unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. 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 in_dom at 1 in H0.
+    elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. intros y' H4. unfold in_dom at 1 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 :
+   forall (m:Map A) (m':Map B), MapDisjoint_2 m m' -> MapDisjoint m m'.
+  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.
+    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 : forall m:Map B, MapDisjoint (M0 A) m.
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. discriminate H.
+  Qed.
+
+  Lemma Map_disjoint_M0 : forall m:Map A, MapDisjoint m (M0 B).
+  Proof.
+    unfold MapDisjoint, in_dom in |- *. intros. discriminate H0.
+  Qed.
+
+End MapDisjointDef.
+
+Section MapDisjointExtra.
+
+  Variables A B : Set.
+
+  Lemma MapDisjoint_ext :
+   forall (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 in |- *.
+    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 :
+   forall m m':Map A,
+     MapDisjoint A A m m' ->
+     forall 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 in |- *. 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 in |- *. rewrite andb_b_true. reflexivity.
+  Qed.
+
+  Lemma MapDisjoint_M2_l :
+   forall (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 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.
+    intro H4. rewrite H4 in H1. discriminate H1.
+    intro H2. rewrite H2 in H0. discriminate H0.
+  Qed.
+
+  Lemma MapDisjoint_M2_r :
+   forall (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 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)).
+    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 :
+   forall (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 in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:B),
+     MapDisjoint B A (M1 B a y) m -> in_dom A a m = false.
+  Proof.
+    unfold MapDisjoint in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:B),
+     MapDisjoint A B m (M1 B a y) -> in_dom A a m = false.
+  Proof.
+    unfold MapDisjoint in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:B),
+     in_dom A a m = false -> MapDisjoint B A (M1 B a y) m.
+  Proof.
+    unfold MapDisjoint in |- *. 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 :
+   forall (m:Map A) (a:ad) (y:B),
+     in_dom A a m = false -> MapDisjoint A B m (M1 B a y).
+  Proof.
+    unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H1) in H. rewrite H0 in H.
+    discriminate H.
+  Qed.
+ 
+  Lemma MapDisjoint_sym :
+   forall (m:Map A) (m':Map B), MapDisjoint A B m m' -> MapDisjoint B A m' m.
+  Proof.
+    unfold MapDisjoint in |- *. intros. exact (H _ H1 H0).
+  Qed.
+
+  Lemma MapDisjoint_empty :
+   forall m:Map A, MapDisjoint A A m m -> eqmap A m (M0 A).
+  Proof.
+    unfold eqmap, eqm in |- *. intros. rewrite <- (MapDomRestrTo_idempotent A m a).
+    exact (MapDisjoint_imp_2 A A m m H a).
+  Qed.
+
+  Lemma MapDelta_disjoint :
+   forall 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 :
+   forall (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 in |- *. 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 :
+   forall m m':Map A,
+     MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m').
+  Proof.
+    unfold MapDisjoint in |- *. 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 :
+   forall m m':Map A,
+     MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m).
+  Proof.
+    unfold MapDisjoint in |- *. 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 :
+   forall (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 in |- *. intros. exact (H1 _ (H _ H2) (H0 _ H3)).
+  Qed.
+
+  Lemma MapSubset_Disjoint_l :
+   forall (m:Map A) (m':Map B) (m'':Map C),
+     MapSubset _ _ m m' -> MapDisjoint _ _ m' m'' -> MapDisjoint _ _ m m''.
+  Proof.
+    unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ (H _ H1) H2).
+  Qed.
+
+  Lemma MapSubset_Disjoint_r :
+   forall (m:Map A) (m'':Map C) (m''':Map D),
+     MapSubset _ _ m'' m''' ->
+     MapDisjoint _ _ m m''' -> MapDisjoint _ _ m m''.
+  Proof.
+    unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ H1 (H _ H2)).
+  Qed.
+
+End MapDisjointExtra.
\ No newline at end of file
diff --git a/theories/IntMap/intro.tex b/theories/IntMap/intro.tex
new file mode 100644
index 00000000..9ad93050
--- /dev/null
+++ b/theories/IntMap/intro.tex
@@ -0,0 +1,6 @@
+\section{Maps indexed by binary integers : IntMap}\label{IntMap}
+
+This library contains a data structure for finite sets implemented by
+an efficient structure of map (trees indexed by binary integers).
+It was initially developed by Jean Goubault.
+
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
new file mode 100755
index 00000000..c3f65d67
--- /dev/null
+++ b/theories/Lists/List.v
@@ -0,0 +1,655 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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*)
+
+Require Import Le.
+
+
+Section Lists.
+
+Variable A : Set.
+
+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.
+
+(*************************)
+(** Discrimination       *)
+(*************************)
+
+Lemma nil_cons : forall (a:A) (m:list), nil <> a :: m.
+Proof. 
+  intros; discriminate.
+Qed.
+
+(*************************)
+(** Concatenation        *)
+(*************************)
+
+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.
+
+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.
+
+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 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.
+
+(*************************)
+(** Head and tail        *)
+(*************************)
+
+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                     *)
+(****************************************)
+
+Fixpoint length (l:list) : nat :=
+  match l with
+  | nil => 0
+  | _ :: m => S (length m)
+  end.
+
+(******************************)
+(** Length order of lists     *)
+(******************************)
+
+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.
+
+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
+  end.
+
+Lemma in_eq : forall (a:A) (l:list), In a (a :: l).
+Proof. 
+	simpl in |- *; auto.
+Qed.
+Hint Resolve in_eq.
+
+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.
+
+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.
+
+(********************************)
+(** Decidable equality on lists *)
+(********************************)
+
+
+Lemma list_eq_dec :
+ (forall x y:A, {x = y} + {x <> y}) -> forall x y:list, {x = y} + {x <> y}.
+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.
+Qed.
+
+(*************************)
+(**  Reverse             *)
+(*************************)
+
+Fixpoint rev (l:list) : list :=
+  match l with
+  | nil => nil
+  | x :: l' => rev l' ++ x :: nil
+  end.
+
+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.
+
+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.
+
+Lemma rev_involutive : forall l:list, 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.
+
+(*********************************************)
+(**  Reverse Induction Principle on Lists    *)
+(*********************************************)
+
+Section Reverse_Induction.
+
+Unset Implicit Arguments.
+
+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 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.
+
+Implicit Arguments nil [A].
+
+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.
+
+
+(** Exporting list notations *)
+
+Infix "::" := cons (at level 60, right associativity) : list_scope.
+
+Infix "++" := app (right associativity, at level 60) : list_scope.
+
+Open Scope list_scope.
+
+(** Declare Scope list_scope with key list *)
+Delimit Scope list_scope with list.
+
+Bind Scope list_scope with list.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
new file mode 100644
index 00000000..d5ecad9c
--- /dev/null
+++ b/theories/Lists/ListSet.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        *)
+(************************************************************************)
+
+(*i $Id: ListSet.v,v 1.13.2.1 2004/07/16 19:31:05 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 Import List.
+
+Set Implicit Arguments.
+
+Section first_definitions.
+
+  Variable A : Set.
+  Hypothesis Aeq_dec : forall x y:A, {x = y} + {x <> y}.
+
+  Definition set := list A.
+
+  Definition empty_set : set := nil.
+
+  Fixpoint set_add (a:A) (x:set) {struct x} : set :=
+    match x with
+    | nil => a :: nil
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | left _ => a1 :: x1
+        | right _ => a1 :: set_add a x1
+        end
+    end.
+
+
+  Fixpoint set_mem (a:A) (x:set) {struct x} : bool :=
+    match x with
+    | nil => false
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | 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) {struct x} : set :=
+    match x with
+    | nil => empty_set
+    | a1 :: x1 =>
+        match Aeq_dec a a1 with
+        | left _ => x1
+        | right _ => a1 :: set_remove a x1
+        end
+    end.
+
+  Fixpoint set_inter (x:set) : set -> set :=
+    match x with
+    | nil => fun y => nil
+    | a1 :: x1 =>
+        fun y =>
+          if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y
+    end.
+
+  Fixpoint set_union (x y:set) {struct y} : set :=
+    match y with
+    | nil => x
+    | 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 y:set) {struct x} : set :=
+    match x with
+    | nil => nil
+    | 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 (A:=A).
+
+  Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}.
+
+  Proof.
+    unfold set_In in |- *.
+    (*** Realizer set_mem. Program_all. ***)
+    simple induction x.
+    auto.
+    intros a0 x0 Ha0. case (Aeq_dec a a0); intro eq.
+    rewrite eq; simpl in |- *; auto with datatypes.
+    elim Ha0.
+    auto with datatypes.
+    right; simpl in |- *; unfold not in |- *; intros [Hc1| Hc2];
+     auto with datatypes.
+  Qed.
+
+  Lemma set_mem_ind :
+   forall (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.
+    simple induction x; simpl in |- *; intros.
+    assumption.
+    elim (Aeq_dec a a0); auto with datatypes.
+  Qed.
+
+  Lemma set_mem_ind2 :
+   forall (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.
+    simple induction x; simpl in |- *; intros.
+    apply H0; red in |- *; trivial.
+    case (Aeq_dec a a0); auto with datatypes.
+    intro; apply H; intros; auto.
+    apply H1; red in |- *; intro.
+    case H3; auto.
+  Qed.
+
+ 
+  Lemma set_mem_correct1 :
+   forall (a:A) (x:set), set_mem a x = true -> set_In a x.
+  Proof.
+    simple induction x; simpl in |- *.
+    discriminate.
+    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
+  Qed.
+
+  Lemma set_mem_correct2 :
+   forall (a:A) (x:set), set_In a x -> set_mem a x = true.
+  Proof.
+    simple induction x; simpl in |- *.
+    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 :
+   forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x.
+  Proof.
+    simple induction x; simpl in |- *.
+    tauto.
+    intros a0 l; elim (Aeq_dec a a0).
+    intros; discriminate H0.
+    unfold not in |- *; intros; elim H1; auto with datatypes.
+  Qed.
+
+  Lemma set_mem_complete2 :
+   forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false.
+  Proof.
+    simple induction x; simpl in |- *.
+    tauto.
+    intros a0 l; elim (Aeq_dec a a0).
+    intros; elim H0; auto with datatypes.
+    tauto.
+  Qed.
+
+  Lemma set_add_intro1 :
+   forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x).
+
+  Proof.
+    unfold set_In in |- *; simple induction x; simpl in |- *.
+    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 :
+   forall (a b:A) (x:set), a = b -> set_In a (set_add b x).
+
+  Proof.
+    unfold set_In in |- *; simple induction x; simpl in |- *.
+    auto with datatypes.
+    intros a0 l H Hab.
+    elim (Aeq_dec b a0);
+     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl in |- *;
+        auto with datatypes
+     | auto with datatypes ].
+  Qed.
+
+  Hint Resolve set_add_intro1 set_add_intro2.
+
+  Lemma set_add_intro :
+   forall (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 :
+   forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x.
+
+  Proof.
+    unfold set_In in |- *.
+    simple induction x.
+    simpl in |- *; intros [H1| H2]; auto with datatypes.
+    simpl in |- *; do 3 intro.
+    elim (Aeq_dec b a0).
+    simpl in |- *; tauto.
+    simpl in |- *; intros; elim H0.
+    trivial with datatypes.
+    tauto.
+    tauto.
+  Qed.
+
+  Lemma set_add_elim2 :
+   forall (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.
+
+  Hint Resolve set_add_intro set_add_elim set_add_elim2.
+
+  Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set.
+  Proof.
+    simple induction x; simpl in |- *.
+    discriminate.
+    intros; elim (Aeq_dec a a0); intros; discriminate.
+  Qed.   
+
+
+  Lemma set_union_intro1 :
+   forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
+  Proof.
+    simple induction y; simpl in |- *; auto with datatypes.
+  Qed.
+
+  Lemma set_union_intro2 :
+   forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y).
+  Proof.
+    simple induction y; simpl in |- *.
+    tauto.
+    intros; elim H0; auto with datatypes.
+  Qed.
+
+  Hint Resolve set_union_intro2 set_union_intro1.
+
+  Lemma set_union_intro :
+   forall (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 :
+   forall (a:A) (x y:set),
+     set_In a (set_union x y) -> set_In a x \/ set_In a y.
+  Proof.
+    simple induction y; simpl in |- *.
+    auto with datatypes.
+    intros.
+    generalize (set_add_elim _ _ _ H0).
+    intros [H1| H1].
+    auto with datatypes.
+    tauto.
+  Qed.
+
+  Lemma set_union_emptyL :
+   forall (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 || contradiction.
+  Qed.
+
+
+  Lemma set_union_emptyR :
+   forall (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 || contradiction.
+  Qed.
+
+
+  Lemma set_inter_intro :
+   forall (a:A) (x y:set),
+     set_In a x -> set_In a y -> set_In a (set_inter x y).
+  Proof.
+    simple induction x.
+    auto with datatypes.
+    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hy.
+    simpl in |- *; rewrite Ha0a.
+    generalize (set_mem_correct1 a y).
+    generalize (set_mem_complete1 a y).
+    elim (set_mem a y); simpl in |- *; 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 :
+   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a x.
+  Proof.
+    simple induction x.
+    auto with datatypes.
+    simpl in |- *; intros a0 l Hrec y.
+    generalize (set_mem_correct1 a0 y).
+    elim (set_mem a0 y); simpl in |- *; intros.
+    elim H0; eauto with datatypes.
+    eauto with datatypes.
+  Qed.
+
+  Lemma set_inter_elim2 :
+   forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y.
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; intros a0 l Hrec y.
+    generalize (set_mem_correct1 a0 y).
+    elim (set_mem a0 y); simpl in |- *; intros.
+    elim H0;
+     [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ].
+    eauto with datatypes.
+  Qed.
+
+  Hint Resolve set_inter_elim1 set_inter_elim2.
+
+  Lemma set_inter_elim :
+   forall (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 :
+   forall (a:A) (x y:set),
+     set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; 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 :
+   forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x.
+  Proof.
+    simple induction x.
+    simpl in |- *; tauto.
+    simpl in |- *; 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 :
+   forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y.
+  intros a x y; elim x; simpl in |- *.
+  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 : forall (a:A) (x:set), ~ set_In a (set_diff x x).
+  red in |- *; intros a x H.
+  apply (set_diff_elim2 _ _ _ H).
+  apply (set_diff_elim1 _ _ _ H).
+  Qed.
+
+Hint 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 (A:=A) (B:=B).
+
+  (** [B^A], set of applications from [A] to [B] *)
+  Definition set_power : set A -> set B -> set (set (A * B)) :=
+    list_power (A:=A) (B:=B).
+
+  Definition set_map : (A -> B) -> set A -> set B := map (A:=A) (B:=B).
+
+  Definition set_fold_left : (B -> A -> B) -> set A -> B -> B :=
+    fold_left (A:=B) (B:=A).
+
+  Definition set_fold_right (f:A -> B -> B) (x:set A) 
+    (b:B) : B := fold_right f b x.
+
+ 
+End other_definitions.
+
+Unset Implicit Arguments.
\ No newline at end of file
diff --git a/theories/Lists/MonoList.v b/theories/Lists/MonoList.v
new file mode 100755
index 00000000..d639a39d
--- /dev/null
+++ b/theories/Lists/MonoList.v
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+(** THIS IS A OLD CONTRIB. IT IS NO LONGER MAINTAINED ***)
+
+Require Import Le.
+
+Parameter List_Dom : Set.
+Definition A := List_Dom.
+
+Inductive list : Set :=
+  | nil : list
+  | cons : A -> list -> list.
+
+Fixpoint app (l m:list) {struct l} : list :=
+  match l return list with
+  | nil => m
+  | cons a l1 => cons a (app l1 m)
+  end.
+
+
+Lemma app_nil_end : forall l:list, l = app l nil.
+Proof. 
+	intro l; elim l; simpl in |- *; auto.
+        simple induction 1; auto.
+Qed.
+Hint Resolve app_nil_end: list v62.
+
+Lemma app_ass : forall l m n:list, app (app l m) n = app l (app m n).
+Proof. 
+	intros l m n; elim l; simpl in |- *; auto with list.
+	simple induction 1; auto with list.
+Qed.
+Hint Resolve app_ass: list v62.
+
+Lemma ass_app : forall l m n:list, app l (app m n) = app (app l m) n.
+Proof. 
+	auto with list.
+Qed.
+Hint Resolve ass_app: list v62.
+
+Definition tail (l:list) : list :=
+  match l return list with
+  | cons _ m => m
+  | _ => nil
+  end.
+                   
+
+Lemma nil_cons : forall (a:A) (m:list), nil <> cons a m.
+  intros; discriminate.
+Qed.
+
+(****************************************)
+(* Length of lists                      *)
+(****************************************)
+
+Fixpoint length (l:list) : nat :=
+  match l return nat with
+  | cons _ m => S (length m)
+  | _ => 0
+  end.
+
+(******************************)
+(* Length order of lists      *)
+(******************************)
+
+Section length_order.
+Definition lel (l m:list) := length l <= length m.
+
+Hint Unfold lel: list.
+
+Variables a b : A.
+Variables l m n : list.
+
+Lemma lel_refl : lel l l.
+Proof. 
+	unfold lel in |- *; auto with list.
+Qed.
+
+Lemma lel_trans : lel l m -> lel m n -> lel l n.
+Proof. 
+	unfold lel in |- *; 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 in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_cons : lel l m -> lel l (cons b m).
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_tail : lel (cons a l) (cons b m) -> lel l m.
+Proof. 
+	unfold lel in |- *; simpl in |- *; auto with list arith.
+Qed.
+
+Lemma lel_nil : forall 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 (S (length y) <= 0); auto with list arith.
+Qed.
+End length_order.
+
+Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: list
+  v62.
+
+Fixpoint In (a:A) (l:list) {struct l} : Prop :=
+  match l with
+  | nil => False
+  | cons b m => b = a \/ In a m
+  end.
+
+Lemma in_eq : forall (a:A) (l:list), In a (cons a l).
+Proof. 
+	simpl in |- *; auto with list.
+Qed.
+Hint Resolve in_eq: list v62.
+
+Lemma in_cons : forall (a b:A) (l:list), In b l -> In b (cons a l).
+Proof. 
+	simpl in |- *; auto with list.
+Qed.
+Hint Resolve in_cons: list v62.
+
+Lemma in_app_or : forall (l m:list) (a:A), In a (app l m) -> In a l \/ In a m.
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; 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.
+Hint Immediate in_app_or: list v62.
+
+Lemma in_or_app : forall (l m:list) (a:A), In a l \/ In a m -> In a (app l m).
+Proof. 
+	intros l m a.
+	elim l; simpl in |- *; 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.
+Hint Resolve in_or_app: list v62.
+
+Definition incl (l m:list) := forall a:A, In a l -> In a m.
+
+Hint Unfold incl: list v62.
+
+Lemma incl_refl : forall l:list, incl l l.
+Proof. 
+	auto with list.
+Qed.
+Hint Resolve incl_refl: list v62.
+
+Lemma incl_tl : forall (a:A) (l m:list), incl l m -> incl l (cons a m).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_tl: list v62.
+
+Lemma incl_tran : forall l m n:list, incl l m -> incl m n -> incl l n.
+Proof. 
+	auto with list.
+Qed.
+
+Lemma incl_appl : forall l m n:list, incl l n -> incl l (app n m).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_appl: list v62.
+
+Lemma incl_appr : forall l m n:list, incl l n -> incl l (app m n).
+Proof. 
+	auto with list.
+Qed.
+Hint Immediate incl_appr: list v62.
+
+Lemma incl_cons :
+ forall (a:A) (l m:list), In a m -> incl l m -> incl (cons a l) m.
+Proof. 
+	unfold incl in |- *; simpl in |- *; 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.
+Hint Resolve incl_cons: list v62.
+
+Lemma incl_app : forall l m n:list, incl l n -> incl m n -> incl (app l m) n.
+Proof. 
+	unfold incl in |- *; simpl in |- *; 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.
+Hint Resolve incl_app: list v62.
\ No newline at end of file
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
new file mode 100755
index 00000000..3c433ba2
--- /dev/null
+++ b/theories/Lists/Streams.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: Streams.v,v 1.15.2.1 2004/07/16 19:31:05 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+(** Streams *)
+
+Section Streams.
+
+Variable A : Set.
+
+CoInductive Stream : Set :=
+    Cons : A -> Stream -> Stream.
+
+
+Definition hd (x:Stream) := match x with
+                            | Cons a _ => a
+                            end.
+
+Definition tl (x:Stream) := match x with
+                            | Cons _ s => s
+                            end.
+
+
+Fixpoint Str_nth_tl (n:nat) (s:Stream) {struct n} : Stream :=
+  match n with
+  | O => s
+  | S m => Str_nth_tl m (tl s)
+  end.
+
+Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s).
+
+
+Lemma unfold_Stream :
+ forall x:Stream, x = match x with
+                      | Cons a s => Cons a s
+                      end. 
+Proof.
+  intro x.
+  case x.
+  trivial.
+Qed.
+
+Lemma tl_nth_tl :
+ forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s).
+Proof.
+  simple induction n; simpl in |- *; auto.
+Qed.
+Hint Resolve tl_nth_tl: datatypes v62.
+
+Lemma Str_nth_tl_plus :
+ forall (n m:nat) (s:Stream),
+   Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s.
+simple induction n; simpl in |- *; intros; auto with datatypes.
+rewrite <- H.
+rewrite tl_nth_tl; trivial with datatypes.
+Qed.
+
+Lemma Str_nth_plus :
+ forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s.
+intros; unfold Str_nth in |- *; rewrite Str_nth_tl_plus;
+ trivial with datatypes.
+Qed.
+
+(** Extensional Equality between two streams  *)
+
+CoInductive EqSt : Stream -> Stream -> Prop :=
+    eqst :
+      forall s1 s2:Stream,
+        hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2.
+
+(** A coinduction principle *)
+
+Ltac coinduction proof :=
+  cofix proof; intros; constructor;
+   [ clear proof | try (apply proof; clear proof) ].
+
+
+(** Extensional equality is an equivalence relation *)
+
+Theorem EqSt_reflex : forall s:Stream, EqSt s s.
+coinduction EqSt_reflex.
+reflexivity.
+Qed.
+
+Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1.
+coinduction Eq_sym.
+case H; intros; symmetry  in |- *; assumption.
+case H; intros; assumption.
+Qed.
+
+
+Theorem trans_EqSt :
+ forall 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 :
+ forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2.
+unfold Str_nth in |- *; simple induction n.
+intros s1 s2 H; case H; trivial with datatypes.
+intros m hypind.
+simpl in |- *.
+intros s1 s2 H.
+apply hypind.
+case H; trivial with datatypes.
+Qed.
+
+Theorem ntheq_eqst :
+ forall s1 s2:Stream,
+   (forall n:nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2.
+coinduction Equiv2.
+apply (H 0).
+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 : forall x:Stream, P x -> Exists x
+  | Further : forall x:Stream, Exists (tl x) -> Exists x.
+
+CoInductive ForAll : Stream -> Prop :=
+    HereAndFurther : forall x:Stream, P x -> ForAll (tl x) -> ForAll x.
+
+
+Section Co_Induction_ForAll.
+Variable Inv : Stream -> Prop.
+Hypothesis InvThenP : forall x:Stream, Inv x -> P x.
+Hypothesis InvIsStable : forall x:Stream, Inv x -> Inv (tl x).
+
+Theorem ForAll_coind : forall 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 (s:Stream A) : Stream B := 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.
\ No newline at end of file
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
new file mode 100755
index 00000000..fbeb97ce
--- /dev/null
+++ b/theories/Lists/TheoryList.v
@@ -0,0 +1,403 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.15.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Some programs and results about lists following CAML Manual *)
+
+Require Export List.
+Set Implicit Arguments.
+Section Lists.
+
+Variable A : Set.
+
+(**********************)
+(** The null function *)
+(**********************)
+
+Definition Isnil (l:list A) : Prop := nil = l.
+
+Lemma Isnil_nil : Isnil nil.
+red in |- *; auto.
+Qed.
+Hint Resolve Isnil_nil.
+
+Lemma not_Isnil_cons : forall (a:A) (l:list A), ~ Isnil (a :: l).
+unfold Isnil in |- *.
+intros; discriminate.
+Qed.
+
+Hint Resolve Isnil_nil not_Isnil_cons.
+
+Lemma Isnil_dec : forall 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 :
+ forall l:list A, {a : A &  {m : list A | 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 :
+ forall l:list A, {a : A |  exists m : list A, 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 :
+ forall l:list A,
+   {m : list A | (exists a : A, a :: m = l) \/ Isnil l /\ Isnil m}.
+intro l; case l.
+exists (nil (A:=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) (n:nat) {struct l} : nat :=
+  match l with
+  | nil => n
+  | _ :: m => Length_l m (S n)
+  end.
+
+(* A tail recursive version *)
+Lemma Length_l_pf : forall (l:list A) (n:nat), {m : nat | n + length l = m}.
+induction l as [| a m lrec].
+intro n; exists n; simpl in |- *; auto.
+intro n; elim (lrec (S n)); simpl in |- *; intros.
+exists x; transitivity (S (n + length m)); auto.
+(*
+Realizer Length_l.
+*)
+Qed.
+
+Lemma Length : forall l:list A, {m : nat | length l = m}.
+intro l. apply (Length_l_pf l 0).
+(*
+Realizer (fun l -> Length_l_pf l O).
+*)
+Qed.
+
+(*******************************)
+(** Members of lists           *)
+(*******************************)
+Inductive In_spec (a:A) : list A -> Prop :=
+  | in_hd : forall l:list A, In_spec a (a :: l)
+  | in_tl : forall (l:list A) (b:A), In a l -> In_spec a (b :: l).
+Hint Resolve in_hd in_tl.
+Hint Unfold In.
+Hint Resolve in_cons.
+
+Theorem In_In_spec : forall (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
+  | allS_cons : forall (a:A) (l:list A), P a -> AllS P l -> AllS P (a :: l).
+Hint Resolve allS_nil allS_cons.
+
+Hypothesis eqA_dec : forall a b:A, {a = b} + {a <> b}.
+
+Fixpoint mem (a:A) (l:list A) {struct l} : bool :=
+  match l with
+  | nil => false
+  | b :: m => if eqA_dec a b then true else mem a m
+  end.
+
+Hint Unfold In.
+Lemma Mem : forall (a:A) (l:list A), {In a l} + {AllS (fun b:A => b <> a) l}.
+intros a l.
+induction l.
+auto.
+elim (eqA_dec a a0).
+auto.
+simpl in |- *. elim IHl; auto.
+(*
+Realizer mem.
+*)
+Qed.
+
+(*********************************)
+(** Index of elements            *)
+(*********************************)
+
+Require Import Le.
+Require Import Lt.
+
+Inductive nth_spec : list A -> nat -> A -> Prop :=
+  | nth_spec_O : forall (a:A) (l:list A), nth_spec (a :: l) 1 a
+  | nth_spec_S :
+      forall (n:nat) (a b:A) (l:list A),
+        nth_spec l n a -> nth_spec (b :: l) (S n) a.
+Hint Resolve nth_spec_O nth_spec_S.
+
+Inductive fst_nth_spec : list A -> nat -> A -> Prop :=
+  | fst_nth_O : forall (a:A) (l:list A), fst_nth_spec (a :: l) 1 a
+  | fst_nth_S :
+      forall (n:nat) (a b:A) (l:list A),
+        a <> b -> fst_nth_spec l n a -> fst_nth_spec (b :: l) (S n) a.
+Hint Resolve fst_nth_O fst_nth_S.
+
+Lemma fst_nth_nth :
+ forall (l:list A) (n:nat) (a:A), fst_nth_spec l n a -> nth_spec l n a.
+induction 1; auto.
+Qed.
+Hint Immediate fst_nth_nth.
+
+Lemma nth_lt_O : forall (l:list A) (n:nat) (a:A), nth_spec l n a -> 0 < n.
+induction 1; auto.
+Qed.
+
+Lemma nth_le_length :
+ forall (l:list A) (n:nat) (a:A), nth_spec l n a -> n <= length l.
+induction 1; simpl in |- *; auto with arith.
+Qed.
+
+Fixpoint Nth_func (l:list A) (n:nat) {struct l} : Exc A :=
+  match l, n with
+  | a :: _, S O => value a
+  | _ :: l', S (S p) => Nth_func l' (S p)
+  | _, _ => error
+  end.
+
+Lemma Nth :
+ forall (l:list A) (n:nat),
+   {a : A | nth_spec l n a} + {n = 0 \/ length l < n}.
+induction l as [| a l IHl].
+intro n; case n; simpl in |- *; auto with arith.
+intro n; destruct n as [| [| n1]]; simpl in |- *; auto.
+left; exists a; auto.
+destruct (IHl (S n1)) as [[b]| o].
+left; exists b; auto.
+right; destruct o.
+absurd (S n1 = 0); auto.
+auto with arith.
+(*
+Realizer Nth_func.
+*)
+Qed.
+
+Lemma Item :
+ forall (l:list A) (n:nat), {a : A | nth_spec l (S n) a} + {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 = 0); auto.
+auto with arith.
+Qed.
+
+Require Import Minus.
+Require Import DecBool.
+
+Fixpoint index_p (a:A) (l:list A) {struct l} : nat -> Exc nat :=
+  match l with
+  | nil => fun p => error
+  | b :: m => fun p => ifdec (eqA_dec a b) (value p) (index_p a m (S p))
+  end.
+
+Lemma Index_p :
+ forall (a:A) (l:list A) (p:nat),
+   {n : nat | fst_nth_spec l (S n - p) a} + {AllS (fun b:A => a <> b) l}.
+induction l as [| b m irec].
+auto.
+intro p.
+destruct (eqA_dec a b) as [e| e].
+left; exists p.
+destruct e; elim minus_Sn_m; trivial; elim minus_n_n; auto with arith.
+destruct (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 :
+ forall (a:A) (l:list A),
+   {n : nat | fst_nth_spec l n a} + {AllS (fun b:A => a <> b) l}.
+
+intros a l; case (Index_p a l 1); 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.
+Variables R P : A -> Prop.
+
+Inductive InR : list A -> Prop :=
+  | inR_hd : forall (a:A) (l:list A), R a -> InR (a :: l)
+  | inR_tl : forall (a:A) (l:list A), InR l -> InR (a :: l).
+Hint Resolve inR_hd inR_tl.
+
+Definition InR_inv (l:list A) :=
+  match l with
+  | nil => False
+  | b :: m => R b \/ InR m
+  end.
+
+Lemma InR_INV : forall l:list A, InR l -> InR_inv l.
+induction 1; simpl in |- *; auto.
+Qed.
+
+Lemma InR_cons_inv : forall (a:A) (l:list A), InR (a :: l) -> R a \/ InR l.
+intros a l H; exact (InR_INV H).
+Qed.
+
+Lemma InR_or_app : forall l m:list A, InR l \/ InR m -> InR (l ++ m).
+intros l m [| ].
+induction 1; simpl in |- *; auto.
+intro. induction l; simpl in |- *; auto.
+Qed.
+
+Lemma InR_app_or : forall l m:list A, InR (l ++ m) -> InR l \/ InR m.
+intros l m; elim l; simpl in |- *; auto.
+intros b l' Hrec IAc; elim (InR_cons_inv IAc); auto.
+intros; elim Hrec; auto.
+Qed.
+
+Hypothesis RS_dec : forall a:A, {R a} + {P a}.
+
+Fixpoint find (l:list A) : Exc A :=
+  match l with
+  | nil => error
+  | a :: m => ifdec (RS_dec a) (value a) (find m)
+  end.
+
+Lemma Find : forall l:list A, {a : A | In a l &  R a} + {AllS P l}.
+induction l as [| a m [[b H1 H2]| H]]; auto.
+left; exists b; auto.
+destruct (RS_dec a).
+left; exists a; auto.
+auto.
+(*
+Realizer find.
+*)
+Qed.
+
+Variable B : Set.
+Variable T : A -> B -> Prop.
+
+Variable TS_dec : forall a:A, {c : B | T a c} + {P a}.
+
+Fixpoint try_find (l:list A) : Exc B :=
+  match l with
+  | nil => error
+  | a :: l1 =>
+      match TS_dec a with
+      | inleft (exist c _) => value c
+      | inright _ => try_find l1
+      end
+  end.
+
+Lemma Try_find :
+ forall l:list A, {c : B |  exists2 a : A, In a l & T a c} + {AllS P l}.
+induction l as [| a m [[b H1]| H]].
+auto.
+left; exists b; destruct H1 as [a' H2 H3]; exists a'; auto.
+destruct (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)) {struct l} : 
+ Exc B :=
+  match l with
+  | nil => error
+  | (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
+  | allS_assoc_cons :
+      forall (a:A) (b:B) (l:list (A * B)),
+        P a -> AllS_assoc P l -> AllS_assoc P ((a, b) :: l).
+
+Hint 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 :
+ forall (a:A) (l:list (A * B)), B + {AllS_assoc (fun a':A => a <> a') l}.
+induction l as [| [a' b] m assrec]. auto.
+destruct (eqA_dec a a').
+left; exact b.
+destruct assrec as [b'| ].
+left; exact b'.
+right; auto.
+(*
+Realizer assoc.
+*)
+Qed.
+
+End Assoc_sec.
+
+End Lists.
+
+Hint Resolve Isnil_nil not_Isnil_cons in_hd in_tl in_cons allS_nil allS_cons:
+  datatypes.
+Hint Immediate fst_nth_nth: datatypes.
diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex
new file mode 100755
index 00000000..344bba59
--- /dev/null
+++ b/theories/Lists/intro.tex
@@ -0,0 +1,24 @@
+\section{Lists}\label{Lists}
+
+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, 
+  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
+  arguments before using it.
+
+\item {\tt TheoryList.v} contains complementary results on lists. Here
+  a more theoric 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.
+
+\end{itemize}
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
new file mode 100644
index 00000000..7e950c17
--- /dev/null
+++ b/theories/Logic/Berardi.v
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:06 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 : forall P:Prop, P \/ ~ P.
+
+(** Conditional on any proposition. *)
+Definition IFProp (P B:Prop) (e1 e2:P) :=
+  match EM B with
+  | or_introl _ => e1
+  | or_intror _ => e2
+  end.
+
+(** Axiom of choice applied to disjunction.
+    Provable in Coq because of dependent elimination. *)
+Lemma AC_IF :
+ forall (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 in |- *.
+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.
+
+Variables A B : Prop.
+
+Record retract : Prop := 
+  {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
+
+Record retract_cond : Prop := 
+  {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.
+
+
+(** The dependent elimination above implies the axiom of choice: *)
+Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
+Proof.
+intros r.
+case r; simpl in |- *.
+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 : 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.
+Qed.
+
+
+(** The paradoxical set *)
+Definition U := forall P:Prop, pow P.
+
+(** Bijection between [U] and [(pow U)] *)
+Definition f (u:U) : pow U := u U.
+
+Definition g (h:pow U) : U :=
+  fun 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 in |- *; simpl in |- *.
+apply AC.
+exists (fun x:pow U => x) (fun 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 (fun u:U => Not_b (u U u)).
+
+
+Lemma not_has_fixpoint : R R = Not_b (R R).
+Proof.
+unfold R at 1 in |- *.
+unfold g in |- *.
+rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
+trivial.
+exists (fun x:pow U => x) (fun x:pow U => x); trivial.
+Qed.
+
+
+Theorem classical_proof_irrelevence : T = F.
+Proof.
+generalize not_has_fixpoint.
+unfold Not_b in |- *.
+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.
\ No newline at end of file
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
new file mode 100644
index 00000000..a1f4417c
--- /dev/null
+++ b/theories/Logic/ChoiceFacts.v
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:06 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 :=
+  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)).
+
+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 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.
+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 :=
+  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.
+
+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'.
+  intros x HPx.
+    destruct (H0 x) as [y [H1 H2]].
+    exists y. split. 
+      apply (H1 HPx).
+      exact H2.
+Qed.
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
new file mode 100755
index 00000000..044cee17
--- /dev/null
+++ b/theories/Logic/Classical.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical.v,v 1.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Logic *)
+
+Require Export Classical_Prop.
+Require Export Classical_Pred_Type.
\ No newline at end of file
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
new file mode 100644
index 00000000..51f758e2
--- /dev/null
+++ b/theories/Logic/ClassicalChoice.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ClassicalChoice.v,v 1.4.2.1 2004/07/16 19:31:06 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 Import ChoiceFacts.
+
+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.
+apply description_rel_choice_imp_funct_choice.
+exact description.
+exact relational_choice.
+Qed.
\ No newline at end of file
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
new file mode 100644
index 00000000..6602cd73
--- /dev/null
+++ b/theories/Logic/ClassicalDescription.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        *)
+(************************************************************************)
+
+(*i $Id: ClassicalDescription.v,v 1.7.2.1 2004/07/16 19:31:06 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 :
+    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)).
+
+(** Principle of definite descriptions (aka axiom of unique choice) *)
+
+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)).
+Proof.
+intros A B.
+apply (dependent_description A (fun _ => B)).
+Qed.
+
+(** The followig proof comes from [1] *)
+
+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 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.
+Qed.
+ 
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
new file mode 100644
index 00000000..cb14fb0e
--- /dev/null
+++ b/theories/Logic/ClassicalFacts.v
@@ -0,0 +1,219 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:06 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 := forall A:Prop, A = True \/ A = False.
+
+(** [prop_extensionality] asserts 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 *)
+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.
+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).
+Qed.
+
+Lemma prop_ext_em_degen :
+ 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 ].
+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 -> 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) ].
+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).
+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.
+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.
+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.
+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 : 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.
+
+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 := 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.
+
+(** 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 := 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.
+
+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/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
new file mode 100755
index 00000000..c8f87fe8
--- /dev/null
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Predicate Logic on Set*)
+
+Require Import Classical_Prop.
+
+Section Generic.
+Variable U : Set.
+
+(** de Morgan laws for quantifiers *)
+
+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.
+
+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.
+
+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. 
+
+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.
+
+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.
+
+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.
+
+End Generic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
new file mode 100755
index 00000000..804ff32d
--- /dev/null
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Predicate Logic on Type *)
+
+Require Import Classical_Prop.
+
+Section Generic.
+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.
+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.
+
+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.
+
+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. 
+
+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.
+
+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.
+
+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.
+
+End Generic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
new file mode 100755
index 00000000..ccc26df1
--- /dev/null
+++ b/theories/Logic/Classical_Prop.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Propositional Logic *)
+
+Require Import ProofIrrelevance.
+
+Hint Unfold not: core.
+
+Axiom classic : forall P:Prop, P \/ ~ P.
+
+Lemma NNPP : forall p:Prop, ~ ~ p -> p.
+Proof.
+unfold not in |- *; intros; elim (classic p); auto.
+intro NP; elim (H NP).
+Qed.
+
+Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
+Proof.
+intros; apply NNPP; red in |- *.
+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.
+Qed.
+
+Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q.
+Proof.
+intros; elim (classic P); auto.
+Qed.
+
+Lemma imply_to_and : forall 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 : forall P Q:Prop, ~ P \/ Q -> P -> Q.
+Proof.
+simple induction 1; auto.
+intros H1 H2; elim (H1 H2).
+Qed.
+
+Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
+Proof.
+intros; elim (classic P); auto.
+Qed.
+
+Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
+Proof.
+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.
+Qed.
+
+Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q).
+Proof.
+simple induction 1; red in |- *; simple induction 3; trivial.
+Qed.
+
+Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q.
+Proof.
+simple induction 2; trivial.
+Qed.
+
+Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R.
+Proof.
+simple induction 2; auto.
+Qed.
+
+Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
+Proof proof_irrelevance_cci classic.
\ No newline at end of file
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
new file mode 100755
index 00000000..753b8590
--- /dev/null
+++ b/theories/Logic/Classical_Type.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical_Type.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** Classical Logic for Type *)
+
+Require Export Classical_Prop.
+Require Export Classical_Pred_Type.
\ No newline at end of file
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
new file mode 100644
index 00000000..08babda9
--- /dev/null
+++ b/theories/Logic/Decidable.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        *)
+(************************************************************************)
+(*i 	$Id: Decidable.v,v 1.5.2.1 2004/07/16 19:31:06 herbelin Exp $	 i*)
+
+(** Properties of decidable propositions *)
+
+Definition decidable (P:Prop) := P \/ ~ P.
+
+Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_True : decidable True.
+unfold decidable in |- *; auto.
+Qed.
+
+Theorem dec_False : decidable False.
+unfold decidable, not in |- *; auto.
+Qed.
+
+Theorem dec_or :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_and :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem dec_imp :
+ forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
+unfold decidable in |- *; tauto. 
+Qed.
+
+Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P.
+unfold decidable in |- *; tauto. Qed.
+
+Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B.
+tauto. Qed.
+
+Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B.
+unfold decidable in |- *; tauto. Qed.
+
+Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B.
+unfold decidable in |- *; tauto.
+Qed.
+
+Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B.
+unfold decidable in |- *; tauto.
+Qed.
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
new file mode 100644
index 00000000..55eed096
--- /dev/null
+++ b/theories/Logic/Diaconescu.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:06 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 :=
+  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.
+
+(* From predicate extensionality we get propositional extensionality
+   hence proof-irrelevance *)
+
+Require Import ClassicalFacts.
+
+Variable pred_extensionality : PredicateExtensionality.
+  
+Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
+Proof.
+  intros A B H.
+  change ((fun _ => A) true = (fun _ => B) true) in |- *.
+  rewrite
+   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
+    reflexivity.
+    intros _; exact H.
+Qed.
+
+Lemma proof_irrel : forall (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 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')).
+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 Import Bool.
+
+Lemma AC :
+  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).
+Qed.
+
+(* The proof of the excluded middle *)
+(* Remark: P could have been in Set or Type *)
+
+Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
+Proof.
+intro P.
+
+(* first we exhibit the choice functional relation R *)
+destruct AC as [R H].
+
+set (class_of_true := fun b => b = true \/ P).
+set (class_of_false := fun b => b = false \/ P).
+
+(* the actual "decision": is (R class_of_true) = true or false? *)
+destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
+exists true; left; reflexivity.
+destruct H0.
+
+(* the actual "decision": is (R class_of_false) = true or false? *)
+destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
+exists false; left; reflexivity.
+destruct H1.
+
+(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
+right.
+intro HP.
+assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
+intro b; split.
+unfold class_of_false in |- *; right; assumption.
+unfold class_of_true in |- *; 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/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
new file mode 100755
index 00000000..24905039
--- /dev/null
+++ b/theories/Logic/Eqdep.v
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Eqdep.v,v 1.10.2.1 2004/07/16 19:31:06 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) : 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.
+
+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 *)
+
+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.
+
+(** UIP implies the injectivity of equality on dependent pairs *)
+
+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.
+
+(** The main results to be exported *)
+
+Hint Resolve eq_dep_intro eq_dep_eq: core v62.
+Hint Immediate eq_dep_sym: core v62.
+Hint Resolve inj_pair2 inj_pairT2: core.
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
new file mode 100644
index 00000000..7caf403c
--- /dev/null
+++ b/theories/Logic/Eqdep_dec.v
@@ -0,0 +1,158 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:06 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) (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.
+
+  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.
+
+
+Section DecidableEqDep.
+
+  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.
+
+
+
+  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)
+    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.
+
+
+  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.
+
+
+  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.
+
+
+  (** The corollary *)
+
+  Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
+    match exP with
+    | ex_intro x' prf =>
+        match eq_dec x' x with
+        | 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.
+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
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
new file mode 100644
index 00000000..46a57432
--- /dev/null
+++ b/theories/Logic/Hurkens.v
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 : forall A:Prop, b2p (p2b A) -> A.
+Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A).
+Variable B : Prop.
+
+Definition V := forall A:Prop, ((A -> bool) -> A -> bool) -> A -> bool.
+Definition U := V -> bool.
+Definition sb (z:V) : V := fun A r a => r (z A r) a.
+Definition le (i:U -> bool) (x:U) : bool :=
+  x (fun A r a => i (fun v => sb v A r a)).
+Definition induct (i:U -> bool) : Prop :=
+  forall x:U, b2p (le i x) -> b2p (i x).
+Definition WF : U := fun z => p2b (induct (z U le)).
+Definition I (x:U) : Prop :=
+  (forall i:U -> bool, b2p (le i x) -> b2p (i (fun v => sb v U le x))) -> B.
+
+Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF).
+Proof.
+intros i y.
+apply y.
+unfold le, WF, induct in |- *.
+apply p2p2.
+intros x H0.
+apply y.
+exact H0.
+Qed.
+
+Lemma lemma1 : induct (fun u => p2b (I u)).
+Proof.
+unfold induct in |- *.
+intros x p.
+apply (p2p2 (I x)).
+intro q.
+apply (p2p1 (I (fun v:V => sb v U le x)) (q (fun u => p2b (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 -> bool, induct i -> b2p (i WF)) -> B.
+Proof.
+intro x.
+apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma1)).
+intros i H0.
+apply (x (fun y => i (fun v => sb v U le y))).
+apply (p2p1 _ H0).
+Qed.
+
+Theorem paradox : B.
+Proof.
+exact (lemma2 Omega).
+Qed.
+
+End Paradox.
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
new file mode 100644
index 00000000..5b7528be
--- /dev/null
+++ b/theories/Logic/JMeq.v
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:06 herbelin Exp $ i*)
+
+(** John Major's Equality as proposed by C. Mc Bride *)
+
+Set Implicit Arguments.
+
+Inductive JMeq (A:Set) (x:A) : forall B:Set, B -> Prop :=
+    JMeq_refl : JMeq x x.
+Reset JMeq_ind.
+
+Hint Resolve JMeq_refl.
+
+Lemma sym_JMeq : forall (A B:Set) (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.
+destruct 1; trivial.
+Qed.
+
+Axiom JMeq_eq : forall (A:Set) (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.
+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.
+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.
+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.
+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 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.
+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.
+Proof.
+destruct 1.
+apply JMeq_refl. 
+Qed.
\ No newline at end of file
diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v
new file mode 100644
index 00000000..afdc0ffe
--- /dev/null
+++ b/theories/Logic/ProofIrrelevance.v
@@ -0,0 +1,114 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 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
+*)
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
new file mode 100644
index 00000000..ca7b760e
--- /dev/null
+++ b/theories/Logic/RelationalChoice.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: RelationalChoice.v,v 1.3.2.1 2004/07/16 19:31:06 herbelin Exp $ 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')).
diff --git a/theories/Logic/intro.tex b/theories/Logic/intro.tex
new file mode 100755
index 00000000..1fb294f2
--- /dev/null
+++ b/theories/Logic/intro.tex
@@ -0,0 +1,8 @@
+\section{Logic}\label{Logic}
+
+This library deals with classical logic and its properties.
+The main file is {\tt Classical.v}.
+
+This library also provides some facts on equalities for dependent
+types. See the files {\tt Eqdep.v} and {\tt JMeq.v}.
+
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
new file mode 100644
index 00000000..e6a14938
--- /dev/null
+++ b/theories/NArith/BinNat.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+
+Require Import BinPos.
+
+(**********************************************************************)
+(** Binary natural numbers *)
+
+Inductive N : Set :=
+  | N0 : N
+  | Npos : positive -> N.
+
+(** Declare binding key for scope positive_scope *)
+
+Delimit Scope N_scope with N.
+
+(** Automatically open scope N_scope for the constructors of N *)
+
+Bind Scope N_scope with N.
+Arguments Scope Npos [N_scope].
+
+Open Local Scope N_scope.
+
+(** Operation x -> 2*x+1 *)
+
+Definition Ndouble_plus_one x :=
+  match x with
+  | N0 => Npos 1%positive
+  | Npos p => Npos (xI p)
+  end.
+
+(** Operation x -> 2*x *)
+
+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
+  | Npos p => Npos (Psucc p)
+  end.
+
+(** Addition *)
+
+Definition Nplus n m :=
+  match n, m with
+  | N0, _ => m
+  | _, N0 => n
+  | Npos p, Npos q => Npos (p + q)%positive
+  end.
+
+Infix "+" := Nplus : N_scope.
+
+(** Multiplication *)
+
+Definition Nmult n m :=
+  match n, m with
+  | N0, _ => N0
+  | _, N0 => N0
+  | Npos p, Npos q => Npos (p * q)%positive
+  end.
+
+Infix "*" := Nmult : N_scope.
+
+(** Order *)
+
+Definition Ncompare n m :=
+  match n, m with
+  | N0, N0 => Eq
+  | N0, Npos m' => Lt
+  | Npos n', N0 => Gt
+  | Npos n', Npos m' => (n' ?= m')%positive Eq
+  end.
+
+Infix "?=" := Ncompare (at level 70, no associativity) : N_scope.
+
+(** Peano induction on binary natural numbers *)
+
+Theorem Nind :
+ forall P:N -> Prop,
+   P N0 -> (forall n:N, P n -> P (Nsucc n)) -> forall n:N, P n.
+Proof.
+destruct n.
+  assumption.
+  apply Pind with (P := fun p => P (Npos p)).
+exact (H0 N0 H).
+intro p'; exact (H0 (Npos p')).
+Qed.
+
+(** Properties of addition *)
+
+Theorem Nplus_0_l : forall n:N, N0 + n = n.
+Proof.
+reflexivity.
+Qed.
+
+Theorem Nplus_0_r : forall n:N, n + N0 = n.
+Proof.
+destruct n; reflexivity.
+Qed.
+
+Theorem Nplus_comm : forall n m:N, n + m = m + n.
+Proof.
+intros.
+destruct n; destruct m; simpl in |- *; try reflexivity.
+rewrite Pplus_comm; reflexivity.
+Qed.
+
+Theorem Nplus_assoc : forall n m p:N, n + (m + p) = n + m + p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; try reflexivity.
+destruct p; try reflexivity.
+simpl in |- *; rewrite Pplus_assoc; reflexivity.
+Qed.
+
+Theorem Nplus_succ : forall n m:N, Nsucc n + m = Nsucc (n + m).
+Proof.
+destruct n; destruct m.
+  simpl in |- *; reflexivity.
+  unfold Nsucc, Nplus in |- *; rewrite <- Pplus_one_succ_l; reflexivity.
+  simpl in |- *; reflexivity.
+  simpl in |- *; rewrite Pplus_succ_permute_l; reflexivity.
+Qed.
+
+Theorem Nsucc_inj : forall n m:N, Nsucc n = Nsucc m -> n = m.
+Proof.
+destruct n; destruct m; simpl in |- *; intro H; reflexivity || injection H;
+ clear H; intro H.
+  symmetry  in H; contradiction Psucc_not_one with p.
+  contradiction Psucc_not_one with p.
+  rewrite Psucc_inj with (1 := H); reflexivity.
+Qed.
+
+Theorem Nplus_reg_l : forall n m p:N, n + m = n + p -> m = p.
+Proof.
+intro n; pattern n in |- *; apply Nind; clear n; simpl in |- *.
+  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 : forall n:N, Npos 1%positive * n = n.
+Proof.
+destruct n; reflexivity.
+Qed.
+
+Theorem Nmult_1_r : forall n:N, n * Npos 1%positive = n.
+Proof.
+destruct n; simpl in |- *; try reflexivity.
+rewrite Pmult_1_r; reflexivity.
+Qed.
+
+Theorem Nmult_comm : forall n m:N, n * m = m * n.
+Proof.
+intros.
+destruct n; destruct m; simpl in |- *; try reflexivity.
+rewrite Pmult_comm; reflexivity.
+Qed.
+
+Theorem Nmult_assoc : forall n m p:N, n * (m * p) = n * m * p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; try reflexivity.
+destruct p; try reflexivity.
+simpl in |- *; rewrite Pmult_assoc; reflexivity.
+Qed.
+
+Theorem Nmult_plus_distr_r : forall n m p:N, (n + m) * p = n * p + m * p.
+Proof.
+intros.
+destruct n; try reflexivity.
+destruct m; destruct p; try reflexivity.
+simpl in |- *; rewrite Pmult_plus_distr_r; reflexivity.
+Qed.
+
+Theorem Nmult_reg_r : forall n m p:N, p <> N0 -> n * p = m * p -> n = m.
+Proof.
+destruct p; intros Hp H.
+contradiction Hp; reflexivity.
+destruct n; destruct m; reflexivity || (try discriminate H).
+injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity.
+Qed. 
+
+Theorem Nmult_0_l : forall n:N, N0 * n = N0.
+Proof.
+reflexivity.
+Qed.
+
+(** Properties of comparison *)
+
+Theorem Ncompare_Eq_eq : forall n m:N, (n ?= m) = Eq -> n = m.
+Proof.
+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.
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
new file mode 100644
index 00000000..fffb10c1
--- /dev/null
+++ b/theories/NArith/BinPos.v
@@ -0,0 +1,961 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:07 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 *)
+
+Delimit 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 Psucc (x:positive) : positive :=
+  match x with
+  | xI x' => xO (Psucc x')
+  | xO x' => xI x'
+  | xH => xO xH
+  end.
+
+(** Addition *)
+
+Fixpoint Pplus (x y:positive) {struct x} : positive :=
+  match x, y with
+  | xI x', xI y' => xO (Pplus_carry x' y')
+  | xI x', xO y' => xI (Pplus x' y')
+  | xI x', xH => xO (Psucc x')
+  | xO x', xI y' => xI (Pplus x' y')
+  | xO x', xO y' => xO (Pplus x' y')
+  | xO x', xH => xI x'
+  | xH, xI y' => xO (Psucc y')
+  | xH, xO y' => xI y'
+  | xH, xH => xO xH
+  end
+ 
+ with Pplus_carry (x y:positive) {struct x} : positive :=
+  match x, y with
+  | xI x', xI y' => xI (Pplus_carry x' y')
+  | xI x', xO y' => xO (Pplus_carry x' y')
+  | xI x', xH => xI (Psucc x')
+  | xO x', xI y' => xO (Pplus_carry x' y')
+  | xO x', xO y' => xI (Pplus x' y')
+  | xO x', xH => xO (Psucc x')
+  | xH, xI y' => xI (Psucc y')
+  | xH, xO y' => xO (Psucc y')
+  | xH, xH => xI xH
+  end.
+
+Infix "+" := Pplus : positive_scope.
+
+Open Local Scope positive_scope.
+
+(** From binary positive numbers to Peano natural numbers *)
+
+Fixpoint Pmult_nat (x:positive) (pow2:nat) {struct x} : nat :=
+  match x with
+  | xI x' => (pow2 + Pmult_nat x' (pow2 + pow2))%nat
+  | xO x' => Pmult_nat x' (pow2 + pow2)%nat
+  | xH => pow2
+  end.
+
+Definition nat_of_P (x:positive) := Pmult_nat x 1.
+
+(** From Peano natural numbers to binary positive numbers *)
+
+Fixpoint P_of_succ_nat (n:nat) : positive :=
+  match n with
+  | O => xH
+  | S x' => Psucc (P_of_succ_nat x')
+  end.
+
+(** Operation x -> 2*x-1 *)
+
+Fixpoint Pdouble_minus_one (x:positive) : positive :=
+  match x with
+  | xI x' => xI (xO x')
+  | xO x' => xI (Pdouble_minus_one x')
+  | xH => xH
+  end.
+
+(** Predecessor *)
+
+Definition Ppred (x:positive) :=
+  match x with
+  | xI x' => xO x'
+  | xO x' => Pdouble_minus_one 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 Pdouble_plus_one_mask (x:positive_mask) :=
+  match x with
+  | IsNul => IsPos xH
+  | IsNeg => IsNeg
+  | IsPos p => IsPos (xI p)
+  end.
+
+(** Operation x -> 2*x *)
+
+Definition Pdouble_mask (x:positive_mask) :=
+  match x with
+  | IsNul => IsNul
+  | IsNeg => IsNeg
+  | IsPos p => IsPos (xO p)
+  end.
+
+(** Operation x -> 2*x-2 *)
+
+Definition Pdouble_minus_two (x:positive) :=
+  match x with
+  | xI x' => IsPos (xO (xO x'))
+  | xO x' => IsPos (xO (Pdouble_minus_one x'))
+  | xH => IsNul
+  end.
+
+(** Subtraction of binary positive numbers into a positive numbers mask *)
+
+Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask :=
+  match x, y with
+  | xI x', xI y' => Pdouble_mask (Pminus_mask x' y')
+  | xI x', xO y' => Pdouble_plus_one_mask (Pminus_mask x' y')
+  | xI x', xH => IsPos (xO x')
+  | xO x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xO x', xO y' => Pdouble_mask (Pminus_mask x' y')
+  | xO x', xH => IsPos (Pdouble_minus_one x')
+  | xH, xH => IsNul
+  | xH, _ => IsNeg
+  end
+ 
+ with Pminus_mask_carry (x y:positive) {struct y} : positive_mask :=
+  match x, y with
+  | xI x', xI y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xI x', xO y' => Pdouble_mask (Pminus_mask x' y')
+  | xI x', xH => IsPos (Pdouble_minus_one x')
+  | xO x', xI y' => Pdouble_mask (Pminus_mask_carry x' y')
+  | xO x', xO y' => Pdouble_plus_one_mask (Pminus_mask_carry x' y')
+  | xO x', xH => Pdouble_minus_two x'
+  | xH, _ => IsNeg
+  end.
+
+(** Subtraction of binary positive numbers x and y, returns 1 if x<=y *)
+
+Definition Pminus (x y:positive) :=
+  match Pminus_mask x y with
+  | IsPos z => z
+  | _ => xH
+  end.
+
+Infix "-" := Pminus : positive_scope.
+
+(** Multiplication on binary positive numbers *)
+
+Fixpoint Pmult (x y:positive) {struct x} : positive :=
+  match x with
+  | xI x' => y + xO (Pmult x' y)
+  | xO x' => xO (Pmult x' y)
+  | xH => y
+  end.
+
+Infix "*" := Pmult : positive_scope.
+
+(** Division by 2 rounded below but for 1 *)
+
+Definition Pdiv2 (z:positive) :=
+  match z with
+  | xH => xH
+  | xO p => p
+  | xI p => p
+  end.
+
+Infix "/" := Pdiv2 : positive_scope.
+
+(** Comparison on binary positive numbers *)
+
+Fixpoint Pcompare (x y:positive) (r:comparison) {struct y} : comparison :=
+  match x, y with
+  | xI x', xI y' => Pcompare x' y' r
+  | xI x', xO y' => Pcompare x' y' Gt
+  | xI x', xH => Gt
+  | xO x', xI y' => Pcompare x' y' Lt
+  | xO x', xO y' => Pcompare x' y' r
+  | xO x', xH => Gt
+  | xH, xI y' => Lt
+  | xH, xO y' => Lt
+  | xH, xH => r
+  end.
+
+Infix "?=" := Pcompare (at level 70, no associativity) : positive_scope.
+
+(**********************************************************************)
+(** Miscellaneous properties of binary positive numbers *)
+
+Lemma ZL11 : forall p:positive, p = xH \/ p <> xH.
+Proof.
+intros x; case x; intros; (left; reflexivity) || (right; discriminate).
+Qed.
+
+(**********************************************************************)
+(** Properties of successor on binary positive numbers *)
+
+(** Specification of [xI] in term of [Psucc] and [xO] *)
+
+Lemma xI_succ_xO : forall p:positive, xI p = Psucc (xO p).
+Proof.
+reflexivity.
+Qed.
+
+Lemma Psucc_discr : forall p:positive, p <> Psucc p.
+Proof.
+intro x; destruct x as [p| p| ]; discriminate.
+Qed.
+
+(** Successor and double *)
+
+Lemma Psucc_o_double_minus_one_eq_xO :
+ forall p:positive, Psucc (Pdouble_minus_one p) = xO p.
+Proof.
+intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx;
+ reflexivity.
+Qed.
+
+Lemma Pdouble_minus_one_o_succ_eq_xI :
+ forall p:positive, Pdouble_minus_one (Psucc p) = xI p.
+Proof.
+intro x; induction x as [x IHx| x| ]; simpl in |- *; try rewrite IHx;
+ reflexivity.
+Qed.
+
+Lemma xO_succ_permute :
+ forall p:positive, xO (Psucc p) = Psucc (Psucc (xO p)).
+Proof.
+intro y; induction  y as [y Hrecy| y Hrecy| ]; simpl in |- *; auto.
+Qed.
+
+Lemma double_moins_un_xO_discr :
+ forall p:positive, Pdouble_minus_one p <> xO p.
+Proof.
+intro x; destruct x as [p| p| ]; discriminate.
+Qed.
+
+(** Successor and predecessor *)
+
+Lemma Psucc_not_one : forall p:positive, Psucc p <> xH.
+Proof.
+intro x; destruct x as [x| x| ]; discriminate.
+Qed.
+
+Lemma Ppred_succ : forall p:positive, Ppred (Psucc p) = p.
+Proof.
+intro x; destruct x as [p| p| ]; [ idtac | idtac | simpl in |- *; auto ];
+ (induction p as [p IHp| | ]; [ idtac | reflexivity | reflexivity ]);
+ simpl in |- *; simpl in IHp; try rewrite <- IHp; reflexivity.
+Qed.
+
+Lemma Psucc_pred : forall p:positive, p = xH \/ Psucc (Ppred p) = p.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ];
+ [ simpl in |- *; auto
+ | simpl in |- *; intros; right; apply Psucc_o_double_minus_one_eq_xO
+ | auto ].
+Qed.
+
+(** Injectivity of successor *)
+
+Lemma Psucc_inj : forall p q:positive, Psucc p = Psucc q -> p = q.
+Proof.
+intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H;
+ discriminate H || (try (injection H; clear H; intro H)).
+rewrite (IHx y H); reflexivity.
+absurd (Psucc x = xH); [ apply Psucc_not_one | assumption ].
+apply f_equal with (1 := H); assumption.
+absurd (Psucc y = xH);
+ [ apply Psucc_not_one | symmetry  in |- *; assumption ].
+reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of addition on binary positive numbers *)
+
+(** Specification of [Psucc] in term of [Pplus] *)
+
+Lemma Pplus_one_succ_r : forall p:positive, Psucc p = p + xH.
+Proof.
+intro q; destruct q as [p| p| ]; reflexivity.
+Qed.
+
+Lemma Pplus_one_succ_l : forall p:positive, Psucc p = xH + p.
+Proof.
+intro q; destruct q as [p| p| ]; reflexivity.
+Qed.
+
+(** Specification of [Pplus_carry] *)
+
+Theorem Pplus_carry_spec :
+ forall p q:positive, Pplus_carry p q = Psucc (p + q).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto; rewrite IHp; 
+ auto.
+Qed.
+
+(** Commutativity *)
+
+Theorem Pplus_comm : forall p q:positive, p + q = q + p.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto;
+ try do 2 rewrite Pplus_carry_spec; rewrite IHp; auto.
+Qed. 
+
+(** Permutation of [Pplus] and [Psucc] *)
+
+Theorem Pplus_succ_permute_r :
+ forall p q:positive, p + Psucc q = Psucc (p + q).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto;
+ [ rewrite Pplus_carry_spec; rewrite IHp; auto
+ | rewrite Pplus_carry_spec; auto
+ | destruct p; simpl in |- *; auto
+ | rewrite IHp; auto
+ | destruct p; simpl in |- *; auto ].
+Qed.
+
+Theorem Pplus_succ_permute_l :
+ forall p q:positive, Psucc p + q = Psucc (p + q).
+Proof.
+intros x y; rewrite Pplus_comm; rewrite Pplus_comm with (p := x);
+ apply Pplus_succ_permute_r.
+Qed.
+
+Theorem Pplus_carry_pred_eq_plus :
+ forall p q:positive, q <> xH -> Pplus_carry p (Ppred q) = p + q.
+Proof.
+intros q z H; elim (Psucc_pred z);
+ [ intro; absurd (z = xH); auto
+ | intros E; pattern z at 2 in |- *; rewrite <- E;
+    rewrite Pplus_succ_permute_r; rewrite Pplus_carry_spec; 
+    trivial ].
+Qed. 
+
+(** No neutral for addition on strictly positive numbers *)
+
+Lemma Pplus_no_neutral : forall p q:positive, q + p <> p.
+Proof.
+intro x; induction x; intro y; destruct y as [y| y| ]; simpl in |- *; intro H;
+ discriminate H || injection H; clear H; intro H; apply (IHx y H).
+Qed.
+
+Lemma Pplus_carry_no_neutral :
+ forall p q:positive, Pplus_carry q p <> Psucc p.
+Proof.
+intros x y H; absurd (y + x = x);
+ [ apply Pplus_no_neutral
+ | apply Psucc_inj; rewrite <- Pplus_carry_spec; assumption ].
+Qed.
+
+(** Simplification *)
+
+Lemma Pplus_carry_plus :
+ forall p q r s:positive, Pplus_carry p r = Pplus_carry q s -> p + r = q + s.
+Proof.
+intros x y z t H; apply Psucc_inj; do 2 rewrite <- Pplus_carry_spec;
+ assumption.
+Qed.
+
+Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q.
+Proof.
+intros x y z; generalize x y; clear x y.
+induction z as [z| z| ].
+  destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *;
+   intro H; discriminate H || (try (injection H; clear H; intro H)).
+    rewrite IHz with (1 := Pplus_carry_plus _ _ _ _ H); reflexivity.
+    absurd (Pplus_carry x z = Psucc z);
+     [ apply Pplus_carry_no_neutral | assumption ].
+    rewrite IHz with (1 := H); reflexivity.
+    symmetry  in H; absurd (Pplus_carry y z = Psucc z);
+     [ apply Pplus_carry_no_neutral | assumption ].
+    reflexivity.
+  destruct x as [x| x| ]; intro y; destruct y as [y| y| ]; simpl in |- *;
+   intro H; discriminate H || (try (injection H; clear H; intro H)).
+    rewrite IHz with (1 := H); reflexivity.
+    absurd (x + z = z); [ apply Pplus_no_neutral | assumption ].
+    rewrite IHz with (1 := H); reflexivity.
+    symmetry  in H; absurd (y + z = z);
+     [ apply Pplus_no_neutral | assumption ].
+    reflexivity.
+  intros H x y; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption.
+Qed.
+
+Lemma Pplus_reg_l : forall p q r:positive, p + q = p + r -> q = r.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := x);
+ rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y);
+ assumption.
+Qed.
+
+Lemma Pplus_carry_reg_r :
+ forall p q r:positive, Pplus_carry p r = Pplus_carry q r -> p = q.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := z); apply Pplus_carry_plus;
+ assumption.
+Qed.
+
+Lemma Pplus_carry_reg_l :
+ forall p q r:positive, Pplus_carry p q = Pplus_carry p r -> q = r.
+Proof.
+intros x y z H; apply Pplus_reg_r with (r := x);
+ rewrite Pplus_comm with (p := z); rewrite Pplus_comm with (p := y);
+ apply Pplus_carry_plus; assumption.
+Qed.
+
+(** Addition on positive is associative *)
+
+Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r.
+Proof.
+intros x y; generalize x; clear x.
+induction y as [y| y| ]; intro x.
+  destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *;
+   repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r;
+   repeat rewrite Pplus_succ_permute_l;
+   reflexivity || (repeat apply f_equal with (A := positive)); 
+   apply IHy.
+  destruct x as [x| x| ]; intro z; destruct z as [z| z| ]; simpl in |- *;
+   repeat rewrite Pplus_carry_spec; repeat rewrite Pplus_succ_permute_r;
+   repeat rewrite Pplus_succ_permute_l;
+   reflexivity || (repeat apply f_equal with (A := positive)); 
+   apply IHy.
+  intro z; rewrite Pplus_comm with (p := xH);
+   do 2 rewrite <- Pplus_one_succ_r; rewrite Pplus_succ_permute_l;
+   rewrite Pplus_succ_permute_r; reflexivity.
+Qed.
+
+(** Commutation of addition with the double of a positive number *)
+
+Lemma Pplus_xI_double_minus_one :
+ forall p q:positive, xO (p + q) = xI p + Pdouble_minus_one q.
+Proof.
+intros; change (xI p) with (xO p + xH) in |- *.
+rewrite <- Pplus_assoc; rewrite <- Pplus_one_succ_l;
+ rewrite Psucc_o_double_minus_one_eq_xO.
+reflexivity.
+Qed.
+
+Lemma Pplus_xO_double_minus_one :
+ forall p q:positive, Pdouble_minus_one (p + q) = xO p + Pdouble_minus_one q.
+Proof.
+induction p as [p IHp| p IHp| ]; destruct q as [q| q| ]; simpl in |- *;
+ try rewrite Pplus_carry_spec; try rewrite Pdouble_minus_one_o_succ_eq_xI;
+ try rewrite IHp; try rewrite Pplus_xI_double_minus_one; 
+ try reflexivity.
+ rewrite <- Psucc_o_double_minus_one_eq_xO; rewrite Pplus_one_succ_l;
+  reflexivity. 
+Qed.
+
+(** Misc *)
+
+Lemma Pplus_diag : forall p:positive, p + p = xO p.
+Proof.
+intro x; induction x; simpl in |- *; try rewrite Pplus_carry_spec;
+ try rewrite IHx; reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Peano induction on binary positive positive numbers *)
+
+Fixpoint plus_iter (x y:positive) {struct x} : positive :=
+  match x with
+  | xH => Psucc y
+  | xO x => plus_iter x (plus_iter x y)
+  | xI x => plus_iter x (plus_iter x (Psucc y))
+  end.
+
+Lemma plus_iter_eq_plus : forall p q:positive, plus_iter p q = p + q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; reflexivity || (do 2 rewrite IHp);
+ rewrite Pplus_assoc; rewrite Pplus_diag; try reflexivity.
+rewrite Pplus_carry_spec; rewrite <- Pplus_succ_permute_r; reflexivity.
+rewrite Pplus_one_succ_r; reflexivity.
+Qed.
+
+Lemma plus_iter_xO : forall p:positive, plus_iter p p = xO p.
+Proof.
+intro; rewrite <- Pplus_diag; apply plus_iter_eq_plus.
+Qed.
+
+Lemma plus_iter_xI : forall p:positive, Psucc (plus_iter p p) = xI p.
+Proof.
+intro; rewrite xI_succ_xO; rewrite <- Pplus_diag;
+ apply (f_equal (A:=positive)); apply plus_iter_eq_plus.
+Qed.
+
+Lemma iterate_add :
+ forall P:positive -> Type,
+   (forall n:positive, P n -> P (Psucc n)) ->
+   forall p q:positive, P q -> P (plus_iter p q).
+Proof.
+intros P H; induction p; simpl in |- *; intros.
+apply IHp; apply IHp; apply H; assumption.
+apply IHp; apply IHp; assumption.
+apply H; assumption.
+Defined.
+
+(** Peano induction *)
+
+Theorem Pind :
+ forall P:positive -> Prop,
+   P xH -> (forall n:positive, P n -> P (Psucc n)) -> forall p:positive, P p.
+Proof.
+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.
+
+(** Peano recursion *)
+
+Definition Prec (A:Set) (a:A) (f:positive -> A -> A) : 
+  positive -> A :=
+  (fix Prec (p:positive) : A :=
+     match p with
+     | xH => a
+     | xO p => iterate_add (fun _ => A) f p p (Prec p)
+     | xI p => f (plus_iter p p) (iterate_add (fun _ => A) f p p (Prec p))
+     end).
+
+(** Peano case analysis *)
+
+Theorem Pcase :
+ forall P:positive -> Prop,
+   P xH -> (forall n:positive, P (Psucc n)) -> forall p:positive, P p.
+Proof.
+intros; apply Pind; auto.
+Qed.
+
+(*
+Check
+  (let fact := Prec positive xH (fun p r => Psucc 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 Pmult_1_r : forall p:positive, p * xH = p.
+Proof.
+intro x; induction x; simpl in |- *.
+  rewrite IHx; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Right reduction properties for multiplication *)
+
+Lemma Pmult_xO_permute_r : forall p q:positive, p * xO q = xO (p * q).
+Proof.
+intros x y; induction x; simpl in |- *.
+  rewrite IHx; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+Lemma Pmult_xI_permute_r : forall p q:positive, p * xI q = p + xO (p * q).
+Proof.
+intros x y; induction x; simpl in |- *.
+  rewrite IHx; do 2 rewrite Pplus_assoc; rewrite Pplus_comm with (p := y);
+   reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Commutativity of multiplication *)
+
+Theorem Pmult_comm : forall p q:positive, p * q = q * p.
+Proof.
+intros x y; induction y; simpl in |- *.
+  rewrite <- IHy; apply Pmult_xI_permute_r.
+  rewrite <- IHy; apply Pmult_xO_permute_r.
+  apply Pmult_1_r.
+Qed.
+
+(** Distributivity of multiplication over addition *)
+
+Theorem Pmult_plus_distr_l :
+ forall p q r:positive, p * (q + r) = p * q + p * r.
+Proof.
+intros x y z; induction x; simpl in |- *.
+  rewrite IHx; rewrite <- Pplus_assoc with (q := xO (x * y));
+   rewrite Pplus_assoc with (p := xO (x * y));
+   rewrite Pplus_comm with (p := xO (x * y));
+   rewrite <- Pplus_assoc with (q := xO (x * y));
+   rewrite Pplus_assoc with (q := z); reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+Theorem Pmult_plus_distr_r :
+ forall p q r:positive, (p + q) * r = p * r + q * r.
+Proof.
+intros x y z; do 3 rewrite Pmult_comm with (q := z); apply Pmult_plus_distr_l.
+Qed.
+
+(** Associativity of multiplication *)
+
+Theorem Pmult_assoc : forall p q r:positive, p * (q * r) = p * q * r.
+Proof.
+intro x; induction x as [x| x| ]; simpl in |- *; intros y z.
+  rewrite IHx; rewrite Pmult_plus_distr_r; reflexivity.
+  rewrite IHx; reflexivity.
+  reflexivity.
+Qed.
+
+(** Parity properties of multiplication *)
+
+Lemma Pmult_xI_mult_xO_discr : forall p q r:positive, xI p * r <> xO q * r.
+Proof.
+intros x y z; induction z as [| z IHz| ]; try discriminate.
+intro H; apply IHz; clear IHz.
+do 2 rewrite Pmult_xO_permute_r in H.
+injection H; clear H; intro H; exact H.
+Qed.
+
+Lemma Pmult_xO_discr : forall p q:positive, xO p * q <> q.
+Proof.
+intros x y; induction y; try discriminate.
+rewrite Pmult_xO_permute_r; injection; assumption.
+Qed.
+
+(** Simplification properties of multiplication *)
+
+Theorem Pmult_reg_r : forall p q r:positive, p * r = q * r -> p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ intros z H; reflexivity || apply (f_equal (A:=positive)) || apply False_ind.
+  simpl in H; apply IHp with (xO z); simpl in |- *;
+   do 2 rewrite Pmult_xO_permute_r; apply Pplus_reg_l with (1 := H).
+  apply Pmult_xI_mult_xO_discr with (1 := H).
+  simpl in H; rewrite Pplus_comm in H; apply Pplus_no_neutral with (1 := H).
+  symmetry  in H; apply Pmult_xI_mult_xO_discr with (1 := H).
+  apply IHp with (xO z); simpl in |- *; do 2 rewrite Pmult_xO_permute_r;
+   assumption.
+  apply Pmult_xO_discr with (1 := H).
+  simpl in H; symmetry  in H; rewrite Pplus_comm in H;
+   apply Pplus_no_neutral with (1 := H).
+  symmetry  in H; apply Pmult_xO_discr with (1 := H).
+Qed.
+
+Theorem Pmult_reg_l : forall p q r:positive, r * p = r * q -> p = q.
+Proof.
+intros x y z H; apply Pmult_reg_r with (r := z).
+rewrite Pmult_comm with (p := x); rewrite Pmult_comm with (p := y);
+ assumption.
+Qed.
+
+(** Inversion of multiplication *)
+
+Lemma Pmult_1_inversion_l : forall p q:positive, p * q = xH -> p = xH.
+Proof.
+intros x y; destruct x as [p| p| ]; simpl in |- *.
+ destruct y as [p0| p0| ]; intro; discriminate.
+ intro; discriminate.
+ reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of comparison on binary positive numbers *)
+
+Theorem Pcompare_not_Eq :
+ forall p q:positive, (p ?= q) Gt <> Eq /\ (p ?= q) Lt <> Eq.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ split; simpl in |- *; auto; discriminate || (elim (IHp q); auto).
+Qed.
+
+Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; intro H;
+ [ rewrite (IHp q); trivial
+ | absurd ((p ?= q) Gt = Eq);
+    [ elim (Pcompare_not_Eq p q); auto | assumption ]
+ | discriminate H
+ | absurd ((p ?= q) Lt = Eq);
+    [ elim (Pcompare_not_Eq p q); auto | assumption ]
+ | rewrite (IHp q); auto
+ | discriminate H
+ | discriminate H
+ | discriminate H ].
+Qed.
+
+Lemma Pcompare_Gt_Lt :
+ forall p q:positive, (p ?= q) Gt = Lt -> (p ?= q) Eq = Lt.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; intro y;
+ [ induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; 
+ auto; discriminate || intros H; discriminate H.
+Qed.
+
+Lemma Pcompare_Lt_Gt :
+ forall p q:positive, (p ?= q) Lt = Gt -> (p ?= q) Eq = Gt.
+Proof.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; intro y;
+ [ induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ]
+ | induction  y as [y Hrecy| y Hrecy| ] ]; simpl in |- *; 
+ auto; discriminate || intros H; discriminate H.
+Qed.
+
+Lemma Pcompare_Lt_Lt :
+ forall p q:positive, (p ?= q) Lt = Lt -> (p ?= q) Eq = Lt \/ p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); 
+ auto; intros E; rewrite E; auto.
+Qed.
+
+Lemma Pcompare_Gt_Gt :
+ forall p q:positive, (p ?= q) Gt = Gt -> (p ?= q) Eq = Gt \/ p = q.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; auto; try discriminate; intro H2; elim (IHp q H2); 
+ auto; intros E; rewrite E; auto.
+Qed.
+
+Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt.
+Proof.
+simple induction r; auto. 
+Qed.
+
+Ltac ElimPcompare c1 c2 :=
+  elim (Dcompare ((c1 ?= c2) Eq));
+   [ idtac | let x := fresh "H" in
+             (intro x; case x; clear x) ].
+
+Theorem Pcompare_refl : forall p:positive, (p ?= p) Eq = Eq.
+intro x; induction  x as [x Hrecx| x Hrecx| ]; auto.
+Qed.
+
+Lemma Pcompare_antisym :
+ forall (p q:positive) (r:comparison),
+   CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r).
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; intro r;
+ reflexivity ||
+   (symmetry  in |- *; assumption) || discriminate H || simpl in |- *;
+ apply IHp || (try rewrite IHp); try reflexivity.
+Qed.
+
+Lemma ZC1 : forall p q:positive, (p ?= q) Eq = Gt -> (q ?= p) Eq = Lt.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC2 : forall p q:positive, (p ?= q) Eq = Lt -> (q ?= p) Eq = Gt.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC3 : forall p q:positive, (p ?= q) Eq = Eq -> (q ?= p) Eq = Eq.
+Proof.
+intros; change Eq with (CompOpp Eq) in |- *.
+rewrite <- Pcompare_antisym; rewrite H; reflexivity.
+Qed.
+
+Lemma ZC4 : forall p q:positive, (p ?= q) Eq = CompOpp ((q ?= p) Eq).
+Proof.
+intros; change Eq at 1 with (CompOpp Eq) in |- *.
+symmetry  in |- *; apply Pcompare_antisym.
+Qed.
+
+(**********************************************************************)
+(** Properties of subtraction on binary positive numbers *)
+
+Lemma double_eq_zero_inversion :
+ forall p:positive_mask, Pdouble_mask p = IsNul -> p = IsNul.
+Proof.
+destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ].
+Qed.
+
+Lemma double_plus_one_zero_discr :
+ forall p:positive_mask, Pdouble_plus_one_mask p <> IsNul.
+Proof.
+simple induction p; intros; discriminate.
+Qed.
+
+Lemma double_plus_one_eq_one_inversion :
+ forall p:positive_mask, Pdouble_plus_one_mask p = IsPos xH -> p = IsNul.
+Proof.
+destruct p; simpl in |- *; [ trivial | discriminate 1 | discriminate 1 ].
+Qed.
+
+Lemma double_eq_one_discr :
+ forall p:positive_mask, Pdouble_mask p <> IsPos xH.
+Proof.
+simple induction p; intros; discriminate.
+Qed.
+
+Theorem Pminus_mask_diag : forall p:positive, Pminus_mask p p = IsNul.
+Proof.
+intro x; induction x as [p IHp| p IHp| ];
+ [ simpl in |- *; rewrite IHp; simpl in |- *; trivial
+ | simpl in |- *; rewrite IHp; auto
+ | auto ].
+Qed.
+
+Lemma ZL10 :
+ forall p q:positive,
+   Pminus_mask p q = IsPos xH -> Pminus_mask_carry p q = IsNul.
+Proof.
+intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; intro H; try discriminate H;
+ [ absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH);
+    [ apply double_eq_one_discr | assumption ]
+ | assert (Heq : Pminus_mask p q = IsNul);
+    [ apply double_plus_one_eq_one_inversion; assumption
+    | rewrite Heq; reflexivity ]
+ | assert (Heq : Pminus_mask_carry p q = IsNul);
+    [ apply double_plus_one_eq_one_inversion; assumption
+    | rewrite Heq; reflexivity ]
+ | absurd (Pdouble_mask (Pminus_mask p q) = IsPos xH);
+    [ apply double_eq_one_discr | assumption ]
+ | destruct p; simpl in |- *;
+    [ discriminate H | discriminate H | reflexivity ] ].
+Qed.
+
+(** Properties of subtraction valid only for x>y *)
+
+Lemma Pminus_mask_Gt :
+ forall p q:positive,
+   (p ?= q) Eq = Gt ->
+    exists h : positive,
+     Pminus_mask p q = IsPos h /\
+     q + h = p /\ (h = xH \/ Pminus_mask_carry p q = IsPos (Ppred h)).
+Proof.
+intro x; induction x as [p| p| ]; intro y; destruct y as [q| q| ];
+ simpl in |- *; intro H; try discriminate H.
+  destruct (IHp q H) as [z [H4 [H6 H7]]]; exists (xO z); split.
+    rewrite H4; reflexivity.
+    split.
+      simpl in |- *; rewrite H6; reflexivity.
+      right; clear H6; destruct (ZL11 z) as [H8| H8];
+       [ rewrite H8; rewrite H8 in H4; rewrite ZL10;
+          [ reflexivity | assumption ]
+       | clear H4; destruct H7 as [H9| H9];
+          [ absurd (z = xH); assumption
+          | rewrite H9; clear H9; destruct z as [p0| p0| ];
+             [ reflexivity | reflexivity | absurd (xH = xH); trivial ] ] ].
+  case Pcompare_Gt_Gt 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 in |- *; rewrite H5; auto
+      | split;
+         [ simpl in |- *; rewrite H7; trivial
+         | right;
+            change (Pdouble_mask (Pminus_mask p q) = IsPos (Ppred (xI z)))
+             in |- *; rewrite H5; auto ] ]
+   | intros H3; exists xH; rewrite H3; split;
+      [ simpl in |- *; rewrite Pminus_mask_diag; auto | split; auto ] ].
+  exists (xO p); auto.
+  destruct (IHp q) as [z [H4 [H6 H7]]].
+    apply Pcompare_Lt_Gt; assumption.
+    destruct (ZL11 z) as [vZ| ];
+     [ exists xH; split;
+        [ rewrite ZL10; [ reflexivity | rewrite vZ in H4; assumption ]
+        | split;
+           [ simpl in |- *; rewrite Pplus_one_succ_r; rewrite <- vZ;
+              rewrite H6; trivial
+           | auto ] ]
+     | exists (xI (Ppred z)); destruct H7 as [| H8];
+        [ absurd (z = xH); assumption
+        | split;
+           [ rewrite H8; trivial
+           | split;
+              [ simpl in |- *; rewrite Pplus_carry_pred_eq_plus;
+                 [ rewrite H6; trivial | assumption ]
+              | right; rewrite H8; reflexivity ] ] ] ].
+  destruct (IHp q H) as [z [H4 [H6 H7]]].
+  exists (xO z); split;
+   [ rewrite H4; auto
+   | split;
+      [ simpl in |- *; rewrite H6; reflexivity
+      | right;
+         change
+           (Pdouble_plus_one_mask (Pminus_mask_carry p q) =
+            IsPos (Pdouble_minus_one z)) in |- *;
+         destruct (ZL11 z) as [H8| H8];
+         [ rewrite H8; simpl in |- *;
+            assert (H9 : Pminus_mask_carry p q = IsNul);
+            [ apply ZL10; rewrite <- H8; assumption
+            | rewrite H9; reflexivity ]
+         | destruct H7 as [H9| H9];
+            [ absurd (z = xH); auto
+            | rewrite H9; destruct z as [p0| p0| ]; simpl in |- *;
+               [ reflexivity
+               | reflexivity
+               | absurd (xH = xH); [ assumption | reflexivity ] ] ] ] ] ].
+  exists (Pdouble_minus_one p); split;
+   [ reflexivity
+   | clear IHp; split;
+      [ destruct p; simpl in |- *;
+         [ reflexivity
+         | rewrite Psucc_o_double_minus_one_eq_xO; reflexivity
+         | reflexivity ]
+      | destruct p; [ right | right | left ]; reflexivity ] ].
+Qed.
+
+Theorem Pplus_minus :
+ forall p q:positive, (p ?= q) Eq = Gt -> q + (p - q) = p.
+Proof.
+intros x y H; elim Pminus_mask_Gt with (1 := H); intros z H1; elim H1;
+ intros H2 H3; elim H3; intros H4 H5; unfold Pminus in |- *; 
+ rewrite H2; exact H4.
+Qed.
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
new file mode 100644
index 00000000..b1bdaaf0
--- /dev/null
+++ b/theories/NArith/NArith.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: NArith.v,v 1.2.2.1 2004/07/16 19:31:07 herbelin Exp $ *)
+
+(** Library for binary natural numbers *)
+
+Require Export BinPos.
+Require Export BinNat.
\ No newline at end of file
diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v
new file mode 100644
index 00000000..f5bbb1c9
--- /dev/null
+++ b/theories/NArith/Pnat.v
@@ -0,0 +1,485 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:31:07 herbelin Exp $ i*)
+
+Require Import BinPos.
+
+(**********************************************************************)
+(** Properties of the injection from binary positive numbers to Peano 
+    natural numbers *)
+
+(** Original development by Pierre Crégut, CNET, Lannion, France *)
+
+Require Import Le.
+Require Import Lt.
+Require Import Gt.
+Require Import Plus.
+Require Import Mult.
+Require Import Minus.
+
+(** [nat_of_P] is a morphism for addition *)
+
+Lemma Pmult_nat_succ_morphism :
+ forall (p:positive) (n:nat), Pmult_nat (Psucc p) n = n + Pmult_nat p n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; simpl in |- *; auto; intro m;
+ rewrite IHp; rewrite plus_assoc; trivial.
+Qed.
+
+Lemma nat_of_P_succ_morphism :
+ forall p:positive, nat_of_P (Psucc p) = S (nat_of_P p).
+Proof.
+  intro; change (S (nat_of_P p)) with (1 + nat_of_P p) in |- *;
+   unfold nat_of_P in |- *; apply Pmult_nat_succ_morphism.
+Qed.
+
+Theorem Pmult_nat_plus_carry_morphism :
+ forall (p q:positive) (n:nat),
+   Pmult_nat (Pplus_carry p q) n = n + Pmult_nat (p + q) n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; 
+ intro m;
+ [ rewrite IHp; rewrite plus_assoc; trivial with arith
+ | rewrite IHp; rewrite plus_assoc; trivial with arith
+ | rewrite Pmult_nat_succ_morphism; rewrite plus_assoc; trivial with arith
+ | rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
+Qed.
+
+Theorem nat_of_P_plus_carry_morphism :
+ forall p q:positive, nat_of_P (Pplus_carry p q) = S (nat_of_P (p + q)).
+Proof.
+intros; unfold nat_of_P in |- *; rewrite Pmult_nat_plus_carry_morphism;
+ simpl in |- *; trivial with arith.
+Qed.
+
+Theorem Pmult_nat_l_plus_morphism :
+ forall (p q:positive) (n:nat),
+   Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
+Proof.
+intro x; induction x as [p IHp| p IHp| ]; intro y;
+ [ destruct y as [p0| p0| ]
+ | destruct y as [p0| p0| ]
+ | destruct y as [p| p| ] ]; simpl in |- *; auto with arith;
+ [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp;
+    rewrite plus_assoc_reverse; rewrite plus_assoc_reverse;
+    rewrite (plus_permute m (Pmult_nat p (m + m))); 
+    trivial with arith
+ | intros m; rewrite IHp; apply plus_assoc
+ | intros m; rewrite Pmult_nat_succ_morphism;
+    rewrite (plus_comm (m + Pmult_nat p (m + m))); 
+    apply plus_assoc_reverse
+ | intros m; rewrite IHp; apply plus_permute
+ | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ].
+Qed.
+
+Theorem nat_of_P_plus_morphism :
+ forall p q:positive, nat_of_P (p + q) = nat_of_P p + nat_of_P q.
+Proof.
+intros x y; exact (Pmult_nat_l_plus_morphism x y 1).
+Qed.
+
+(** [Pmult_nat] is a morphism for addition *)
+
+Lemma Pmult_nat_r_plus_morphism :
+ forall (p:positive) (n:nat),
+   Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
+Proof.
+intro y; induction y as [p H| p H| ]; intro m;
+ [ simpl in |- *; rewrite H; rewrite plus_assoc_reverse;
+    rewrite (plus_permute m (Pmult_nat p (m + m)));
+    rewrite plus_assoc_reverse; auto with arith
+ | simpl in |- *; rewrite H; auto with arith
+ | simpl in |- *; trivial with arith ].
+Qed.
+
+Lemma ZL6 : forall p:positive, Pmult_nat p 2 = nat_of_P p + nat_of_P p.
+Proof.
+intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism;
+ trivial.
+Qed.
+ 
+(** [nat_of_P] is a morphism for multiplication *)
+
+Theorem nat_of_P_mult_morphism :
+ forall p q:positive, nat_of_P (p * q) = nat_of_P p * nat_of_P q.
+Proof.
+intros x y; induction x as [x' H| x' H| ];
+ [ change (xI x' * y)%positive with (y + xO (x' * y))%positive in |- *;
+    rewrite nat_of_P_plus_morphism; unfold nat_of_P at 2 3 in |- *;
+    simpl in |- *; do 2 rewrite ZL6; rewrite H; rewrite mult_plus_distr_r;
+    reflexivity
+ | unfold nat_of_P at 1 2 in |- *; simpl in |- *; do 2 rewrite ZL6; rewrite H;
+    rewrite mult_plus_distr_r; reflexivity
+ | simpl in |- *; rewrite <- plus_n_O; reflexivity ].
+Qed.
+
+(** [nat_of_P] maps to the strictly positive subset of [nat] *)
+
+Lemma ZL4 : forall p:positive,  exists h : nat, nat_of_P p = S h.
+Proof.
+intro y; induction y as [p H| p H| ];
+ [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *;
+    simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; 
+    rewrite H1; auto with arith
+ | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *;
+    simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; 
+    rewrite H2; auto with arith
+ | exists 0; auto with arith ].
+Qed.
+
+(** Extra lemmas on [lt] on Peano natural numbers *)
+
+Lemma ZL7 : forall n m:nat, n < m -> n + n < m + m.
+Proof.
+intros m n H; apply lt_trans with (m := m + n);
+ [ apply plus_lt_compat_l with (1 := H)
+ | rewrite (plus_comm m n); apply plus_lt_compat_l with (1 := H) ].
+Qed.
+
+Lemma ZL8 : forall n m:nat, n < m -> S (n + n) < m + m.
+Proof.
+intros m n H; apply le_lt_trans with (m := m + n);
+ [ change (m + m < m + n) in |- *; apply plus_lt_compat_l with (1 := H)
+ | rewrite (plus_comm m n); apply plus_lt_compat_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 nat_of_P_lt_Lt_compare_morphism :
+ forall p q:positive, (p ?= q)%positive Eq = Lt -> nat_of_P p < nat_of_P q.
+Proof.
+intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ];
+ intro H2;
+ [ unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; do 2 rewrite ZL6;
+    apply ZL7; apply H; simpl in H2; assumption
+ | unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6; apply ZL8;
+    apply H; simpl in H2; apply Pcompare_Gt_Lt; assumption
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    elim (Pcompare_Lt_Lt p q H2);
+    [ intros H3; apply lt_S; apply ZL7; apply H; apply H3
+    | intros E; rewrite E; apply lt_n_Sn ]
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL7; apply H; assumption
+ | simpl in |- *; discriminate H2
+ | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6;
+    elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; 
+    apply lt_O_Sn
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q);
+    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
+    apply lt_n_S; apply lt_O_Sn
+ | simpl in |- *; 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 nat_of_P_gt_Gt_compare_morphism :
+ forall p q:positive, (p ?= q)%positive Eq = Gt -> nat_of_P p > nat_of_P q.
+Proof.
+unfold gt in |- *; intro x; induction x as [p H| p H| ]; intro y;
+ destruct y as [q| q| ]; intro H2;
+ [ simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply lt_n_S; apply ZL7; apply H; assumption
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    elim (Pcompare_Gt_Gt p q H2);
+    [ intros H3; apply lt_S; apply ZL7; apply H; assumption
+    | intros E; rewrite E; apply lt_n_Sn ]
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
+    intros h H3; rewrite H3; simpl in |- *; apply lt_n_S; 
+    apply lt_O_Sn
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL8; apply H; apply Pcompare_Lt_Gt; assumption
+ | simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; do 2 rewrite ZL6;
+    apply ZL7; apply H; assumption
+ | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 p);
+    intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm;
+    apply lt_n_S; apply lt_O_Sn
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; discriminate H2
+ | simpl in |- *; 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 nat_of_P_lt_Lt_compare_complement_morphism :
+ forall p q:positive, nat_of_P p < nat_of_P q -> (p ?= q)%positive Eq = Lt.
+Proof.
+intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
+ [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
+    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
+ | intros H; elim H;
+    [ auto
+    | intros H1 H2; absurd (nat_of_P x < nat_of_P y);
+       [ apply lt_asym; change (nat_of_P x > nat_of_P y) in |- *;
+          apply nat_of_P_gt_Gt_compare_morphism; 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 nat_of_P_gt_Gt_compare_complement_morphism :
+ forall p q:positive, nat_of_P p > nat_of_P q -> (p ?= q)%positive Eq = Gt.
+Proof.
+intros x y; unfold gt in |- *; elim (Dcompare ((x ?= y)%positive Eq));
+ [ intros E; rewrite (Pcompare_Eq_eq x y E); intros H;
+    absurd (nat_of_P y < nat_of_P y); [ apply lt_irrefl | assumption ]
+ | intros H; elim H;
+    [ intros H1 H2; absurd (nat_of_P y < nat_of_P x);
+       [ apply lt_asym; apply nat_of_P_lt_Lt_compare_morphism; assumption
+       | assumption ]
+    | auto ] ].
+Qed.
+
+(** [nat_of_P] is strictly positive *)
+
+Lemma le_Pmult_nat : forall (p:positive) (n:nat), n <= Pmult_nat p n.
+induction p; simpl in |- *; auto with arith.
+intro m; apply le_trans with (m + m); auto with arith.
+Qed.
+
+Lemma lt_O_nat_of_P : forall p:positive, 0 < nat_of_P p.
+intro; unfold nat_of_P in |- *; apply lt_le_trans with 1; auto with arith.
+apply le_Pmult_nat.
+Qed.
+
+(** Pmult_nat permutes with multiplication *)
+
+Lemma Pmult_nat_mult_permute :
+ forall (p:positive) (n m:nat), Pmult_nat p (m * n) = m * Pmult_nat p n.
+Proof.
+  simple induction p. intros. simpl in |- *. rewrite mult_plus_distr_l. rewrite <- (mult_plus_distr_l m n n).
+  rewrite (H (n + n) m). reflexivity.
+  intros. simpl in |- *. rewrite <- (mult_plus_distr_l m n n). apply H.
+  trivial.
+Qed.
+
+Lemma Pmult_nat_2_mult_2_permute :
+ forall p:positive, Pmult_nat p 2 = 2 * Pmult_nat p 1.
+Proof.
+  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
+Qed.
+
+Lemma Pmult_nat_4_mult_2_permute :
+ forall p:positive, Pmult_nat p 4 = 2 * Pmult_nat p 2.
+Proof.
+  intros. rewrite <- Pmult_nat_mult_permute. reflexivity.
+Qed.
+
+(** Mapping of xH, xO and xI through [nat_of_P] *)
+
+Lemma nat_of_P_xH : nat_of_P 1 = 1.
+Proof.
+  reflexivity.
+Qed.
+
+Lemma nat_of_P_xO : forall p:positive, nat_of_P (xO p) = 2 * nat_of_P p.
+Proof.
+  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute.
+  rewrite Pmult_nat_4_mult_2_permute. rewrite H. simpl in |- *. rewrite <- plus_Snm_nSm. reflexivity.
+  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
+  rewrite H. reflexivity.
+  reflexivity.
+Qed.
+
+Lemma nat_of_P_xI : forall p:positive, nat_of_P (xI p) = S (2 * nat_of_P p).
+Proof.
+  simple induction p. unfold nat_of_P in |- *. simpl in |- *. intro p0. intro. rewrite Pmult_nat_2_mult_2_permute.
+  rewrite Pmult_nat_4_mult_2_permute; injection H; intro H1; rewrite H1;
+   rewrite <- plus_Snm_nSm; reflexivity.
+  unfold nat_of_P in |- *. simpl in |- *. intros. rewrite Pmult_nat_2_mult_2_permute. rewrite Pmult_nat_4_mult_2_permute.
+  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 nat_of_P_o_P_of_succ_nat_eq_succ :
+ forall n:nat, nat_of_P (P_of_succ_nat n) = S n.
+Proof.
+intro m; induction m as [| n H];
+ [ reflexivity
+ | simpl in |- *; rewrite nat_of_P_succ_morphism; rewrite H; auto ].
+Qed.
+
+(** Miscellaneous lemmas on [P_of_succ_nat] *)
+
+Lemma ZL3 :
+ forall n:nat, Psucc (P_of_succ_nat (n + n)) = xO (P_of_succ_nat n).
+Proof.
+intro x; induction x as [| n H];
+ [ simpl in |- *; auto with arith
+ | simpl in |- *; rewrite plus_comm; simpl in |- *; rewrite H;
+    rewrite xO_succ_permute; auto with arith ].
+Qed.
+
+Lemma ZL5 : forall n:nat, P_of_succ_nat (S n + S n) = xI (P_of_succ_nat n).
+Proof.
+intro x; induction x as [| n H]; simpl in |- *;
+ [ auto with arith
+ | rewrite <- plus_n_Sm; simpl in |- *; simpl in H; rewrite H;
+    auto with arith ].
+Qed.
+
+(** Composition of [nat_of_P] and [P_of_succ_nat] is successor on [positive] *)
+
+Theorem P_of_succ_nat_o_nat_of_P_eq_succ :
+ forall p:positive, P_of_succ_nat (nat_of_P p) = Psucc p.
+Proof.
+intro x; induction x as [p H| p H| ];
+ [ simpl in |- *; rewrite <- H; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism; elim (ZL4 p); 
+    unfold nat_of_P in |- *; intros n H1; rewrite H1; 
+    rewrite ZL3; auto with arith
+ | unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *;
+    rewrite Pmult_nat_r_plus_morphism;
+    rewrite <- (Ppred_succ (P_of_succ_nat (Pmult_nat p 1 + Pmult_nat p 1)));
+    rewrite <- (Ppred_succ (xI p)); simpl in |- *; 
+    rewrite <- H; elim (ZL4 p); unfold nat_of_P in |- *; 
+    intros n H1; rewrite H1; rewrite ZL5; simpl in |- *; 
+    trivial with arith
+ | unfold nat_of_P in |- *; simpl in |- *; auto with arith ].
+Qed.
+
+(** Composition of [nat_of_P], [P_of_succ_nat] and [Ppred] is identity
+    on [positive] *)
+
+Theorem pred_o_P_of_succ_nat_o_nat_of_P_eq_id :
+ forall p:positive, Ppred (P_of_succ_nat (nat_of_P p)) = p.
+Proof.
+intros x; rewrite P_of_succ_nat_o_nat_of_P_eq_succ; rewrite Ppred_succ;
+ 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 nat_of_P_minus_morphism :
+ forall p q:positive,
+   (p ?= q)%positive Eq = Gt -> nat_of_P (p - q) = nat_of_P p - nat_of_P q.
+Proof.
+intros x y H; apply plus_reg_l with (nat_of_P y); rewrite le_plus_minus_r;
+ [ rewrite <- nat_of_P_plus_morphism; rewrite Pplus_minus; auto with arith
+ | apply lt_le_weak; exact (nat_of_P_gt_Gt_compare_morphism x y H) ].
+Qed.
+
+(** [nat_of_P] is injective *)
+
+Lemma nat_of_P_inj : forall p q:positive, nat_of_P p = nat_of_P q -> p = q.
+Proof.
+intros x y H; rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id x);
+ rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id y); 
+ rewrite H; trivial with arith.
+Qed.
+
+Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p.
+Proof.
+intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1;
+ rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; 
+ apply le_minus.
+Qed.
+
+Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q).
+Proof.
+intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q);
+ intros k H; rewrite H; rewrite plus_comm; simpl in |- *; 
+ apply le_n_S; apply le_plus_r.
+Qed.
+
+(** Comparison and subtraction *)
+
+Lemma Pcompare_minus_r :
+ forall p q r:positive,
+   (q ?= p)%positive Eq = Lt ->
+   (r ?= p)%positive Eq = Gt ->
+   (r ?= q)%positive Eq = Gt -> (r - p ?= r - q)%positive Eq = Lt.
+Proof.
+intros; 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; 
+             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 Pcompare_minus_l :
+ forall p q r:positive,
+   (q ?= p)%positive Eq = Lt ->
+   (p ?= r)%positive Eq = Gt ->
+   (q ?= r)%positive Eq = Gt -> (q - r ?= p - r)%positive Eq = Lt.
+Proof.
+intros p q z; intros; apply nat_of_P_lt_Lt_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;
+             apply ZC1; assumption ]
+       | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1;
+          assumption ]
+    | assumption ]
+ | assumption ].
+Qed.
+
+(** Distributivity of multiplication over subtraction *)
+
+Theorem Pmult_minus_distr_l :
+ forall p q r:positive,
+   (q ?= r)%positive Eq = Gt ->
+   (p * (q - r))%positive = (p * q - p * r)%positive.
+Proof.
+intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism;
+ rewrite nat_of_P_minus_morphism;
+ [ rewrite nat_of_P_minus_morphism;
+    [ do 2 rewrite nat_of_P_mult_morphism;
+       do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r
+    | apply nat_of_P_gt_Gt_compare_complement_morphism;
+       do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; 
+       elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l;
+       exact (nat_of_P_gt_Gt_compare_morphism y z H) ]
+ | assumption ].
+Qed.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
new file mode 100644
index 00000000..a691b189
--- /dev/null
+++ b/theories/Reals/Alembert.v
@@ -0,0 +1,726 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import PartSum.
+Require Import Max.
+
+Open Local Scope R_scope.
+
+(***************************************************)
+(* Various versions of the criterion of D'Alembert *)
+(***************************************************)
+
+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 ].
+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.
+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 ].
+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 ].
+Qed.
+
+(* 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).
+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.
+  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 ].
+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.
+Qed.
+
+(* 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
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
new file mode 100644
index 00000000..166a8a46
--- /dev/null
+++ b/theories/Reals/AltSeries.v
@@ -0,0 +1,448 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(*i $Id: AltSeries.v,v 1.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import PartSum.
+Require Import Max.
+Open Local Scope R_scope.
+
+(**********)
+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.
+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.
+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.
+Qed.
+
+(* 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.
+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.
+Qed.
+
+(* 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.
+Qed.
+
+(************************************************)
+(*        Convergence of alternated series      *)
+(*                                              *)
+(*         Applications: PI, cos, sin           *)
+(************************************************)
+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.
+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.
+Qed.
+
+(************************************)
+(* 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 ].
+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 ].
+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.
+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.
+Qed.
+
+(* Now, PI is defined *)
+Definition PI : R := 4 * match exist_PI with
+                         | existT a b => a
+                         end.
+
+(* 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 ].
+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
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
new file mode 100644
index 00000000..ad535a9d
--- /dev/null
+++ b/theories/Reals/ArithProp.v
@@ -0,0 +1,178 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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*)
+
+Require Import Rbase.
+Require Import Rbasic_fun.
+Require Import Even.
+Require Import Div2.
+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.
+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.
+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 ].
+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.
+Qed.
+
+(* 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.
+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 :
+ 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)).
+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
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
new file mode 100644
index 00000000..e31b623c
--- /dev/null
+++ b/theories/Reals/Binomial.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import PartSum.
+Open Local Scope R_scope.
+
+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.
+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.
+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.
+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.
+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
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
new file mode 100644
index 00000000..41a6284f
--- /dev/null
+++ b/theories/Reals/Cauchy_prod.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+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.
+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.
+Qed.
+
+(* 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
+    (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
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
new file mode 100644
index 00000000..422eb4a4
--- /dev/null
+++ b/theories/Reals/Cos_plus.v
@@ -0,0 +1,1061 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Require Import Cos_rel.
+Require Import Max. Open Local Scope nat_scope. Open Local Scope R_scope.
+
+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.
+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 =>
+            (-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.
+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 =>
+            (-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.
+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 ].
+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.
+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.
+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
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
new file mode 100644
index 00000000..9f76a5ad
--- /dev/null
+++ b/theories/Reals/Cos_rel.v
@@ -0,0 +1,420 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Open Local Scope R_scope.
+
+Definition A1 (x:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. 
+ 
+Definition B1 (x:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    N. 
+ 
+Definition C1 (x y:R) (N:nat) : R :=
+  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. 
+ 
+Definition Reste1 (x y:R) (N:nat) : R :=
+  sum_f_R0
+    (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).
+
+Definition Reste2 (x y:R) (N:nat) : R :=
+  sum_f_R0
+    (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).
+
+Definition Reste (x y:R) (N:nat) : R := 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 :
+ forall (x y:R) (n:nat),
+   (0 < n)%nat ->
+   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 in |- *.
+rewrite
+ (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
+    S n)).
+rewrite
+ (cauchy_finite
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
+ .
+unfold Reste in |- *.
+replace
+ (sum_f_R0
+    (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) ^ (S n - l) / INR (fact (2 * (S n - l))) *
+             y ^ (2 * (S n - l)))) (pred (S n - k))) (
+    pred (S n))) with (Reste1 x y (S n)).
+replace
+ (sum_f_R0
+    (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)) with (Reste2 x y n).
+ring.
+replace
+ (sum_f_R0
+    (fun k:nat =>
+       sum_f_R0
+         (fun p:nat =>
+            (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) *
+            ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p))))
+         k) (S n)) with
+ (sum_f_R0
+    (fun k:nat =>
+       (-1) ^ k / INR (fact (2 * k)) *
+       sum_f_R0
+         (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
+    (S n)).
+set
+ (sin_nnn :=
+  fun n:nat =>
+    match n with
+    | O => 0
+    | S p =>
+        (-1) ^ S p / INR (fact (2 * S p)) *
+        sum_f_R0
+          (fun l:nat =>
+             C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
+    end).
+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 (sum_f_R0 sin_nnn (S n)).
+rewrite <- sum_plus.
+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 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)).
+replace
+ (sum_f_R0
+    (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
+    (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)).
+replace
+ (sum_f_R0
+    (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.
+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 ].
+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 ].
+apply sum_eq; intros.
+rewrite Rmult_comm.
+unfold sin_nnn in |- *.
+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.
+replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with
+ (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))).
+replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
+replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
+replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
+ring.
+simpl in |- *.
+pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+rewrite pow_add.
+ring.
+symmetry  in |- *; apply le_plus_minus; assumption.
+unfold C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+rewrite Rmult_1_l.
+rewrite Rinv_mult_distr.
+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.
+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 in |- *.
+repeat rewrite <- Rmult_assoc.
+rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
+repeat rewrite <- Rmult_assoc.
+replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
+ (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
+replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
+ring.
+pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+rewrite pow_add.
+ring.
+symmetry  in |- *; apply le_plus_minus; assumption.
+unfold C in |- *.
+unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+rewrite <- Rinv_l_sym.
+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.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+apply INR_fact_neq_0.
+unfold Reste2 in |- *; apply sum_eq; intros.
+apply sum_eq; intros.
+unfold Rdiv in |- *; ring. 
+unfold Reste1 in |- *; apply sum_eq; intros.
+apply sum_eq; intros.
+unfold Rdiv in |- *; ring.
+apply lt_O_Sn.
+Qed.
+
+Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. 
+intros. 
+assert (H := pow_Rsqr x i).
+unfold Rsqr in H; exact H.
+Qed. 
+ 
+Lemma A1_cvg : forall 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 in |- *; unfold R_dist in |- *; intros. 
+elim (p eps H1); intros. 
+exists x1; intros. 
+unfold A1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
+ (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). 
+apply H2; assumption. 
+apply sum_eq. 
+intros. 
+replace ((x * x) ^ i) with (x ^ (2 * i)). 
+reflexivity. 
+apply pow_sqr. 
+unfold cos in |- *. 
+case (exist_cos (Rsqr x)). 
+unfold Rsqr in |- *; intros. 
+unfold cos_in in p_i. 
+unfold cos_in in c. 
+apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. 
+Qed. 
+ 
+Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (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 in |- *; unfold R_dist in |- *; intros. 
+elim (p eps H1); intros. 
+exists x1; intros. 
+unfold C1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
+ with
+ (sum_f_R0
+    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). 
+apply H2; assumption. 
+apply sum_eq. 
+intros. 
+replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). 
+reflexivity. 
+apply pow_sqr. 
+unfold cos in |- *. 
+case (exist_cos (Rsqr (x + y))). 
+unfold Rsqr in |- *; intros. 
+unfold cos_in in p_i. 
+unfold cos_in in c. 
+apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
+ assumption. 
+Qed. 
+ 
+Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). 
+intro. 
+case (Req_dec x 0); intro. 
+rewrite H. 
+rewrite sin_0. 
+unfold B1 in |- *. 
+unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
+    n) with 0. 
+unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. 
+induction  n as [| n Hrecn]. 
+simpl in |- *; ring. 
+rewrite tech5; rewrite <- Hrecn. 
+simpl in |- *; ring. 
+unfold ge in |- *; 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 in |- *; unfold R_dist in |- *; intros. 
+cut (0 < eps / Rabs x);
+ [ intro
+ | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. 
+elim (p (eps / Rabs x) H3); intros. 
+exists x1; intros. 
+unfold B1 in |- *. 
+replace
+ (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
+    n) with
+ (x *
+  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). 
+replace
+ (x *
+  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
+  x * x0) with
+ (x *
+  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
+   x0)); [ idtac | ring ]. 
+rewrite Rabs_mult. 
+apply Rmult_lt_reg_l with (/ Rabs x). 
+apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. 
+rewrite <- Rmult_assoc. 
+rewrite <- Rinv_l_sym. 
+rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
+ assumption. 
+apply Rabs_no_R0; assumption. 
+rewrite scal_sum. 
+apply sum_eq. 
+intros. 
+rewrite pow_add. 
+rewrite pow_sqr. 
+simpl in |- *. 
+ring. 
+unfold sin in |- *. 
+case (exist_sin (Rsqr x)). 
+unfold Rsqr in |- *; intros. 
+unfold sin_in in p_i. 
+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
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
new file mode 100644
index 00000000..f897e258
--- /dev/null
+++ b/theories/Reals/DiscrR.v
@@ -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        *)
+(************************************************************************)
+
+(*i        $Id: DiscrR.v,v 1.21.2.1 2004/07/16 19:31:10 herbelin Exp $       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 ].
+Qed.
+
+Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y.
+intros.
+apply Rlt_trans with x.
+assumption. 
+pattern x at 1 in |- *; rewrite <- Rplus_0_r.
+apply Rplus_lt_compat_l.
+assumption.
+Qed.
+
+Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
+intros; rewrite H; reflexivity.
+Qed.
+
+Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.
+intros; red in |- *; intro; elim H; apply eq_IZR; assumption.
+Qed.
+
+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 ]
+   end.
+
+Ltac prove_sup0 :=
+  match goal with
+  |  |- (0 < 1) => apply Rlt_0_1
+  |  |- (0 < ?X1) =>
+      repeat
+       (apply Rmult_lt_0_compat || apply Rplus_lt_pos;
+         try apply Rlt_0_1 || apply Rlt_R0_R2)
+  |  |- (?X1 > 0) => change (0 < X1) in |- *; 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 ].
+  
+Ltac prove_sup :=
+  match goal with
+  |  |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup
+  |  |- (0 < ?X1) => prove_sup0
+  |  |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup
+  |  |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup
+  |  |- (- ?X1 < ?X2) => apply Rlt_trans with 0; prove_sup
+  |  |- (?X1 < ?X2) => omega_sup
+  | _ => idtac
+  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
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
new file mode 100644
index 00000000..fcaeb11e
--- /dev/null
+++ b/theories/Reals/Exp_prop.v
@@ -0,0 +1,1011 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import PSeries_reg.
+Require Import Div2.
+Require Import Even.
+Require Import Max.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+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.
+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).
+
+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.
+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))))).
+
+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).
+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.
+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.
+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 ].
+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 =>
+            / 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.
+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 *
+  (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
+    (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.
+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.
+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.
+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.
+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.
+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).
+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
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
new file mode 100644
index 00000000..c3c3d9bb
--- /dev/null
+++ b/theories/Reals/Integration.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Export NewtonInt.
+Require Export RiemannInt_SF.
+Require Export RiemannInt.
\ No newline at end of file
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
new file mode 100644
index 00000000..baa61304
--- /dev/null
+++ b/theories/Reals/MVT.v
@@ -0,0 +1,699 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+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) ->
+    exists c : R,
+     (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).
+(*** 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).
+(*** 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).
+(*** 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).
+Qed.
+
+(* Corollaries ... *)
+Lemma MVT_cor1 :
+ 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.
+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)) ->
+    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.
+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)) ->
+    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 ] ] ].
+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 ->
+    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) ].
+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)).
+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 ].
+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.
+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.
+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 ].
+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.
+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.
+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.
+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)).
+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).
+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 ].
+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).
+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).
+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)).
+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.
+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)).
+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 ->
+    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.
+Qed.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
new file mode 100644
index 00000000..97cd4b94
--- /dev/null
+++ b/theories/Reals/NewtonInt.v
@@ -0,0 +1,788 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis. Open Local Scope R_scope.
+
+(*******************************************)
+(*            Newton's Integral            *)
+(*******************************************)
+
+Definition Newton_integrable (f:R -> R) (a b:R) : Type :=
+  sigT (fun 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 := match pr with
+           | 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 ] ].
+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.
+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.
+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.
+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.
+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
+        (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
+        (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.
+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.
+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.
+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.
+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
+        | 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 =>
+        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 =>
+        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 =>
+        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.
+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.
+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.
+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)).
+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.
+(* 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)).
+(* 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 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.
+(* 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.
+(*****************)
+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.
+(* 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 :
+ 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.
+(* 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)).
+(* 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)).
+(* 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)).
+(* 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_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 ].
+(* 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 ].
+Qed.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
new file mode 100644
index 00000000..0c19c8da
--- /dev/null
+++ b/theories/Reals/PSeries_reg.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:10 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Ranalysis1.
+Require Import Max.
+Require Import Even. Open Local Scope R_scope.
+
+Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
+
+(* Uniform convergence *)
+Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) 
+  (r:posreal) : Prop :=
+  forall eps:R,
+    0 < eps ->
+     exists N : nat,
+      (forall (n:nat) (y:R),
+         (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). 
+
+(* 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))).
+
+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
+               end.
+
+(* 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.
+Qed.
+
+(* 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 ].
+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.
+Qed.
+
+(* 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.
+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.
+Qed.
+
+(* 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 ].
+Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
new file mode 100644
index 00000000..13070bde
--- /dev/null
+++ b/theories/Reals/PartSum.v
@@ -0,0 +1,603 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import Rcomplete.
+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.
+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 ].
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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 ].
+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.
+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 ].
+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.
+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. 
+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.
+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 ].
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(* Cauchy's criterion for series *)
+Definition Cauchy_crit_series (An:nat -> R) : Prop :=
+  Cauchy_crit (fun N:nat => sum_f_R0 An N).
+
+(* 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.
+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 ].
+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.
+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 ] ].
+Qed.
+
+Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
+  sum_f_R0 (fun k:nat => fn k x) N.
+
+(**********)
+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).
+fold l1 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.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
new file mode 100644
index 00000000..a23f53ff
--- /dev/null
+++ b/theories/Reals/RIneq.v
@@ -0,0 +1,1631 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.23.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+(***************************************************************************)
+(**              Basic lemmas for the classical reals numbers              *)
+(***************************************************************************)
+
+Require Export Raxioms.
+Require Export ZArithRing.
+Require Import Omega.
+Require Export Field.
+
+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                                 *)
+(**************************************************************************)
+
+(**********)
+Lemma Rlt_irrefl : forall r, ~ r < r.
+  generalize Rlt_asym. intuition eauto.
+Qed.
+Hint Resolve Rlt_irrefl: real.
+
+Lemma Rle_refl : forall r, r <= r.
+intro; right; reflexivity.
+Qed.
+
+Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
+  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.
+Qed.
+
+(**********)
+Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2.
+generalize Rlt_not_eq Rgt_not_eq. intuition eauto.
+Qed.
+Hint Resolve Rlt_dichotomy_converse: real.
+
+(** Reasoning by case on equalities and order *)
+
+(**********)
+Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
+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.
+Qed.
+
+(**********)
+Lemma Rdichotomy : forall r1 r2, r1 <> r2 -> r1 < r2 \/ r1 > r2.
+intros; generalize (total_order_T r1 r2); tauto.
+Qed.
+
+
+(*********************************************************************************)
+(**       Order Lemma  : relating [<], [>], [<=] and [>=]  	                 *)
+(*********************************************************************************)
+
+(**********)
+Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
+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.
+Qed.
+
+Hint Immediate Rle_ge: real.
+
+(**********)
+Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1.
+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.
+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.
+Qed.
+
+(**********)
+Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
+generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *.
+intuition eauto 3.
+Qed.
+
+Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2.
+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.
+Qed.
+
+(**********)
+Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2.
+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.
+Qed.
+Hint Immediate Req_le: real.
+
+Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2.
+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.
+Qed.
+Hint Immediate Req_le_sym: real.
+
+Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2.
+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.
+Qed.
+Hint Resolve Rle_antisym: real.
+
+(**********)
+Lemma Rle_le_eq : forall r1 r2, r1 <= r2 /\ r2 <= r1 <-> r1 = r2.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********)
+Lemma Rgt_dec : forall r1 r2, {r1 > r2} + {~ r1 > r2}.
+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.
+Qed.
+
+Lemma Rlt_le_dec : forall r1 r2, {r1 < r2} + {r2 <= r1}.
+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.
+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.
+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.
+Qed.
+
+(****************************************************************)
+(**        Field Lemmas                                         *)
+(* This part contains lemma involving the Fields operations     *)
+(****************************************************************)
+(*********************************************************)
+(**      Addition                                        *)
+(*********************************************************)
+
+Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r.
+intro; split; ring.
+Qed.
+Hint Resolve Rplus_ne: real v62.
+
+Lemma Rplus_0_r : forall r, r + 0 = r.
+intro; ring.
+Qed.
+Hint Resolve Rplus_0_r: real.
+
+(**********)
+Lemma Rplus_opp_l : forall r, - r + r = 0.
+  intro; ring.
+Qed.
+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 ].
+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.
+  auto with real.
+Qed.
+
+(*i Old i*)Hint Resolve Rplus_eq_compat_l: v62.
+
+(**********)
+Lemma Rplus_eq_reg_l : forall r r1 r2, 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.
+Hint Resolve Rplus_eq_reg_l: real.
+
+(**********)
+Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0.
+  intros r b; pattern r at 2 in |- *; replace r with (r + 0); eauto with real.
+Qed.
+
+(***********************************************************)       
+(**       Multiplication                                   *)
+(***********************************************************)
+
+(**********)
+Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1.
+  intros; rewrite Rmult_comm; auto with real.
+Qed.
+Hint Resolve Rinv_r: real.
+
+Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r.
+  symmetry  in |- *; auto with real.
+Qed.
+
+Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r.
+  symmetry  in |- *; auto with real.
+Qed.
+Hint Resolve Rinv_l_sym Rinv_r_sym: real.
+
+
+(**********)
+Lemma Rmult_0_r : forall r, r * 0 = 0.
+intro; ring.
+Qed.
+Hint Resolve Rmult_0_r: real v62.
+
+(**********)
+Lemma Rmult_0_l : forall r, 0 * r = 0.
+intro; ring.
+Qed.
+Hint Resolve Rmult_0_l: real v62.
+
+(**********)
+Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r.
+intro; split; ring.
+Qed.
+Hint Resolve Rmult_ne: real v62.
+
+(**********)
+Lemma Rmult_1_r : forall r, r * 1 = r.
+intro; ring.
+Qed.
+Hint Resolve Rmult_1_r: real.
+
+(**********)
+Lemma Rmult_eq_compat_l : forall r r1 r2, r1 = r2 -> r * r1 = r * r2.
+  auto with real.
+Qed.
+
+(*i OLD i*)Hint Resolve Rmult_eq_compat_l: v62.
+
+(**********)
+Lemma Rmult_eq_reg_l : forall r r1 r2, 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 Rmult_integral : forall r1 r2, r1 * r2 = 0 -> r1 = 0 \/ r2 = 0.
+  intros; case (Req_dec r1 0); [ intro Hz | intro Hnotz ].
+  auto.
+  right; apply Rmult_eq_reg_l with r1; trivial.
+  rewrite H; auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_eq_0_compat : forall r1 r2, r1 = 0 \/ r2 = 0 -> r1 * r2 = 0.
+  intros r1 r2 [H| H]; rewrite H; auto with real.
+Qed.
+
+Hint Resolve Rmult_eq_0_compat: real.
+
+(**********)
+Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 = 0 -> r1 * r2 = 0.
+  auto with real.
+Qed.
+
+(**********)
+Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = 0 -> r1 * r2 = 0.
+  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.
+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.
+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.
+Qed.
+
+(** Square function *)
+
+(***********)
+Definition Rsqr r : R := r * r.
+
+(***********)
+Lemma Rsqr_0 : Rsqr 0 = 0.
+  unfold Rsqr in |- *; auto with real.
+Qed.
+
+(***********)
+Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0.
+unfold Rsqr in |- *; intros; elim (Rmult_integral r r H); trivial.
+Qed.
+
+(*********************************************************)
+(**      Opposite                                        *)
+(*********************************************************)
+
+(**********)
+Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2.
+  auto with real.
+Qed.
+Hint Resolve Ropp_eq_compat: real.
+
+(**********)
+Lemma Ropp_0 : -0 = 0.
+  ring.
+Qed.
+Hint Resolve Ropp_0: real v62.
+
+(**********)
+Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0.
+  intros; rewrite H; auto with real.
+Qed.
+Hint Resolve Ropp_eq_0_compat: real.
+
+(**********)
+Lemma Ropp_involutive : forall r, - - r = r.
+  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.
+Qed.
+Hint Resolve Ropp_neq_0_compat: real.
+
+(**********)
+Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2.
+  intros; ring.
+Qed.
+Hint Resolve Ropp_plus_distr: real.
+
+(** Opposite and multiplication *)
+
+Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2).
+  intros; ring.
+Qed.
+Hint Resolve Ropp_mult_distr_l_reverse: real.
+
+(**********)
+Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2.
+  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.
+Qed.
+
+(** Substraction *)
+
+Lemma Rminus_0_r : forall r, r - 0 = r.
+intro; ring.
+Qed.
+Hint Resolve Rminus_0_r: real.
+
+Lemma Rminus_0_l : forall r, 0 - r = - r.
+intro; ring.
+Qed.
+Hint Resolve Rminus_0_l: real.
+
+(**********)
+Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1.
+  intros; ring.
+Qed.
+Hint Resolve Ropp_minus_distr: real.
+
+Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2.
+intros; ring.
+Qed.
+Hint Resolve Ropp_minus_distr': real. 
+
+(**********)
+Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0.
+  intros; rewrite H; ring.
+Qed.
+Hint Resolve Rminus_diag_eq: real.
+
+(**********)
+Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2.
+  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.
+Qed.
+Hint Immediate Rminus_diag_uniq_sym: real.
+
+Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2.
+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.
+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.
+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.
+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.
+Qed.
+
+(** Inverse *)
+Lemma Rinv_1 : / 1 = 1.
+field; auto with real.
+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.
+Qed.
+Hint Resolve Rinv_neq_0_compat: real.
+
+(*********)
+Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r.
+intros; field; auto with real.
+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.
+Qed.
+
+(*********)
+Lemma Ropp_inv_permute : forall r, r <> 0 -> - / r = / - r.
+intros; field; auto with real.
+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.
+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.
+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.
+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.
+Qed.
+
+(** 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.
+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).
+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.
+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.
+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).
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Hint Immediate Rplus_lt_compat Rplus_le_compat Rplus_lt_le_compat
+  Rplus_le_lt_compat: real.
+
+(** 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.
+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.
+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.
+Qed.
+Hint Immediate Ropp_lt_cancel: real.
+
+Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********)
+Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0.
+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.
+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.
+Qed.
+Hint Resolve Ropp_0_ge_le_contravar: real.
+
+(** 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(** 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.
+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.
+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.
+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.
+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.
+Qed.
+Hint Immediate tech_Rplus: real.
+
+(** 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.
+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.
+Qed.
+Hint Resolve Rle_0_sqr Rlt_0_sqr: real.
+
+(** 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.
+Qed.
+Hint Resolve Rlt_0_1: real.
+
+Lemma Rle_0_1 : 0 <= 1.
+left.
+exact Rlt_0_1.
+Qed.
+
+(** 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.
+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.
+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.
+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.
+Qed.
+Hint Resolve Rinv_1_lt_contravar: real.
+
+(*********************************************************)        
+(**      Greater                                         *)
+(*********************************************************)
+
+(**********)
+Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2.
+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.
+Qed.
+
+(**********)
+Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1.
+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).
+Qed.
+
+(**********)
+Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(***********)
+Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2.
+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).
+Qed.
+
+(***********)
+Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2.
+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.
+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.
+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.
+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.
+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).
+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.
+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.
+Qed.
+
+(*********)
+Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2.
+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.
+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.
+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.
+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.
+Qed.
+
+
+(**********************************************************) 
+(**       Injection from [N] to [R]                       *)
+(**********************************************************)
+
+(**********)
+Lemma S_INR : forall n:nat, INR (S n) = INR n + 1.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+Hint Resolve not_1_INR: real.
+
+(**********************************************************) 
+(**      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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********)
+Lemma Ropp_Ropp_IZR : forall n:Z, IZR (- n) = - IZR n.
+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.
+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.
+Qed.
+
+(**********)
+Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
+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 : 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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 : 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.
+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).
+Qed.
+
+Lemma double : forall r1, 2 * r1 = r1 + r1.
+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 ].
+Qed.
+
+(**********************************************************)
+(** 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 ].
+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 ].
+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.
+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 ].
+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 ].
+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 ].
+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 ] ].
+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 ].
+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.
+Qed.
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
new file mode 100644
index 00000000..3b58c02f
--- /dev/null
+++ b/theories/Reals/RList.v
@@ -0,0 +1,744 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:11 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Open Local Scope R_scope.
+
+Inductive Rlist : Type :=
+  | 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'
+  end.
+
+Fixpoint Rlength (l:Rlist) : nat :=
+  match l with
+  | nil => 0%nat
+  | cons a l' => S (Rlength l')
+  end.
+
+Fixpoint MaxRlist (l:Rlist) : R :=
+  match l with
+  | nil => 0
+  | cons a l1 =>
+      match l1 with
+      | nil => a
+      | cons a' l2 => Rmax a (MaxRlist l1)
+      end
+  end.
+
+Fixpoint MinRlist (l:Rlist) : R :=
+  match l with
+  | nil => 1
+  | cons a l1 =>
+      match l1 with
+      | 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.
+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)
+  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.
+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.
+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.
+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.
+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.
+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
+  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 ] ].
+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 ].
+Qed.
+
+Lemma Rlist_P1 :
+ 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.
+Qed.
+
+Definition ordered_Rlist (l:Rlist) : Prop :=
+  forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <= pos_Rl l (S i).
+
+Fixpoint insert (l:Rlist) (x:R) {struct l} : Rlist :=
+  match l with
+  | nil => cons x nil
+  | cons a l' =>
+      match Rle_dec a x with
+      | 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)
+  end.
+
+Fixpoint cons_ORlist (k l:Rlist) {struct k} : Rlist :=
+  match k with
+  | 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)
+  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)
+  end.
+
+Definition Rtail (l:Rlist) : Rlist :=
+  match l with
+  | 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
+  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 ] ].
+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) ].
+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 ].
+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 ] ].
+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) ].
+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 ] ] ] ].
+Qed.
+
+Lemma RList_P6 :
+ 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 ].
+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) ].
+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 ].
+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 ].
+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 ] ].
+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 ].
+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 ] ].
+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.
+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 ].
+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 ] ] ].
+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)
+          (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) ] ].
+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 ].
+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 ].
+Qed.
+
+Lemma RList_P20 :
+ 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 ] ].
+Qed.
+
+Lemma RList_P21 : forall l l':Rlist, l = l' -> Rtail l = Rtail l'.
+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 ].
+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 ].
+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 ].
+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.
+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.
+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 ].
+Qed.
+
+Lemma RList_P28 : forall l:Rlist, cons_Rlist l nil = l.
+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 ].
+Qed.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
new file mode 100644
index 00000000..289b1921
--- /dev/null
+++ b/theories/Reals/R_Ifp.v
@@ -0,0 +1,545 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(**********************************************************)
+(** Complements for the reals.Integer and fractional part *)
+(*                                                        *)
+(**********************************************************)
+
+Require Import Rbase.
+Require Import Omega.
+Open Local Scope R_scope.
+
+(*********************************************************)
+(**      Fractional part                                 *)
+(*********************************************************)
+
+(**********)
+Definition Int_part (r:R) : Z := (up r - 1)%Z.
+
+(**********)
+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.
+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.
+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.
+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.
+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.
+     (*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.
+    (*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.
+Qed.
+
+(*********************************************************)
+(**      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.  
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
new file mode 100644
index 00000000..0abf9064
--- /dev/null
+++ b/theories/Reals/R_sqr.v
@@ -0,0 +1,330 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rbasic_fun. Open Local Scope R_scope.
+
+(****************************************************)
+(* Rsqr : some results                              *)
+(****************************************************)
+
+Ltac ring_Rsqr := unfold Rsqr in |- *; ring.
+
+Lemma Rsqr_neg : forall x:R, Rsqr x = Rsqr (- x).
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_mult : forall x y:R, Rsqr (x * y) = Rsqr x * Rsqr y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_plus : forall x y:R, Rsqr (x + y) = Rsqr x + Rsqr y + 2 * x * y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_minus : forall x y:R, Rsqr (x - y) = Rsqr x + Rsqr y - 2 * x * y.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_neg_minus : forall x y:R, Rsqr (x - y) = Rsqr (y - x).
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_1 : Rsqr 1 = 1.
+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).
+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 ] ].
+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.
+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.
+Qed.
+
+Lemma Rsqr_minus_plus : forall a b:R, (a - b) * (a + b) = Rsqr a - Rsqr b.
+intros; ring_Rsqr.
+Qed.
+
+Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b.
+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 ] ].
+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 ] ].
+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.
+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) ] ].
+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.
+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 ].
+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.
+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.
+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 ].
+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 ].
+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)).
+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 ].
+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)).
+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.
+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.
+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.
+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 ] ].
+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 ].
+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 ].
+Qed.
+
+Lemma Rsqr_inv : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x.
+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).
+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
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
new file mode 100644
index 00000000..660b0527
--- /dev/null
+++ b/theories/Reals/R_sqrt.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:12 herbelin Exp $ 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 *)
+Definition sqrt (x:R) : R :=
+  match Rcase_abs x with
+  | 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.
+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.
+Qed.
+
+Lemma sqrt_0 : sqrt 0 = 0.
+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.
+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.
+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).
+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) ].
+Qed.
+
+Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
+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)).
+Qed.
+
+Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x.
+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.
+Qed.
+
+Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x.
+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) ].
+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)) ].
+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) ] ].
+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.
+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) ].
+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.
+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) ].
+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.
+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).
+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).
+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
+          (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 - 2 * a * b * c * d)
+                 with (Rsqr (a * d - b * c));
+                [ apply Rle_0_sqr | unfold Rsqr in |- *; 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 ].
+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 :
+ 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.
+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
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
new file mode 100644
index 00000000..88af8b20
--- /dev/null
+++ b/theories/Reals/Ranalysis.v
@@ -0,0 +1,802 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rtrigo.
+Require Import 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. Open Local Scope R_scope.
+
+Axiom AppVar : R.
+
+(**********)
+Ltac intro_hyp_glob trm :=
+  match constr:trm with
+  | (?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
+      end
+  | (?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
+      end
+  | (?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
+      end
+  | (?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
+      |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+      |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+      | _ => idtac
+      end
+  | (- ?X1)%F =>
+      match goal with
+      |  |- (derivable _) => intro_hyp_glob X1
+      |  |- (continuity _) => intro_hyp_glob X1
+      | _ => idtac
+      end
+  | (/ ?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 =>
+      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
+  end.
+
+(**********)
+Ltac intro_hyp_pt trm pt :=
+  match constr:trm with
+  | (?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 _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?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 _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?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 _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+      | _ => idtac
+      end
+  | (?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
+      |  |- (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 _ _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+          (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
+      end
+  | (- ?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
+      end
+  | (/ ?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
+      |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
+      |  |- (continuity_pt _ _) =>
+          cut (0 <= pt); [ intro | try assumption ]
+      |  |- (derive_pt _ _ _ = _) =>
+          cut (0 < pt); [ intro | try assumption ]
+      | _ => idtac
+      end
+  | Rabs =>
+      match goal with
+      |  |- (derivable_pt _ _) =>
+          cut (pt <> 0); [ intro | try assumption ]
+      | _ => idtac
+      end
+  | ?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
+  end.
+ 
+(**********)
+Ltac is_diff_pt :=
+  match goal with
+  |  |- (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 _) _) =>
+      unfold pow_fct in |- *; apply derivable_pt_pow
+  |  |- (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) =>
+      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 |- *
+        (* regles de differentiabilite *)
+        (* PLUS *)
+  |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
+      apply (derivable_pt_plus X1 X2 X3); is_diff_pt
+       (* MOINS *)
+  |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
+      apply (derivable_pt_minus X1 X2 X3); is_diff_pt
+       (* OPPOSE *)
+  |  |- (derivable_pt (- ?X1) ?X2) =>
+      apply (derivable_pt_opp X1 X2);
+       is_diff_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (derivable_pt_scal X2 X1 X3); is_diff_pt
+       (* MULTIPLICATION *)
+  |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
+      apply (derivable_pt_mult X1 X2 X3); is_diff_pt
+       (* DIVISION *)
+  |  |- (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) =>
+      
+       (* INVERSION *)
+       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) =>
+      
+       (* COMPOSITION *)
+       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) =>
+      cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+  |  |- (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 |- *
+  end.
+
+(**********)
+Ltac is_diff_glob :=
+  match goal with
+  |  |- (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 _)) =>
+      unfold pow_fct in |- *;
+       apply derivable_pow
+        (* regles de differentiabilite *)
+        (* PLUS *)
+  |  |- (derivable (?X1 + ?X2)) =>
+      apply (derivable_plus X1 X2); is_diff_glob
+       (* MOINS *)
+  |  |- (derivable (?X1 - ?X2)) =>
+      apply (derivable_minus X1 X2); is_diff_glob
+       (* OPPOSE *)
+  |  |- (derivable (- ?X1)) =>
+      apply (derivable_opp X1);
+       is_diff_glob
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
+      apply (derivable_scal X2 X1); is_diff_glob
+       (* MULTIPLICATION *)
+  |  |- (derivable (?X1 * ?X2)) =>
+      apply (derivable_mult X1 X2); is_diff_glob
+       (* DIVISION *)
+  |  |- (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)) =>
+      
+       (* INVERSION *)
+       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 _)) =>
+      
+       (* COMPOSITION *)
+       unfold derivable in |- *; intro; try is_diff_pt
+  |  |- (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 _) =>
+      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 |- *
+  end.
+
+(**********)
+Ltac is_cont_pt :=
+  match goal with
+  |  |- (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_id X1)
+  |  |- (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 in |- *; apply derivable_continuous_pt;
+       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) =>
+      apply (Rcontinuity_abs X1)
+       (* regles de differentiabilite *)
+       (* PLUS *)
+  |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
+      apply (continuity_pt_plus X1 X2 X3); is_cont_pt
+       (* MOINS *)
+  |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
+      apply (continuity_pt_minus X1 X2 X3); is_cont_pt
+       (* OPPOSE *)
+  |  |- (continuity_pt (- ?X1) ?X2) =>
+      apply (continuity_pt_opp X1 X2);
+       is_cont_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (continuity_pt_scal X2 X1 X3); is_cont_pt
+       (* MULTIPLICATION *)
+  |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
+      apply (continuity_pt_mult X1 X2 X3); is_cont_pt
+       (* DIVISION *)
+  |  |- (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) =>
+      
+       (* 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) =>
+      
+       (* COMPOSITION *)
+       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) =>
+      cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+  | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      apply derivable_continuous_pt; assumption
+  | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
+      cut (continuity X1);
+       [ 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 |- *
+  end.
+
+(**********)
+Ltac is_cont_glob :=
+  match goal with
+  |  |- (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_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 in |- *; apply derivable_continuous; apply derivable_pow
+  |  |- (continuity sinh) =>
+      apply derivable_continuous; apply derivable_sinh
+  |  |- (continuity cosh) =>
+      apply derivable_continuous; apply derivable_cosh
+  |  |- (continuity Rabs) =>
+      apply Rcontinuity_abs
+       (* regles de continuite *)
+       (* PLUS *)
+  |  |- (continuity (?X1 + ?X2)) =>
+      apply (continuity_plus X1 X2);
+       try is_cont_glob || assumption
+            (* MOINS *)
+  |  |- (continuity (?X1 - ?X2)) =>
+      apply (continuity_minus X1 X2);
+       try is_cont_glob || assumption
+            (* OPPOSE *)
+  |  |- (continuity (- ?X1)) =>
+      apply (continuity_opp X1); try is_cont_glob || assumption
+                                      (* INVERSE *)
+  |  |- (continuity (/ ?X1)) =>
+      apply (continuity_inv X1);
+       try is_cont_glob || assumption
+            (* MULTIPLICATION PAR UN SCALAIRE *)
+  |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
+      apply (continuity_scal X2 X1);
+       try is_cont_glob || assumption
+            (* MULTIPLICATION *)
+  |  |- (continuity (?X1 * ?X2)) =>
+      apply (continuity_mult X1 X2);
+       try is_cont_glob || assumption
+            (* DIVISION *)
+  |  |- (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 _)) =>
+      
+       (* COMPOSITION *)
+       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 _) =>
+      intro HypTruE; clear HypTruE; is_cont_glob
+  | _:(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 |- *
+  end.
+
+(**********)
+Ltac rew_term trm :=
+  match constr:trm with
+  | (?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
+      | _ => constr:(p1 + p2)%F
+      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
+      | _ => constr:(p1 - p2)%F
+      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) =>
+      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) =>
+      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
+      | _ => constr:(p1 * p2)%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) =>
+      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) =>
+      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) =>
+      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)
+  end.
+
+(**********)
+Ltac deriv_proof trm pt :=
+  match constr:trm with
+  | (?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 =>
+      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 =>
+      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 =>
+      match goal with
+      | 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
+      end
+  | (/ ?X1)%F =>
+      match goal with
+      | id:(?X1 pt <> 0) |- _ =>
+          let p1 := deriv_proof X1 pt in
+          constr:(derivable_pt_inv X1 pt p1 id)
+      | _ => constr:False
+      end
+  | (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 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 =>
+      match goal with
+      | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
+      | _ => constr:False
+      end
+  | (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
+  end.
+
+(**********)
+Ltac simplify_derive trm pt :=
+  match constr:trm with
+  | (?X1 + ?X2)%F =>
+      try rewrite derive_pt_plus; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 - ?X2)%F =>
+      try rewrite derive_pt_minus; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 * ?X2)%F =>
+      try rewrite derive_pt_mult; simplify_derive X1 pt;
+       simplify_derive X2 pt
+  | (?X1 / ?X2)%F =>
+      try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
+  | (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_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 =>
+      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
+  end.
+
+(**********)
+Ltac reg :=
+  match goal with
+  |  |- (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 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 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 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 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
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
new file mode 100644
index 00000000..918ebfc0
--- /dev/null
+++ b/theories/Reals/Ranalysis1.v
@@ -0,0 +1,1479 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.21.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Export Rlimit.
+Require Export Rderiv. Open Local Scope R_scope.
+Implicit Type f : R -> R.
+
+(****************************************************)
+(**           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.
+Definition mult_fct f1 f2 (x:R) : R := f1 x * f2 x.
+Definition mult_real_fct (a:R) f (x:R) : R := a * f x.
+Definition minus_fct f1 f2 (x:R) : R := f1 x - f2 x.
+Definition div_fct f1 f2 (x:R) : R := f1 x / f2 x.
+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.
+
+Infix "+" := plus_fct : Rfun_scope.
+Notation "- x" := (opp_fct x) : Rfun_scope.
+Infix "*" := mult_fct : Rfun_scope.
+Infix "-" := minus_fct : Rfun_scope.
+Infix "/" := div_fct : Rfun_scope.
+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              *)
+(****************************************************)
+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.
+
+(**********)
+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 continuity_pt f (x0:R) : Prop := continue_in f no_cond x0.
+Definition continuity f : Prop := forall x:R, continuity_pt f x.
+
+Arguments Scope continuity_pt [Rfun_scope R_scope].
+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.
+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.
+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.
+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.
+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 ].
+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.
+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.
+ 
+Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F.
+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 ].
+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.
+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)).
+Qed.
+
+Lemma continuity_opp : forall f, continuity f -> continuity (- f).
+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)).
+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)).
+Qed.
+
+Lemma continuity_const : forall f, constant f -> continuity f.
+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)).
+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)).
+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)).
+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))).
+Qed.
+
+
+(*****************************************************)
+(**  Derivative's definition using Landau's kernel   *)
+(*****************************************************)
+
+Definition derivable_pt_lim f (x l:R) : Prop :=
+  forall eps:R,
+    0 < eps ->
+     exists delta : posreal,
+      (forall h:R,
+         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.
+
+Definition derivable_pt f (x:R) := sigT (derivable_pt_abs f x).
+Definition derivable f := forall x:R, derivable_pt f x.
+
+Definition derive_pt f (x:R) (pr:derivable_pt f x) := projT1 pr.
+Definition derive f (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 :=
+  (forall x:R,
+     a <= x <= b ->  exists 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 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. 
+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 ].
+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 ].
+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.
+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.
+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).
+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).
+Qed.
+
+
+(********************************************************************)
+(** 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.
+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.
+Qed.
+
+
+(***********************************)
+(**   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.
+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.
+Qed.
+
+Theorem derivable_continuous : forall f, derivable f -> continuity f.
+unfold derivable, continuity in |- *; intros.
+apply (derivable_continuous_pt f x (X x)).
+Qed.
+
+(****************************************************************)
+(**                      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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma derivable_pt_id : forall x:R, derivable_pt id x.
+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.
+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.
+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 _)).
+Qed.
+
+Lemma derivable_opp : forall f, derivable f -> derivable (- f).
+unfold derivable in |- *; intros.
+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 _)).
+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 _)).
+Qed.
+
+Lemma derivable_const : forall a:R, derivable (fct_cte a).
+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 _)).
+Qed.
+
+Lemma derivable_id : derivable id.
+unfold derivable in |- *; intro; apply derivable_pt_id.
+Qed.
+
+Lemma derivable_Rsqr : derivable Rsqr.
+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 _)).
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
+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.
+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).
+Qed.
+
+
+(************************************************************)
+(**             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 +
+      -
+      ((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) 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
+  (-
+   (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 + 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.
+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.
+ 
+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).
+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.
+Qed.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
new file mode 100644
index 00000000..35f7eab8
--- /dev/null
+++ b/theories/Reals/Ranalysis2.v
@@ -0,0 +1,450 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+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.
+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.
+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,
+      h <> 0 ->
+      Rabs h < alp_f1d ->
+      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
+   (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.
+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,
+      Rabs a < alp_f2t2 ->
+      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
+   (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.
+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,
+      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,
+      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.
+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,
+      Rabs a < alp_f2c ->
+      Rabs (f2 (x + a) - f2 x) <
+      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
+   (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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
+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.
+Qed.
+
+(**********)
+Lemma continuous_neq_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
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
new file mode 100644
index 00000000..9f85b00a
--- /dev/null
+++ b/theories/Reals/Ranalysis3.v
@@ -0,0 +1,793 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import Ranalysis2. Open Local Scope R_scope.
+
+(* 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.
+(***********************************)
+(*              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.
+(***********************************)
+(*              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 ].
+(***********************************)
+(*              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).
+(***********************************)
+(*              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.
+(***********************************)
+(*              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)).
+(***********************************)
+(*              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.
+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.
+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)).
+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
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
new file mode 100644
index 00000000..86f49cd4
--- /dev/null
+++ b/theories/Reals/Ranalysis4.v
@@ -0,0 +1,384 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.19.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import Ranalysis3.
+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.
+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.
+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.
+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).
+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.
+Qed.
+
+(* 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.
+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.
+Qed.
+
+(* 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).
+Qed.
+
+(* 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).
+Qed.
+
+(* 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.
+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 ].
+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.
+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.
+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.
+Qed.
+
+(* 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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma derivable_exp : derivable exp.
+unfold derivable in |- *; apply derivable_pt_exp.
+Qed.
+
+Lemma derivable_cosh : derivable cosh.
+unfold derivable in |- *; apply derivable_pt_cosh.
+Qed.
+
+Lemma derivable_sinh : derivable sinh.
+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.
+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.
+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
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
new file mode 100644
index 00000000..bef9f89c
--- /dev/null
+++ b/theories/Reals/Raxioms.v
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.20.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**    Axiomatisation of the classical reals             *)
+(*********************************************************)
+
+Require Export ZArith_base.
+Require Export Rdefinitions.
+Open Local Scope R_scope.
+
+(*********************************************************)
+(*               Field axioms                            *)
+(*********************************************************)
+
+(*********************************************************)
+(**      Addition                                        *)
+(*********************************************************)
+
+(**********)
+Axiom Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1.
+Hint Resolve Rplus_comm: real.
+
+(**********)
+Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3).
+Hint Resolve Rplus_assoc: real.
+
+(**********)
+Axiom Rplus_opp_r : forall r:R, r + - r = 0.
+Hint Resolve Rplus_opp_r: real v62.
+
+(**********)
+Axiom Rplus_0_l : forall r:R, 0 + r = r.
+Hint Resolve Rplus_0_l: real.
+
+(***********************************************************)       
+(**       Multiplication                                   *)
+(***********************************************************)
+
+(**********)
+Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
+Hint Resolve Rmult_comm: real v62. 
+
+(**********)
+Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3).
+Hint Resolve Rmult_assoc: real v62.
+
+(**********)
+Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1.
+Hint Resolve Rinv_l: real.
+
+(**********)
+Axiom Rmult_1_l : forall r:R, 1 * r = r.
+Hint Resolve Rmult_1_l: real.
+
+(**********)
+Axiom R1_neq_R0 : 1 <> 0.
+Hint Resolve R1_neq_R0: real.
+
+(*********************************************************)
+(**      Distributivity                                  *)
+(*********************************************************)
+
+(**********)
+Axiom
+  Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3.
+Hint Resolve Rmult_plus_distr_l: real v62.
+
+(*********************************************************)
+(**      Order axioms                                    *)
+(*********************************************************)
+(*********************************************************)
+(**      Total Order                                     *)
+(*********************************************************)
+
+(**********)
+Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}.
+
+(*********************************************************)
+(**      Lower                                           *)
+(*********************************************************)
+
+(**********)
+Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1.
+
+(**********)
+Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3.
+
+(**********)
+Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2.
+
+(**********)
+Axiom
+  Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2.
+
+Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real.
+
+(**********************************************************) 
+(**      Injection from N to R                            *)
+(**********************************************************)
+
+(**********)
+Fixpoint INR (n:nat) : R :=
+  match n with
+  | O => 0
+  | S O => 1
+  | S n => INR n + 1
+  end.  
+Arguments Scope INR [nat_scope].
+
+
+(**********************************************************) 
+(**      Injection from [Z] to [R]                        *)
+(**********************************************************)
+
+(**********)
+Definition IZR (z:Z) : R :=
+  match z with
+  | Z0 => 0
+  | Zpos n => INR (nat_of_P n)
+  | Zneg n => - INR (nat_of_P n)
+  end.  
+Arguments Scope IZR [Z_scope].
+
+(**********************************************************)
+(**      [R] Archimedian                                  *)
+(**********************************************************)
+
+(**********)
+Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1.
+
+(**********************************************************)
+(**      [R] Complete                                     *)
+(**********************************************************)
+
+(**********)
+Definition is_upper_bound (E:R -> Prop) (m:R) := forall x:R, E x -> x <= m.
+
+(**********)
+Definition bound (E:R -> Prop) :=  exists m : R, is_upper_bound E m.
+
+(**********)
+Definition is_lub (E:R -> Prop) (m:R) :=
+  is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b).
+
+(**********)
+Axiom
+  completeness :
+    forall E:R -> Prop,
+      bound E -> (exists x : R, E x) -> sigT (fun m:R => is_lub E m).
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
new file mode 100644
index 00000000..773819a2
--- /dev/null
+++ b/theories/Reals/Rbase.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Rbase.v,v 1.39.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Export Rdefinitions.
+Require Export Raxioms.
+Require Export RIneq.
+Require Export DiscrR.
\ No newline at end of file
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
new file mode 100644
index 00000000..49ba48f7
--- /dev/null
+++ b/theories/Reals/Rbasic_fun.v
@@ -0,0 +1,470 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.22.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**          Complements for the real numbers            *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import R_Ifp.
+Require Import Fourier. Open Local Scope R_scope.
+
+Implicit Type r : R.
+
+(*******************************)
+(**          Rmin              *)
+(*******************************)
+
+(*********)
+Definition Rmin (x y:R) : R :=
+  match Rle_dec x y with
+  | 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.
+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.
+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).
+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 ].
+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 ].
+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).
+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) ].
+Qed.
+
+(*******************************)
+(**          Rmax              *)
+(*******************************)
+
+(*********)
+Definition Rmax (x y:R) : R :=
+  match Rle_dec x y with
+  | 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)).
+Qed.
+
+Lemma RmaxLess1 : forall r1 r2, r1 <= Rmax r1 r2.
+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.
+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.
+Qed.
+
+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.
+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) ].
+Qed.
+
+(*******************************)
+(**          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).
+Qed.
+
+(*********)
+Definition Rabs r : R :=
+  match Rcase_abs r with
+  | 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.
+Qed.
+
+Lemma Rabs_R1 : Rabs 1 = 1.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma RRle_abs : forall x:R, x <= Rabs x.
+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 ].
+Qed.
+
+(*********)
+Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
+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.
+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.
+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.
+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.
+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.
+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.
+(**)
+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.
+(**)
+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.
+(**)
+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).
+(**)
+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.
+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 ] ]. 
+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.
+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.
+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.
+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.
+Qed.
+ 
\ No newline at end of file
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
new file mode 100644
index 00000000..dd8379cb
--- /dev/null
+++ b/theories/Reals/Rcomplete.v
@@ -0,0 +1,198 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import Max.
+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 :
+ 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
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
new file mode 100644
index 00000000..33f494df
--- /dev/null
+++ b/theories/Reals/Rdefinitions.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+
+(*********************************************************)
+(**          Definitions for the axiomatization          *)
+(*                                                       *)
+(*********************************************************)
+
+Require Export ZArith_base.
+
+Parameter R : Set.
+
+(* Declare Scope positive_scope with Key R *)
+Delimit 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.
+
+Infix "+" := Rplus : R_scope.
+Infix "*" := Rmult : R_scope.
+Notation "- x" := (Ropp x) : R_scope.
+Notation "/ x" := (Rinv x) : R_scope.
+
+Infix "<" := Rlt : R_scope.
+
+(*i*******************************************************i*)
+
+(**********)
+Definition Rgt (r1 r2:R) : Prop := (r2 < r1)%R.
+
+(**********)
+Definition Rle (r1 r2:R) : Prop := (r1 < r2)%R \/ r1 = r2.
+
+(**********)
+Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.
+
+(**********)
+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.
+
+Infix "<=" := Rle : R_scope.
+Infix ">=" := Rge : R_scope.
+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
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
new file mode 100644
index 00000000..81db80ab
--- /dev/null
+++ b/theories/Reals/Rderiv.v
@@ -0,0 +1,431 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.15.2.1 2004/07/16 19:31:12 herbelin Exp $ i*)
+
+(*********************************************************)
+(**     Definition of the derivative,continuity          *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rlimit.
+Require Import Fourier.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type.
+Require Import Omega. Open Local Scope R_scope.
+
+(*********)
+Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x.
+
+(*********)
+Definition continue_in (f:R -> R) (D:R -> Prop) (x0:R) : Prop :=
+  limit1_in f (D_x D x0) (f x0) x0.
+
+(*********)
+Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop :=
+  limit1_in (fun x:R => (f x - f x0) / (x - x0)) (D_x D x0) (d x0) x0.
+
+(*********)
+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.
+(**)
+ 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.
+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.
+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.
+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.
+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.
+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.
+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. 
+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.
+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)).
+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 ].
+Qed.
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
new file mode 100644
index 00000000..5e4b3e7b
--- /dev/null
+++ b/theories/Reals/Reals.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Reals.v,v 1.24.2.1 2004/07/16 19:31:12 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.
\ No newline at end of file
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
new file mode 100644
index 00000000..cdff9fcb
--- /dev/null
+++ b/theories/Reals/Rfunctions.v
@@ -0,0 +1,801 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.31.2.1 2004/07/16 19:31:12 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 Import Rbase.
+Require Export R_Ifp.
+Require Export Rbasic_fun.
+Require Export R_sqr.
+Require Export SplitAbsolu.
+Require Export SplitRmult.
+Require Export ArithProp.
+Require Import Omega.
+Require Import Zpower.
+Open Local Scope nat_scope.
+Open Local Scope R_scope.
+
+(*******************************)
+(**  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.
+Qed.    
+
+(*********)
+Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat.
+Proof.
+intro; reflexivity.
+Qed. 
+
+(*********)
+Lemma simpl_fact :
+ 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.
+Qed.
+
+(*******************************)
+(*          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.
+Qed.
+ 
+Lemma pow_1 : forall x:R, x ^ 1 = x.
+Proof.
+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.
+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.
+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.
+Proof.
+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.
+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.
+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.
+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.
+Qed.
+
+(*********)
+Lemma tech_pow_Rplus :
+ 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.
+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.
+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.
+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.
+Qed.
+
+
+Lemma Pow_x_infinity :
+ 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.
+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.
+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.
+Qed.
+
+Lemma pow_lt_1_zero :
+ 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.
+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.
+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.
+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.
+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 ].
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma Rle_pow :
+ 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.
+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.
+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.
+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 ].
+Qed.
+
+(*******************************)
+(**         PowerRZ            *)
+(*******************************)
+(*i Due to L.Thery i*)
+
+Ltac case_eq name :=
+  generalize (refl_equal name); pattern name at -1 in |- *; case 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
+  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.
+Proof.
+induction n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith.
+Qed.
+
+Lemma powerRZ_O : forall x:R, x ^Z 0 = 1.
+Proof.
+reflexivity.
+Qed.
+ 
+Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
+Proof.
+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.
+Qed.
+ 
+Lemma powerRZ_add :
+ 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.
+(* POS/POS *)
+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.
+(* 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.
+(* 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.
+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.
+ 
+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.
+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.
+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.
+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.
+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.
+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    *)
+(*******************************)
+(*********)
+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
+  end.
+
+(*********)
+Definition sum_nat_f (s n:nat) (f:nat -> nat) : nat :=
+  sum_nat_f_O (fun x:nat => f (x + s)%nat) (n - s).
+
+(*********)
+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             *)
+(*******************************)
+(*********)
+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)
+  end.
+
+(*********)
+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.
+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.
+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.
+Qed.
+
+(*******************************)
+(*        Distance  in R       *)
+(*******************************)
+
+(*********)
+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.
+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.
+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). 
+Qed.
+
+Lemma R_dist_eq : forall x:R, R_dist x x = 0.
+Proof.
+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 ].
+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.
+Proof.
+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          *)
+(*******************************)
+(*********)
+Definition infinit_sum (s:nat -> R) (l:R) : Prop :=
+  forall eps:R,
+    eps > 0 ->
+     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
new file mode 100644
index 00000000..a01e7b52
--- /dev/null
+++ b/theories/Reals/Rgeom.v
@@ -0,0 +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: Rgeom.v,v 1.13.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import R_sqrt. Open Local Scope R_scope.
+
+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 ] ] ].
+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.
+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.
+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
+          (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 (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 Rmult_le_compat_l;
+                   [ left; cut (0%nat <> 2%nat);
+                      [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
+                         intro H0; assumption
+                      | discriminate ]
+                   | apply sqrt_cauchy ]
+                | ring ]
+             | ring ]
+          | 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 ].
+Qed.
+
+(******************************************************************)
+(**                         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.
+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.
+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 : 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.
+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.
+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 ].
+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.
+Qed.
+
+(******************************************************************)
+(**                         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.
+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
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
new file mode 100644
index 00000000..51323ac4
--- /dev/null
+++ b/theories/Reals/RiemannInt.v
@@ -0,0 +1,3263 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.18.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Ranalysis.
+Require Import Rbase.
+Require Import RiemannInt_SF.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type.
+Require Import Max. Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+(********************************************)
+(*            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)).
+
+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))).
+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.
+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 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.
+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 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.
+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)) ].
+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
+  (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;
+    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;
+    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
+              (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
+    (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;
+    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;
+    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 ].
+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 ].
+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).
+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'
+  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 ].
+Qed.
+
+(**************************************)
+(* 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) ] ].
+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)
+  end.
+
+Definition max_N (a b:R) (del:posreal) (h:a < b) : nat :=
+  match maxN del h with
+  | 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 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.
+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)).
+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.
+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 ] ].
+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 ].
+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 ] ] ].
+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.
+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.
+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).
+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 ] ].
+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 ].
+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;
+    rewrite <- Rinv_r_sym.
+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;
+    elim (Rlt_irrefl _ 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.
+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).
+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)) ].
+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 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));
+    [ 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)).
+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 ].
+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) ].
+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 ].
+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 t:R,
+         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 t:R,
+         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
+          (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
+    (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 ].
+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
+  (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)
+          (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
+    (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 ]. 
+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 ] ].
+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) ].
+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.
+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 ].
+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 ].
+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);
+ 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.
+fold phi1 in u0;
+ 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.
+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 ].
+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 ].
+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 =>
+      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))
+      end
+  | 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 ].
+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 ] ].
+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.
+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.
+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.
+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)) +
+  (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);
+ fold phi1 in H8; set (phi2 := phi_sequence RinvN pr2 n); 
+ fold phi2 in H3; set (phi3 := phi_sequence RinvN pr3 n); 
+ fold phi2 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.
+fold phi3 in H1; 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 ].
+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
+          (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
+    (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
+        (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;
+    [ 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 ].
+(*****)
+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.
+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 ].
+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.
+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.
+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) ] ].
+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 ] ].
+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 ] ].
+Qed.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
new file mode 100644
index 00000000..0ae8f9f2
--- /dev/null
+++ b/theories/Reals/RiemannInt_SF.v
@@ -0,0 +1,2632 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis.
+Require Import Classical_Prop.
+Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+(**************************************************)
+(* 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).
+
+Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z_of_nat n}.
+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 ].
+Qed.
+
+(*******************************************)
+(*             Step functions              *)
+(*******************************************)
+
+Definition open_interval (a b x:R) : Prop := a < x < b.
+Definition co_interval (a b x:R) : Prop := a <= x < b. 
+
+Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop :=
+  ordered_Rlist l /\
+  pos_Rl l 0 = Rmin a b /\
+  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)).
+
+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) /\
+  (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 :=
+  sigT (fun l0:Rlist => adapted_couple f a b l l0).
+
+Definition IsStepFun (f:R -> R) (a b:R) : Type :=
+  sigT (fun 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 :=
+  match projT2 (pre f) with
+  | existT a b => a
+  end.
+
+Fixpoint Int_SF (l k:Rlist) {struct l} : R :=
+  match l with
+  | 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')
+      end
+  end.
+
+(* 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)
+  end.
+
+(********************************)
+(* 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.
+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.
+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) ].
+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.
+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.
+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.
+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.
+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 ].
+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 ] ].
+Qed.
+
+Lemma StepFun_P10 :
+ 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 ] ].
+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;
+    [ 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;
+    [ 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.
+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 ].
+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;
+    [ 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 ] ] ].
+Qed.
+
+Lemma StepFun_P16 :
+ 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 ] ].
+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.
+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)))
+    (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)))
+    (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))) ] ].
+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 ] ].
+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 ].
+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.
+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)
+          (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 ].
+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 ] ].
+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)
+          (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)));
+    [ 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 ] ].
+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.
+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 ].
+Qed.
+
+(* 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.
+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.
+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;
+      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 (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 ].
+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.
+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 ].
+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)))
+    (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.
+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.
+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.
+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.
+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 ] ].
+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)))));
+    [ 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)) ] ].
+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;
+    [ 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.
+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)).
+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 ] ].
+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.
+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 ].
+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 ].
+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.
+Qed.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
new file mode 100644
index 00000000..0fbb17c6
--- /dev/null
+++ b/theories/Reals/Rlimit.v
@@ -0,0 +1,557 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.23.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+(*********************************************************)
+(*           Definition of the limit                     *)
+(*                                                       *)
+(*********************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Classical_Prop.
+Require Import Fourier. Open Local Scope R_scope.
+
+(*******************************)
+(*      Calculus               *)
+(*******************************)
+(*********)
+Lemma eps2_Rgt_R0 : forall eps:R, eps > 0 -> eps * / 2 > 0.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(*********)
+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.
+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.
+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).
+Qed.
+
+
+(*******************************)
+(*      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}.
+
+(*******************************)
+(*     Limit in Metric space   *)
+(*******************************)
+
+(*********)
+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,
+      alp > 0 /\
+      (forall x:Base X, D x /\ dist X x x0 < alp -> 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 (f:R -> R) (D:R -> Prop) (l x0:R) : Prop :=
+  limit_in R_met R_met f D x0 l.
+
+(*********)
+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.
+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.
+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.
+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).
+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.
+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).
+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.
+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.
+Qed.
+
+(*********)
+Definition adhDa (D:R -> Prop) (a:R) : Prop :=
+  forall alp:R, alp > 0 ->  exists x : R, D x /\ R_dist x a < alp.
+
+(*********)
+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.
+(**)
+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).
+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.
+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);
+    [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+       intro; assumption
+    | discriminate ] ].
+Qed.
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
new file mode 100644
index 00000000..7575d929
--- /dev/null
+++ b/theories/Reals/Rpower.v
@@ -0,0 +1,661 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.17.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+(*i Due to L.Thery i*) 
+
+(************************************************************)
+(* Definitions of log and Rpower : R->R->R; main properties *)
+(************************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import Exp_prop.
+Require Import Rsqrt_def.
+Require Import R_sqrt.
+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.
+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.
+Qed.
+
+(******************************************************************)
+(*                        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.
+ 
+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)).
+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.
+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 ].
+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).
+Qed.
+
+(* Definition of log R+* -> R *)
+Definition Rln (y:posreal) : R :=
+  match ln_exists (pos y) (cond_pos y) with
+  | 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
+  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.
+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).
+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.
+ 
+(******************************************************************)
+(*                        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.
+Qed.
+
+Theorem ln_exp : forall 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 : 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.
+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.
+ 
+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.
+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.
+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.
+Qed.
+
+(******************************************************************)
+(*                        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                   *)
+(******************************************************************)
+ 
+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.
+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.
+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.
+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.
+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.
+ 
+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.
+ 
+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.
+ 
+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.
+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.
+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 *)
+(**************************************)
+
+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.
+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.
+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.
+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).
+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;
+    [ apply H6 | unfold alp in |- *; apply Rmin_l ]
+ | 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.
+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.
+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.
+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
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
new file mode 100644
index 00000000..6577146f
--- /dev/null
+++ b/theories/Reals/Rprod.v
@@ -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        *)
+(************************************************************************)
+ 
+(*i $Id: Rprod.v,v 1.10.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Compare.
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+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 :=
+  match N with
+  | 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 ].
+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.
+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.
+Qed.
+
+(* 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.
+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.
+Qed. 
+
+(* We prove that (N!)²<=(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 ].
+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.
+Qed.
+
+(* 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
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
new file mode 100644
index 00000000..cbf93278
--- /dev/null
+++ b/theories/Reals/Rseries.v
@@ -0,0 +1,275 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Classical.
+Require Import Compare.
+Open Local Scope R_scope.
+
+Implicit 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 :=
+  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 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 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 Un_in_EUn : forall n:nat, EUn (Un n).
+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 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.
+
+
+(* 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 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 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.
+
+End sequence.
+
+(*****************************************************************)
+(*           Definition of Power Series and properties           *)
+(*                                                               *)
+(*****************************************************************)
+
+Section Isequence.
+
+(*********)
+Variable An : nat -> R.
+
+(*********)
+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.
+Qed.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
new file mode 100644
index 00000000..e54c3675
--- /dev/null
+++ b/theories/Reals/Rsigma.v
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import PartSum.
+Open Local Scope R_scope.
+
+Set Implicit Arguments.
+
+Section Sigma.
+
+Variable f : nat -> R.
+
+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_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_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_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_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_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.
+
+End Sigma.
\ No newline at end of file
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
new file mode 100644
index 00000000..459f2716
--- /dev/null
+++ b/theories/Reals/Rsqrt_def.v
@@ -0,0 +1,762 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Sumbool.
+Require Import Rbase.
+Require Import Rfunctions.
+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 :=
+  match N with
+  | 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) {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.
+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 ].
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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;
+    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)).
+Qed.
+
+Definition cond_positivity (x:R) : bool :=
+  match Rle_dec 0 x with
+  | left _ => true
+  | right _ => false
+  end.
+
+(* 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.
+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.
+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.
+Qed.
+
+(* 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.
+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.
+Qed.
+
+(* 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.
+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
+  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.
+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
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
new file mode 100644
index 00000000..1c112bf1
--- /dev/null
+++ b/theories/Reals/Rtopology.v
@@ -0,0 +1,1825 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.19.2.1 2004/07/16 19:31:13 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+Require Import RList.
+Require Import Classical_Prop.
+Require Import Classical_Pred_Type. Open Local Scope R_scope.
+
+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.
+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.
+Definition closed_set (D:R -> Prop) : Prop := open_set (complementary D).
+Definition intersection_domain (D1 D2:R -> Prop) (c:R) : Prop := D1 c /\ D2 c.
+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).
+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.
+Qed.
+
+Definition point_adherent (D:R -> Prop) (x:R) : Prop :=
+  forall V:R -> Prop,
+    neighbourhood V x ->  exists y : R, intersection_domain V D y.
+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.
+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.
+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.
+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.
+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.
+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 ].
+Qed.
+
+Definition eq_Dom (D1 D2:R -> Prop) : Prop :=
+  included D1 D2 /\ included D2 D1.
+
+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).
+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).
+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)).
+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.
+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).
+Qed.
+
+Lemma open_set_P4 : open_set (fun x:R => False).
+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.
+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.
+Qed.
+
+Lemma continuity_P1 :
+ forall (f:R -> R) (x:R),
+   continuity_pt f x <->
+   (forall W:R -> Prop,
+      neighbourhood W (f x) ->
+       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.
+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)).
+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.
+Qed.
+
+(**********)
+Theorem Rsepare :
+ forall x y:R,
+   x <> y ->
+    exists V : 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.
+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}.
+
+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).
+
+Definition family_finite (f:family) : Prop := domain_finite (ind f).
+
+Definition covering (D:R -> Prop) (f:family) : Prop :=
+  forall x:R, D x ->  exists 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 :
+ 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.
+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).
+
+Definition compact (X:R -> Prop) : Prop :=
+  forall f:family,
+    covering_open_set X f ->
+     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.
+Qed.
+
+Definition bounded (D:R -> Prop) : Prop :=
+   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.
+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)) ].
+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.
+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.
+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.
+Qed.
+
+(* 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.
+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.
+(* 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.
+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).
+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).
+Qed.
+
+Definition image_dir (f:R -> R) (D:R -> Prop) (x:R) : Prop :=
+   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.
+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 ].
+Qed.
+
+Lemma prolongement_C0 :
+ 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.
+Qed.
+
+(**********)
+Lemma continuity_ab_maj :
+ 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 ->
+        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.
+Qed.
+
+(**********)
+Lemma continuity_ab_min :
+ 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).
+Qed.
+
+
+(********************************************************)
+(*         Proof of Bolzano-Weierstrass theorem         *)
+(********************************************************)
+
+Definition ValAdh (un:nat -> R) (x:R) : Prop :=
+  forall (V:R -> Prop) (N:nat),
+    neighbourhood V x ->  exists p : nat, (N <= p)%nat /\ V (un p).
+
+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
+        (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.
+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
+        (fun y:R => (exists p : nat, y = un p /\ x <= INR p) /\ D x) in
+  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.
+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) ].
+Qed.
+
+Definition family_closed_set (f:family) : Prop :=
+  forall x:R, closed_set (f x).
+
+Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop :=
+  forall x:R,
+    (ind f x -> included (f x) D) /\
+    ~ (exists 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 :
+ 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) ].
+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.
+Qed.
+
+(********************************************************)
+(*               Proof of Heine's theorem               *)
+(********************************************************)
+
+Definition uniform_continuity (f:R -> R) (X:R -> Prop) : Prop :=
+  forall eps:posreal,
+     exists delta : posreal,
+      (forall x y:R,
+         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) ].
+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.
+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.
+(* 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.
+(* 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).
+(* 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 =>
+            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.
+Qed.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
new file mode 100644
index 00000000..e4cae6c6
--- /dev/null
+++ b/theories/Reals/Rtrigo.v
@@ -0,0 +1,1707 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.40.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Export Rtrigo_fun.
+Require Export Rtrigo_def.
+Require Export Rtrigo_alt.
+Require Export Cos_rel.
+Require Export Cos_plus.
+Require Import ZArith_base.
+Require Import Zcomplements.
+Require Import Classical_Prop.
+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 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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********)
+Lemma neg_cos : forall x:R, cos (x + PI) = - cos x.
+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.
+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.
+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.
+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.
+Qed.
+
+(*******************************************************)
+(* 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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma sin_neg : forall x:R, sin (- x) = - sin x.
+apply sin_antisym.
+Qed.
+
+Lemma cos_neg : forall x:R, cos (- x) = cos x.
+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. 
+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.
+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.
+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.
+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 : forall x:R, sin (x + PI) = - sin x.
+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.
+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 ].
+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 ].
+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.
+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.
+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.
+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 ].
+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.
+Qed.
+
+Lemma COS_bound : forall x:R, -1 <= cos x <= 1.
+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).
+Qed.
+  
+Lemma cos_sin_0_var : forall 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 : 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
+    (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.
+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).
+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).
+Qed.
+
+(**********)
+Lemma _PI2_RLT_0 : - (PI / 2) < 0.
+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 ].
+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 *)
+(********************************************)
+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.
+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).
+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 ].
+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 ].
+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 ].
+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.
+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 ].
+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 ].
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+
+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.
+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.
+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.
+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.
+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.
+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.
+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).
+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).
+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.
+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.
+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.
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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)) ] ].
+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.
+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.
+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.
+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.
+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.
+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 ] ].
+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.
+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
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
new file mode 100644
index 00000000..3cda9290
--- /dev/null
+++ b/theories/Reals/Rtrigo_alt.v
@@ -0,0 +1,426 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.16.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_def.
+Open Local Scope R_scope.
+
+(*****************************************************************)
+(* 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))).
+
+Definition cos_term (a:R) (i:nat) : R :=
+  (-1) ^ i * (a ^ (2 * i) / INR (fact (2 * 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 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 ].
+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
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
new file mode 100644
index 00000000..0ef87322
--- /dev/null
+++ b/theories/Reals/Rtrigo_calc.v
@@ -0,0 +1,434 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.15.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+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. 
+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.
+Qed.
+
+Lemma tan_2PI : tan (2 * PI) = 0.
+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 ]...
+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...
+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...
+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 ].
+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.
+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 ] ]...
+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 ] ].
+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.
+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 ] ] ].
+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 ] ] ].
+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 ].
+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 ].
+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...
+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 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 ]...
+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 ]...
+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...
+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.
+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 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.
+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...
+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...
+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 ]...
+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 ]...
+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_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 ].
+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.
+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.
+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 : 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.
+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.
+Qed.
+
+Lemma deg_rad : forall 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 : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
+intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
+Qed.
+
+(***************************************************)
+(*                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
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
new file mode 100644
index 00000000..92ec68ce
--- /dev/null
+++ b/theories/Reals/Rtrigo_def.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: Rtrigo_def.v,v 1.17.2.1 2004/07/16 19:31:14 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo_fun.
+Require Import Max.
+Open Local Scope R_scope.
+
+(*****************************)
+(* 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.
+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.
+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).
+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.
+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)).
+Qed.
+
+(**************************************)
+(* 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 ].
+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.
+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.
+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.
+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 ].
+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.
+Qed.
+
+(**********)
+Definition cos_in (x l:R) : Prop :=
+  infinit_sum (fun i:nat => cos_n i * x ^ i) l.
+
+(**********)
+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.
+Qed.
+
+(* Definition of cosinus *)
+(*************************)
+Definition cos (x:R) : R :=
+  match exist_cos (Rsqr x) with
+  | 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.
+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 ].
+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.
+Qed.
+
+(**********)
+Definition sin_in (x l:R) : Prop :=
+  infinit_sum (fun i:nat => sin_n i * x ^ i) l.
+
+(**********)
+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.
+Qed.
+
+(***********************)
+(* Definition of sinus *)
+Definition sin (x:R) : R :=
+  match exist_sin (Rsqr x) with
+  | existT a b => x * a
+  end.
+
+(*********************************************)
+(*                 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.
+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.
+Qed.
+
+Lemma sin_0 : sin 0 = 0.
+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.
+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
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
new file mode 100644
index 00000000..b0f29e5c
--- /dev/null
+++ b/theories/Reals/Rtrigo_fun.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Open Local Scope R_scope.
+
+(*****************************************************************)
+(*           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.
+(**)
+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.
+Qed.
+
+
+
+
+
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
new file mode 100644
index 00000000..9d3b60c6
--- /dev/null
+++ b/theories/Reals/Rtrigo_reg.v
@@ -0,0 +1,608 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.15.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Import Rtrigo.
+Require Import Ranalysis1.
+Require Import PSeries_reg.
+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).
+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.
+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.
+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).
+Qed.
+
+(* (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.
+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 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).
+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.
+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.
+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.
+Qed.
+
+Lemma derivable_sin : derivable sin.
+unfold derivable in |- *; intro; apply derivable_pt_sin.
+Qed.
+
+Lemma derivable_cos : derivable cos.
+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.
+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
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
new file mode 100644
index 00000000..34f9fd72
--- /dev/null
+++ b/theories/Reals/SeqProp.v
@@ -0,0 +1,1295 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.13.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import Classical.
+Require Import Max.
+Open Local Scope R_scope.
+
+Definition Un_decreasing (Un:nat -> R) : Prop :=
+  forall n:nat, Un (S n) <= Un n.
+Definition opp_seq (Un:nat -> R) (n:nat) : R := - 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 :
+ 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).
+  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.
+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.
+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 ].
+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.
+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.
+Qed.
+
+Definition majorant (Un:nat -> R) (pr:has_ub Un) : R :=
+  match maj_sup Un pr with
+  | 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
+  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.
+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.
+Qed.
+
+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) 
+  (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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********)
+Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un.
+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 ].
+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.
+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.
+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.
+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 ].
+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. 
+
+(**********)
+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.
+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.
+Qed.
+
+(* 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. 
+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 ]. 
+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. 
+
+(**********) 
+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. 
+
+(**********)
+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. 
+ 
+(**********) 
+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. 
+
+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.
+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.
+Qed.
+
+Lemma tech13 :
+ 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,
+        (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.
+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 ].
+Qed.
+
+(* 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.
+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.
+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. 
+
+(* 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 *)
+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.
+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 ].
+Qed.
+
+(* |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.
+Qed.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
new file mode 100644
index 00000000..deb98492
--- /dev/null
+++ b/theories/Reals/SeqSeries.v
@@ -0,0 +1,417 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import 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.
+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
+  (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
+ (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.
+Qed.
+
+(* 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.
+Qed.
+
+(* 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.
+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 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.
+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...
+Qed.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
new file mode 100644
index 00000000..b4026e67
--- /dev/null
+++ b/theories/Reals/SplitAbsolu.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i      $Id: SplitAbsolu.v,v 1.6.2.1 2004/07/16 19:31:15 herbelin Exp $       i*)
+
+Require Import Rbasic_fun.
+
+Ltac split_case_Rabs :=
+  match goal with
+  |  |- 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)] =>
+      unfold Rabs in |- *; try split_case_Rabs; intros
+  end.
\ No newline at end of file
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
new file mode 100644
index 00000000..19df2afa
--- /dev/null
+++ b/theories/Reals/SplitRmult.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: SplitRmult.v,v 1.7.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+(*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
+
+
+Require Import Rbase.
+
+Ltac split_Rmult :=
+  match goal with
+  |  |- ((?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
new file mode 100644
index 00000000..b11e51f0
--- /dev/null
+++ b/theories/Reals/Sqrt_reg.v
@@ -0,0 +1,351 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.9.2.1 2004/07/16 19:31:15 herbelin Exp $ i*)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Ranalysis1.
+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.
+Qed.
+
+(* 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 ].
+Qed.
+
+(* 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.
+Qed.
+
+(* 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.
+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.
+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.
+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 : 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
diff --git a/theories/Reals/intro.tex b/theories/Reals/intro.tex
new file mode 100644
index 00000000..43317258
--- /dev/null
+++ b/theories/Reals/intro.tex
@@ -0,0 +1,4 @@
+\section{Reals}\label{Reals}
+
+This library contains an axiomatization of real numbers.
+The main file is \texttt{Reals.v}.
diff --git a/theories/Relations/Newman.v b/theories/Relations/Newman.v
new file mode 100755
index 00000000..3cf604d8
--- /dev/null
+++ b/theories/Relations/Newman.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+Require Import Rstar.
+
+Section Newman.
+
+Variable A : Type. 
+Variable R : A -> A -> Prop.
+
+Let Rstar := Rstar A R. 
+Let Rstar_reflexive := Rstar_reflexive A R.
+Let Rstar_transitive := Rstar_transitive A R.
+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.
+  
+(** 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).  
+  
+(** 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.
+
+Definition confluence (x:A) :=
+  forall y z:A, Rstar x y -> Rstar x z -> coherence y z.  
+  
+Definition local_confluence (x:A) :=
+  forall y z:A, R x y -> R x z -> coherence y z.  
+  
+Definition noetherian :=
+  forall (x:A) (P:A -> Prop),
+    (forall y:A, (forall 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 : forall x:A, local_confluence x.  
+  
+(** The induction hypothesis *)
+
+Section Induct.
+  Variable x : A.
+  Hypothesis hyp_ind : forall 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 : 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.  
+
+End Newman_section.
+
+
+End Newman.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
new file mode 100755
index 00000000..5e0e9ec8
--- /dev/null
+++ b/theories/Relations/Operators_Properties.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:16 herbelin Exp $ i*)
+
+(****************************************************************************)
+(*                            Bruno Barras                                  *)
+(****************************************************************************)
+
+Require Import Relation_Definitions.
+Require Import Relation_Operators.
+
+
+Section Properties.
+
+  Variable A : Set.
+  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
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
new file mode 100755
index 00000000..e115b0b0
--- /dev/null
+++ b/theories/Relations/Relation_Definitions.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        *)
+(************************************************************************)
+
+(*i $Id: Relation_Definitions.v,v 1.6.2.1 2004/07/16 19:31:16 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 := 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 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 (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'.
+
+End Relations_of_Relations.
+
+   
+End Relation_Definition.
+
+Hint Unfold reflexive transitive antisymmetric symmetric: sets v62.
+
+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
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
new file mode 100755
index 00000000..b6359ada
--- /dev/null
+++ b/theories/Relations/Relation_Operators.v
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:16 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 Import Relation_Definitions.
+Require Import List.
+
+(** Some operators to build relations *)
+
+Section Transitive_Closure.
+  Variable A : Set.
+  Variable R : relation A.
+
+  Inductive clos_trans : A -> A -> Prop :=
+    | t_step : forall x 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.
+End Transitive_Closure.
+
+
+Section Reflexive_Transitive_Closure.
+  Variable A : Set.
+  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
+    | rt_trans :
+        forall 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 : 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
+    | 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.
+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.
+  Variables R1 R2 : relation A.
+
+  Definition union (x y:A) := R1 x y \/ R2 x y.
+End Union.
+
+
+Section Disjoint_Union.
+Variables A B : Set.
+Variable leA : A -> A -> Prop.
+Variable leB : B -> B -> Prop.
+
+Inductive le_AsB : A + B -> A + B -> Prop :=
+  | le_aa : forall x y:A, leA x y -> le_AsB (inl B x) (inl B y)
+  | le_ab : forall (x:A) (y:B), le_AsB (inl B x) (inr A y)
+  | le_bb : forall x y:B, leB x y -> le_AsB (inr A x) (inr A 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 : forall x:A, B x -> B x -> Prop.
+
+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 :
+      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 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)
+    | right_sym :
+        forall y y':B, leB y y' -> forall 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 : 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.
+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 :
+      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).
+
+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
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
new file mode 100755
index 00000000..6c96f14d
--- /dev/null
+++ b/theories/Relations/Relations.v
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Relations.v,v 1.6.2.1 2004/07/16 19:31:16 herbelin Exp $ 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.
+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
diff --git a/theories/Relations/Rstar.v b/theories/Relations/Rstar.v
new file mode 100755
index 00000000..7bb3ee93
--- /dev/null
+++ b/theories/Relations/Rstar.v
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:16 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) :=
+  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_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.  
+  
+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).  
+  
+(** 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
+   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
+   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
+   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'.
+
+
+End Rstar.
diff --git a/theories/Relations/intro.tex b/theories/Relations/intro.tex
new file mode 100755
index 00000000..5056f36f
--- /dev/null
+++ b/theories/Relations/intro.tex
@@ -0,0 +1,23 @@
+\section{Relations}\label{Relations}
+
+This library develops closure properties of relations.
+
+\begin{itemize}
+\item {\tt Relation\_Definitions.v} deals with the general notions
+  about binary relations (orders, equivalences, ...)
+
+\item {\tt Relation\_Operators.v} and {\tt Rstar.v} define various
+  closures of relations (by symmetry, by transitivity, ...) and
+  lexicographic orderings.
+
+\item {\tt Operators\_Properties.v} states and proves facts on the
+  various closures of a relation.
+
+\item {\tt Relations.v} puts {\tt Relation\_Definitions.v}, {\tt
+    Relation\_Operators.v} and \\
+    {\tt Operators\_Properties.v} together.
+
+\item {\tt Newman.v} proves Newman's lemma on noetherian and locally
+  confluent relations.
+
+\end{itemize}
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
new file mode 100644
index 00000000..63f21fed
--- /dev/null
+++ b/theories/Setoids/Setoid.v
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:17 herbelin Exp $: i*)
+
+Section Setoid.
+
+Variable A : Type.
+Variable Aeq : A -> A -> Prop.
+
+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}.
+
+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 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 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 in |- *; intros.
+apply H0.
+inversion H.
+apply (H3 H1).
+Qed.
+
+Definition fleche (A B:Prop) := A -> B.
+
+Add Morphism fleche : fleche_ext.
+unfold fleche in |- *.
+intros.
+inversion H0.
+inversion H.
+apply (H3 (H1 (H6 H2))).
+Qed.
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
new file mode 100755
index 00000000..98cb14e4
--- /dev/null
+++ b/theories/Sets/Classical_sets.v
@@ -0,0 +1,132 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:17 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 :
+ 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.
+
+End Ensembles_classical.
+
+Hint Resolve Strict_super_set_contains_new_element Subtract_intro
+  not_SIncl_empty: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
new file mode 100755
index 00000000..a2bc781d
--- /dev/null
+++ b/theories/Sets/Constructive_sets.v
@@ -0,0 +1,159 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:17 herbelin Exp $ 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.
+ 
+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.
+
+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
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
new file mode 100755
index 00000000..9fae12f5
--- /dev/null
+++ b/theories/Sets/Cpo.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Export Ensembles.
+Require Export Relations_1.
+Require Export Partial_Order.
+
+Section Bounds.
+Variable U : Type.
+Variable D : PO U.
+
+Let C := Carrier_of U D.
+
+Let R := Rel_of U D.
+
+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.
+
+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 :=
+    Lub_definition :
+      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 :=
+    Glb_definition :
+      Lower_Bound B x -> (forall y:U, Lower_Bound B y -> R y x) -> Glb B x.
+
+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 :=
+    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.
+
+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.
+
+Inductive Complete : Prop :=
+    Definition_of_Complete :
+      (exists bot : _, Bottom bot) ->
+      (forall X:Ensemble U, Directed X ->  exists bsup : _, Lub X bsup) ->
+      Complete.
+
+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.
+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)}.
+
+End Specific_orders.
\ No newline at end of file
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
new file mode 100755
index 00000000..05afc298
--- /dev/null
+++ b/theories/Sets/Ensembles.v
@@ -0,0 +1,101 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:17 herbelin Exp $ 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 :=
+    Full_intro : forall 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 : 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 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 :=
+    Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.
+
+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 *)
+
+Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.
+Hint Resolve Extensionality_Ensembles.
+
+End Ensembles.
+
+Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets
+  v62.
+
+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
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
new file mode 100755
index 00000000..5a2e4397
--- /dev/null
+++ b/theories/Sets/Finite_sets.v
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+Require Import Ensembles.
+
+Section Ensembles_finis.
+Variable U : Type.
+
+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 :
+      forall (A:Ensemble U) (n:nat),
+        cardinal A n -> forall x:U, ~ In U A x -> cardinal (Add U A x) (S n).
+
+End Ensembles_finis.
+
+Hint Resolve Empty_is_finite Union_is_finite: sets v62.
+Hint Resolve card_empty card_add: sets v62.
+
+Require Import Constructive_sets.
+
+Section Ensembles_finis_facts.
+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_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
new file mode 100755
index 00000000..952965e8
--- /dev/null
+++ b/theories/Sets/Finite_sets_facts.v
@@ -0,0 +1,347 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:17 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 :
+ 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.
+
+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 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 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.
+
+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 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 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_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 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 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
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
new file mode 100755
index 00000000..f58f2f81
--- /dev/null
+++ b/theories/Sets/Image.v
@@ -0,0 +1,205 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:17 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 : 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.
+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
new file mode 100755
index 00000000..c357e26c
--- /dev/null
+++ b/theories/Sets/Infinite_sets.v
@@ -0,0 +1,244 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:17 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.
+
+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.
+
+End Infinite_sets.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
new file mode 100755
index 00000000..26f29c96
--- /dev/null
+++ b/theories/Sets/Integers.v
@@ -0,0 +1,167 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:17 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 : 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.
+
+End Integers_sect.
+
+
+
+
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
new file mode 100755
index 00000000..a308282b
--- /dev/null
+++ b/theories/Sets/Multiset.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Multiset.v,v 1.9.2.1 2004/07/16 19:31:17 herbelin Exp $ i*)
+
+(* G. Huet 1-9-95 *)
+
+Require Import Permut.
+
+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}.
+
+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.
+
+
+(*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.
+
+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
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
new file mode 100755
index 00000000..b3e59886
--- /dev/null
+++ b/theories/Sets/Partial_Order.v
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:18 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 := 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.
+
+End Partial_orders.
+
+Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62.
+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.
+
+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 : 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
new file mode 100755
index 00000000..af6151bf
--- /dev/null
+++ b/theories/Sets/Permut.v
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:18 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 : 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
new file mode 100755
index 00000000..a7f5e9f4
--- /dev/null
+++ b/theories/Sets/Powerset.v
@@ -0,0 +1,190 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:18 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 :
+      forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X.
+Hint Resolve Definition_of_Power_set.
+
+Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X.
+intro X; red in |- *.
+intros x H'; elim H'.
+Qed.
+Hint Resolve Empty_set_minimal.
+
+Theorem Power_set_Inhabited :
+ forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X).
+intro X.
+apply Inhabited_intro with (Empty_set U); auto with sets.
+Qed.
+Hint Resolve Power_set_Inhabited.
+
+Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U).
+auto 6 with sets.
+Qed.
+Hint Resolve Inclusion_is_an_order.
+
+Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U).
+elim Inclusion_is_an_order; auto with sets.
+Qed.
+Hint 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.
+Hint 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.
+Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included.
+
+Lemma Strict_inclusion_is_transitive_with_inclusion :
+ forall 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 in |- *.
+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 :
+ forall 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 in |- *.
+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 :
+ forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U).
+intro A; apply Bottom_definition; simpl in |- *; auto with sets.
+Qed.
+Hint Resolve Empty_set_is_Bottom.
+
+Theorem Union_minimal :
+ forall 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 in |- *.
+intros x H'1; elim H'1; auto with sets.
+Qed.
+Hint Resolve Union_minimal.
+
+Theorem Intersection_maximal :
+ forall 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 : forall a b:Ensemble U, Included U a (Union U a b).
+auto with sets.
+Qed.
+
+Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b).
+auto with sets.
+Qed.
+
+Theorem Intersection_decreases_l :
+ forall a b:Ensemble U, Included U (Intersection U a b) a.
+intros a b; red in |- *.
+intros x H'; elim H'; auto with sets.
+Qed.
+
+Theorem Intersection_decreases_r :
+ forall a b:Ensemble U, Included U (Intersection U a b) b.
+intros a b; red in |- *.
+intros x H'; elim H'; auto with sets.
+Qed.
+Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
+  Intersection_decreases_r.
+
+Theorem Union_is_Lub :
+ forall A 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 in |- *.
+apply Upper_Bound_definition; simpl in |- *; auto with sets.
+intros y H'1; elim H'1; auto with sets.
+intros y H'1; elim H'1; simpl in |- *; auto with sets.
+Qed.
+
+Theorem Intersection_is_Glb :
+ forall A 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 in |- *.
+apply Lower_Bound_definition; simpl in |- *; 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 in |- *; auto with sets.
+Qed.
+
+End The_power_set_partial_order.
+
+Hint Resolve Empty_set_minimal: sets v62.
+Hint Resolve Power_set_Inhabited: sets v62.
+Hint Resolve Inclusion_is_an_order: sets v62.
+Hint Resolve Inclusion_is_transitive: sets v62.
+Hint Resolve Union_minimal: sets v62.
+Hint Resolve Union_increases_l: sets v62.
+Hint Resolve Union_increases_r: sets v62.
+Hint Resolve Intersection_decreases_l: sets v62.
+Hint Resolve Intersection_decreases_r: sets v62.
+Hint Resolve Empty_set_is_Bottom: sets v62.
+Hint Resolve Strict_inclusion_is_transitive: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
new file mode 100755
index 00000000..05c60def
--- /dev/null
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -0,0 +1,342 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:18 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 :
+ 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.
+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.
+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.
+
+End Sets_as_an_algebra.
+
+Hint Resolve incl_soustr_in: sets v62.
+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
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
new file mode 100755
index 00000000..2c71f529
--- /dev/null
+++ b/theories/Sets/Powerset_facts.v
@@ -0,0 +1,268 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:18 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.
+Hint Unfold not.
+
+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: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'.
+
+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.
+
+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.
+
+End Sets_as_an_algebra.
+
+Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add
+  singlx incl_add: sets v62.
+
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
new file mode 100755
index 00000000..e33746a9
--- /dev/null
+++ b/theories/Sets/Relations_1.v
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Section Relations_1.
+   Variable U : Type.
+   
+   Definition Relation := U -> U -> Prop.
+   Variable R : Relation.
+   
+   Definition Reflexive : Prop := forall x:U, R x x.
+   
+   Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z.
+   
+   Definition Symmetric : Prop := forall x y:U, R x y -> R y x.
+   
+   Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y.
+   
+   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 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.
+Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
+  same_relation: sets v62.
+Hint Resolve Definition_of_preorder Definition_of_order
+  Definition_of_equivalence Definition_of_PER: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
new file mode 100755
index 00000000..62688895
--- /dev/null
+++ b/theories/Sets/Relations_1_facts.v
@@ -0,0 +1,112 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+
+Definition Complement (U:Type) (R:Relation U) : Relation U :=
+  fun x y:U => ~ R x y.
+
+Theorem Rsym_imp_notRsym :
+ forall (U:Type) (R:Relation U),
+   Symmetric U R -> Symmetric U (Complement U R).
+Proof.
+unfold Symmetric, Complement in |- *.
+intros U R H' x y H'0; red in |- *; intro H'1; apply H'0; auto with sets.
+Qed.
+
+Theorem Equiv_from_preorder :
+ forall (U:Type) (R:Relation U),
+   Preorder U R -> Equivalence U (fun 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 in |- *; intros x y h; elim h; intros H'3 H'4; auto 10 with sets.
+red in H'1; red in |- *; 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.
+Hint Resolve Equiv_from_preorder.
+
+Theorem Equiv_from_order :
+ forall (U:Type) (R:Relation U),
+   Order U R -> Equivalence U (fun x y:U => R x y /\ R y x).
+Proof.
+intros U R H'; elim H'; auto 10 with sets.
+Qed.
+Hint Resolve Equiv_from_order.
+
+Theorem contains_is_preorder :
+ forall U:Type, Preorder (Relation U) (contains U).
+Proof.
+auto 10 with sets.
+Qed.
+Hint Resolve contains_is_preorder.
+
+Theorem same_relation_is_equivalence :
+ forall U:Type, Equivalence (Relation U) (same_relation U).
+Proof.
+unfold same_relation at 1 in |- *; auto 10 with sets.
+Qed.
+Hint Resolve same_relation_is_equivalence.
+
+Theorem cong_reflexive_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Reflexive U R -> Reflexive U R'.
+Proof.
+unfold same_relation in |- *; intuition.
+Qed.
+
+Theorem cong_symmetric_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Symmetric U R -> Symmetric U R'.
+Proof.
+  compute in |- *; intros; elim H; intros; clear H;
+   apply (H3 y x (H0 x y (H2 x y H1))).
+(*Intuition.*)
+Qed.
+
+Theorem cong_antisymmetric_same_relation :
+ forall (U:Type) (R R':Relation U),
+   same_relation U R R' -> Antisymmetric U R -> Antisymmetric U R'.
+Proof.
+  compute in |- *; 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 :
+ forall (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 in |- *.
+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.
\ No newline at end of file
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
new file mode 100755
index 00000000..15d3ee2d
--- /dev/null
+++ b/theories/Sets/Relations_2.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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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.4.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+
+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 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 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.
+
+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).
+
+End Relations_2.
+
+Hint Resolve Rstar_0: sets v62.
+Hint Resolve Rstar1_0: sets v62.
+Hint Resolve Rstar1_1: sets v62.
+Hint Resolve Rplus_0: sets v62.
\ No newline at end of file
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
new file mode 100755
index 00000000..4c729fe7
--- /dev/null
+++ b/theories/Sets/Relations_2_facts.v
@@ -0,0 +1,153 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+Require Export Relations_1_facts.
+Require Export Relations_2.
+
+Theorem Rstar_reflexive :
+ forall (U:Type) (R:Relation U), Reflexive U (Rstar U R).
+Proof.
+auto with sets.
+Qed.
+
+Theorem Rplus_contains_R :
+ forall (U:Type) (R:Relation U), contains U (Rplus U R) R.
+Proof.
+auto with sets.
+Qed.
+
+Theorem Rstar_contains_R :
+ forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
+Proof.
+intros U R; red in |- *; intros x y H'; apply Rstar_n with y; auto with sets.
+Qed.
+
+Theorem Rstar_contains_Rplus :
+ forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
+Proof.
+intros U R; red in |- *.
+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 :
+ forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
+Proof.
+intros U R; red in |- *.
+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 :
+ forall (U:Type) (R:Relation U) (x y:U),
+   Rstar U R x y -> x = y \/ (exists 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 :
+ forall (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 in |- *.
+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 :
+ forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
+Proof.
+intros U R H'; red in |- *.
+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 :
+ forall (U:Type) (R S:Relation U),
+   contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
+Proof.
+unfold contains in |- *.
+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 :
+ forall (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 :
+ forall (U:Type) (R:Relation U) (x y z:U),
+   Rstar U R x y -> Rplus U R y z ->  exists 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 :
+ forall (U:Type) (R:Relation U),
+   Strongly_confluent U R ->
+   forall x b:U,
+     Rstar U R x b ->
+     forall a:U, R x a ->  exists 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  3H' 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.
\ No newline at end of file
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
new file mode 100755
index 00000000..6a254819
--- /dev/null
+++ b/theories/Sets/Relations_3.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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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.7.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+Require Export Relations_1.
+Require Export Relations_2.
+
+Section Relations_3.
+   Variable U : Type.
+   Variable R : Relation U.
+   
+   Definition coherent (x y:U) : Prop :=
+      exists z : _, Rstar U R x z /\ Rstar U R y z.
+   
+   Definition locally_confluent (x:U) : Prop :=
+     forall y z:U, R x y -> R x z -> coherent y z.
+   
+   Definition Locally_confluent : Prop := forall x:U, locally_confluent x.
+   
+   Definition confluent (x:U) : Prop :=
+     forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z.
+   
+   Definition Confluent : Prop := forall x:U, confluent x.
+   
+   Inductive noetherian : U -> Prop :=
+       definition_of_noetherian :
+         forall x:U, (forall y:U, R x y -> noetherian y) -> noetherian x.
+   
+   Definition Noetherian : Prop := forall x:U, noetherian x.
+   
+End Relations_3.
+Hint Unfold coherent: sets v62.
+Hint Unfold locally_confluent: sets v62.
+Hint Unfold confluent: sets v62.
+Hint Unfold Confluent: sets v62.
+Hint Resolve definition_of_noetherian: sets v62.
+Hint Unfold Noetherian: sets v62.
+
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
new file mode 100755
index 00000000..34322dc7
--- /dev/null
+++ b/theories/Sets/Relations_3_facts.v
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:18 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 :
+ forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y.
+Proof.
+intros U R x y H'; red in |- *.
+exists y; auto with sets.
+Qed.
+Hint Resolve Rstar_imp_coherent.
+
+Theorem coherent_symmetric :
+ forall (U:Type) (R:Relation U), Symmetric U (coherent U R).
+Proof.
+unfold coherent at 1 in |- *.
+intros U R; red in |- *.
+intros x y H'; elim H'.
+intros z H'0; exists z; tauto.
+Qed.
+
+Theorem Strong_confluence :
+ forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
+Proof.
+intros U R H'; red in |- *.
+intro x; red in |- *; intros a b H'0.
+unfold coherent at 1 in |- *.
+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 :
+ forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
+Proof.
+intros U R H'; red in |- *.
+intro x; red in |- *; intros a b H'0.
+unfold coherent at 1 in |- *.
+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 (ex (fun 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 :
+ forall (U:Type) (R R':Relation U),
+   Noetherian U R -> contains U R R' -> Noetherian U R'.
+Proof.
+unfold Noetherian at 2 in |- *.
+intros U R R' H' H'0 x.
+elim (H' x); auto with sets.
+Qed.
+
+Theorem Newman :
+ forall (U:Type) (R:Relation U),
+   Noetherian U R -> Locally_confluent U R -> Confluent U R.
+Proof.
+intros U R H' H'0; red in |- *; intro x.
+elim (H' x); unfold confluent in |- *.
+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 coherent at 1 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 in |- *; (exists z1; split); auto with sets.
+apply T with y1; auto with sets.
+apply T with t; auto with sets.
+Qed.
\ No newline at end of file
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
new file mode 100644
index 00000000..10d26f22
--- /dev/null
+++ b/theories/Sets/Uniset.v
@@ -0,0 +1,215 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.9.2.1 2004/07/16 19:31:18 herbelin Exp $ i*)
+
+(** Sets as characteristic functions *)
+
+(* G. Huet 1-9-95 *)
+(* Updated Papageno 12/98 *)
+
+Require Import Bool.
+
+Set Implicit Arguments.
+
+Section defs.
+
+Variable A : Set.
+Variable eqA : A -> A -> Prop.
+Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}.
+
+Inductive uniset : Set :=
+    Charac : (A -> bool) -> uniset.
+
+Definition charac (s:uniset) (a:A) : bool := let (f) := s in f a.
+
+Definition Emptyset := Charac (fun a:A => false).
+
+Definition Fullset := Charac (fun a:A => true).
+
+Definition Singleton (a:A) :=
+  Charac
+    (fun a':A =>
+       match eqA_dec a a' with
+       | left h => true
+       | right h => false
+       end).
+
+Definition In (s:uniset) (a:A) : Prop := charac s a = true.
+Hint Unfold In.
+
+(** uniset inclusion *)
+Definition incl (s1 s2:uniset) := forall a:A, leb (charac s1 a) (charac s2 a).
+Hint Unfold incl.
+
+(** uniset equality *)
+Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a.
+Hint Unfold seq.
+
+Lemma leb_refl : forall b:bool, leb b b.
+Proof.
+destruct b; simpl in |- *; auto.
+Qed.
+Hint Resolve leb_refl.
+
+Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2.
+Proof.
+unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+Qed.
+
+Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1.
+Proof.
+unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+Qed.
+
+Lemma seq_refl : forall x:uniset, seq x x.
+Proof.
+destruct x; unfold seq in |- *; auto.
+Qed.
+Hint Resolve seq_refl.
+
+Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z.
+Proof.
+unfold seq in |- *.
+destruct x; destruct y; destruct z; simpl in |- *; intros.
+rewrite H; auto.
+Qed.
+
+Lemma seq_sym : forall x y:uniset, seq x y -> seq y x.
+Proof.
+unfold seq in |- *.
+destruct x; destruct y; simpl in |- *; auto.
+Qed.
+
+(** uniset union *)
+Definition union (m1 m2:uniset) :=
+  Charac (fun a:A => orb (charac m1 a) (charac m2 a)).
+
+Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x).  
+Proof.  
+unfold seq in |- *; unfold union in |- *; simpl in |- *; auto.  
+Qed. 
+Hint Resolve union_empty_left.
+
+Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset).
+Proof.
+unfold seq in |- *; unfold union in |- *; simpl in |- *.
+intros x a; rewrite (orb_b_false (charac x a)); auto.
+Qed.
+Hint Resolve union_empty_right.
+
+Lemma union_comm : forall x y:uniset, seq (union x y) (union y x).
+Proof.
+unfold seq in |- *; unfold charac in |- *; unfold union in |- *.
+destruct x; destruct y; auto with bool.
+Qed.
+Hint Resolve union_comm.
+
+Lemma union_ass :
+ forall x y z:uniset, seq (union (union x y) z) (union x (union y z)).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z; auto with bool.
+Qed.
+Hint Resolve union_ass.
+
+Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto.
+Qed.
+Hint Resolve seq_left.
+
+Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y).
+Proof.
+unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+destruct x; destruct y; destruct z.
+intros; elim H; auto.
+Qed.
+Hint 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 Import Permut.
+
+Lemma union_rotate :
+ forall 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 :
+ forall 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 :
+ forall 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 :
+ forall 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 :
+ forall 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 :
+ forall 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 :
+ forall 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.
\ No newline at end of file
diff --git a/theories/Sets/intro.tex b/theories/Sets/intro.tex
new file mode 100755
index 00000000..83c2177f
--- /dev/null
+++ b/theories/Sets/intro.tex
@@ -0,0 +1,24 @@
+\section{Sets}\label{Sets}
+
+This is a library on sets defined by their characteristic predicate.
+It contains the following modules:
+
+\begin{itemize}
+\item {\tt Ensembles.v}
+\item {\tt Constructive\_sets.v}, {\tt Classical\_sets.v}
+\item {\tt Relations\_1.v}, {\tt Relations\_2.v}, 
+ {\tt Relations\_3.v}, {\tt Relations\_1\_facts.v},  \\
+ {\tt Relations\_2\_facts.v}, {\tt Relations\_3\_facts.v}
+\item {\tt Partial\_Order.v}, {\tt Cpo.v}
+\item {\tt Powerset.v}, {\tt Powerset\_facts.v}, 
+ {\tt Powerset\_Classical\_facts.v}
+\item {\tt Finite\_sets.v}, {\tt Finite\_sets\_facts.v}
+\item {\tt Image.v}
+\item {\tt Infinite\_sets.v}
+\item {\tt Integers.v}
+\end{itemize}
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
new file mode 100644
index 00000000..41594749
--- /dev/null
+++ b/theories/Sorting/Heap.v
@@ -0,0 +1,227 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** A development of Treesort on Heap trees *)
+
+(* G. Huet 1-9-95 uses Multiset *)
+
+Require Import List.
+Require Import Multiset.
+Require Import Permutation.
+Require Import Relations.
+Require Import Sorting.
+
+
+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 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.
+
+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] *)
+
+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_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 *)
+
+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 :=
+    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 :=
+    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 :=
+    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.
+
+End defs.
\ No newline at end of file
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
new file mode 100644
index 00000000..43a0f0bc
--- /dev/null
+++ b/theories/Sorting/Permutation.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Permutation.v,v 1.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+Require Import Relations.
+Require Import List.
+Require Import Multiset.
+
+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.
+
+End defs.
+Unset Implicit Arguments.
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
new file mode 100644
index 00000000..aa829fea
--- /dev/null
+++ b/theories/Sorting/Sorting.v
@@ -0,0 +1,123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+Require Import List.
+Require Import Multiset.
+Require Import Permutation.
+Require Import Relations.
+
+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 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.
+
+Let emptyBag := EmptyBag A.
+Let singletonBag := SingletonBag _ eqA_dec.
+
+(** [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).
+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.
+
+(** definition for a list to be sorted *)
+
+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 :=
+    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.
+
+End defs.
+
+Unset Implicit Arguments.
+Hint Constructors sort: datatypes v62.
+Hint Constructors lelistA: datatypes v62.
\ No newline at end of file
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
new file mode 100644
index 00000000..a3f16888
--- /dev/null
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes
+    From : Constructing Recursion Operators in Type Theory                 
+           L. Paulson  JSC (1986) 2, 325-355 *) 
+
+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.
+
+End Wf_Disjoint_Union.
\ No newline at end of file
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
new file mode 100644
index 00000000..1677659c
--- /dev/null
+++ b/theories/Wellfounded/Inclusion.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Inclusion.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Definitions.
+
+Section WfInclusion.
+  Variable A : Set.
+  Variables R1 R2 : A -> A -> Prop.
+
+  Lemma Acc_incl : inclusion A R1 R2 -> forall z:A, Acc R2 z -> Acc R1 z.
+  Proof.
+    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.
+  Proof.
+    unfold well_founded in |- *; auto with sets.
+  Qed.
+
+End WfInclusion.
\ No newline at end of file
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
new file mode 100644
index 00000000..f2cf1d2e
--- /dev/null
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Section Inverse_Image.
+
+  Variables A B : Set.
+  Variable R : B -> B -> Prop.
+  Variable f : A -> B.
+
+  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.
+    induction 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 : forall x:A, Acc R (f x) -> Acc Rof x.
+    intros; apply (Acc_lemma (f x)); trivial.
+  Qed.
+
+  Theorem wf_inverse_image : well_founded R -> well_founded Rof.
+    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.
+    red in |- *; constructor; intros.
+    case H0; intros.
+    apply (Acc_inverse_rel x); auto.
+Qed.
+
+End Inverse_Image.
+
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
new file mode 100644
index 00000000..d8a4d37c
--- /dev/null
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -0,0 +1,374 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.10.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes
+
+    From : Constructing Recursion Operators in Type Theory                
+           L. Paulson  JSC (1986) 2, 325-355  *)
+
+Require Import Eqdep.
+Require Import List.
+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.
+
+
+End Wf_Lexicographic_Exponentiation.
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
new file mode 100644
index 00000000..8ac178fc
--- /dev/null
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -0,0 +1,192 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Authors: Bruno Barras, Cristina Cornes *)
+
+Require Import Eqdep.
+Require Import Relation_Operators.
+Require Import 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 : 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.
+
+
+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 :
+   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 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.
+
+
+  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.
+
+
+  Lemma wf_swapprod : well_founded R -> well_founded SwapProd.
+Proof.
+ red in |- *.
+ destruct a; intros.
+ apply Acc_swapprod; auto with sets.
+Qed.
+
+End Swap.
\ No newline at end of file
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
new file mode 100644
index 00000000..2e9d497b
--- /dev/null
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Definitions.
+Require Import 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 in |- *; auto with sets.
+  Qed.
+
+  Lemma Acc_clos_trans : forall x:A, Acc R x -> Acc trans_clos x.
+    induction 1 as [x0 _ H1].
+    apply Acc_intro.
+    intros y H2.
+    induction H2; auto with sets.
+    apply Acc_inv with y; auto with sets.
+  Qed.
+
+  Hint Resolve Acc_clos_trans.
+
+  Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y.
+  Proof.
+    induction 1 as [| x y]; auto with sets.
+    intro; apply Acc_inv with y; assumption.
+  Qed.
+
+  Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
+  Proof.
+    unfold well_founded in |- *; auto with sets.
+  Qed.
+
+End Wf_Transitive_Closure.
\ No newline at end of file
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
new file mode 100644
index 00000000..8f31ce9f
--- /dev/null
+++ b/theories/Wellfounded/Union.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: Union.v,v 1.9.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Bruno Barras *)
+
+Require Import Relation_Operators.
+Require Import Relation_Definitions.
+Require Import Transitive_Closure.
+
+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.
+
+
+  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.
+
+
+  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.
+
+End WfUnion.
\ No newline at end of file
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
new file mode 100644
index 00000000..4a20c518
--- /dev/null
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Well_Ordering.v,v 1.7.2.1 2004/07/16 19:31:19 herbelin Exp $ i*)
+
+(** Author: Cristina Cornes.
+    From: Constructing Recursion Operators in Type Theory
+    L. Paulson  JSC (1986) 2, 325-355 *)
+
+Require Import Eqdep.
+
+Section WellOrdering.
+Variable A : Set.
+Variable B : A -> Set. 
+
+Inductive WO : Set :=
+    sup : forall (a:A) (f:B a -> WO), WO.
+
+
+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.
+
+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 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.
+Qed.
+
+End Characterisation_wf_relations.
\ No newline at end of file
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
new file mode 100644
index 00000000..87c00b47
--- /dev/null
+++ b/theories/Wellfounded/Wellfounded.v
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Wellfounded.v,v 1.4.2.1 2004/07/16 19:31:19 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/theories/Wellfounded/intro.tex b/theories/Wellfounded/intro.tex
new file mode 100755
index 00000000..126071e2
--- /dev/null
+++ b/theories/Wellfounded/intro.tex
@@ -0,0 +1,4 @@
+\section{Well-founded relations}\label{Wellfounded}
+
+This library gives definitions and results about well-founded relations.
+
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
new file mode 100644
index 00000000..11fa3872
--- /dev/null
+++ b/theories/ZArith/BinInt.v
@@ -0,0 +1,1038 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+(***********************************************************)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+(***********************************************************)
+
+Require Export BinPos.
+Require Export Pnat.
+Require Import BinNat.
+Require Import Plus.
+Require Import Mult.
+(**********************************************************************)
+(** 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 *)
+Bind Scope Z_scope with Z.
+Arguments Scope Zpos [positive_scope].
+Arguments Scope Zneg [positive_scope].
+
+(** 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)
+  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)
+  end.
+
+Definition Zdouble (x:Z) :=
+  match x with
+  | 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
+  end.
+
+(** 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' =>
+      match (x' ?= y')%positive Eq with
+      | Eq => Z0
+      | Lt => Zneg (y' - x')
+      | Gt => Zpos (x' - y')
+      end
+  | Zneg x', Zpos y' =>
+      match (x' ?= y')%positive Eq with
+      | Eq => Z0
+      | Lt => Zpos (y' - x')
+      | Gt => Zneg (x' - y')
+      end
+  | Zneg x', Zneg y' => Zneg (x' + y')
+  end.
+
+Infix "+" := Zplus : Z_scope.
+
+(** Opposite *)
+
+Definition Zopp (x:Z) :=
+  match x with
+  | Z0 => Z0
+  | Zpos x => Zneg x
+  | Zneg x => Zpos x
+  end.
+
+Notation "- x" := (Zopp x) : Z_scope.
+
+(** Successor on integers *)
+
+Definition Zsucc (x:Z) := (x + Zpos 1)%Z.
+
+(** Predecessor on integers *)
+
+Definition Zpred (x:Z) := (x + Zneg 1)%Z.
+
+(** Subtraction on integers *)
+
+Definition Zminus (m n:Z) := (m + - n)%Z.
+
+Infix "-" := Zminus : Z_scope.
+
+(** 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')
+  end.
+
+Infix "*" := Zmult : Z_scope.
+
+(** 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)
+  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) ].
+
+(** Sign function *)
+
+Definition Zsgn (z:Z) : Z :=
+  match z with
+  | Z0 => Z0
+  | Zpos p => Zpos 1
+  | Zneg p => Zneg 1
+  end.
+
+(** 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'
+  end.
+
+Definition Zpred' (x:Z) :=
+  match x with
+  | 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')
+  end.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** 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.
+Proof.
+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.
+    intro n; exact (Hs (Zpos n)).
+  apply Pind with (P := fun p => P (Zneg p)).
+    change (P (Zpred' Z0)) in |- *; apply Hp; apply H0.
+    intro n; exact (Hp (Zneg n)).
+Qed.
+
+(**********************************************************************)
+(** Properties of opposite on binary integer numbers *)
+
+Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
+Proof.
+reflexivity.
+Qed.
+
+(** [opp] is involutive *)
+
+Theorem Zopp_involutive : forall n:Z, - - n = n.
+Proof.
+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 ].
+Qed.
+
+(**********************************************************************)
+(* 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.
+Qed.
+
+Lemma Zsucc'_discr : forall n:Z, n <> Zsucc' n.
+Proof.
+intro x; destruct x; simpl in |- *.
+  discriminate.
+  injection; apply Psucc_discr.
+  destruct p; simpl in |- *.
+    discriminate.
+    intro H; symmetry  in H; injection H; apply double_moins_un_xO_discr.
+    discriminate.
+Qed.
+
+(**********************************************************************)
+(** Other properties of binary integer numbers *)
+
+Lemma ZL0 : 2%nat = (1 + 1)%nat.
+Proof.
+reflexivity.
+Qed.
+
+(**********************************************************************)
+(** Properties of the addition on integers *)
+
+(** zero is left neutral for addition *)
+
+Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** zero is right neutral for addition *)
+
+Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+(** 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.
+  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 *)
+
+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.
+Qed.
+
+(** 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 ].
+Qed.
+
+Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
+Proof.
+intro; rewrite Zplus_comm; apply Zplus_opp_r.
+Qed.
+
+Hint Local Resolve Zplus_0_l Zplus_0_r.
+
+(** 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 ] ] ].
+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 ].
+Qed.
+
+
+Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p).
+Proof.
+intros; symmetry  in |- *; apply Zplus_assoc.
+Qed.
+
+(** 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.
+Qed.
+
+(** 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 ].
+Qed.
+
+(** 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.
+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.
+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.
+Qed.
+
+(** 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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********************************************************************)
+(** 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 ].
+Qed.
+
+Theorem Zpos_succ_morphism :
+ forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
+Proof.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********************************************************************)
+(** Properties of subtraction on binary integer numbers *)
+
+Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
+Proof.
+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.
+Qed.
+
+Lemma Zminus_diag : forall n:Z, n - n = Z0.
+Proof.
+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.
+Qed.
+
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(** 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.
+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.
+Qed.
+
+
+(**********************************************************************)
+(** Properties of multiplication on binary integer numbers *)
+
+(** One is neutral for multiplication *)
+
+Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
+Proof.
+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.
+Qed.
+
+(** Zero property of multiplication *)
+
+Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
+Proof.
+intro x; destruct x; reflexivity.
+Qed.
+
+Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
+Proof.
+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.
+Qed.
+
+(** 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.
+Qed.
+
+(** 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.
+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.
+Qed.
+
+(** 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.
+Qed.
+
+(** 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].
+  intro H; absurd (Z0 = Z0); trivial.
+  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
+  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
+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.
+Qed.
+
+
+Lemma Zmult_1_inversion_l :
+ 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).
+Qed.
+
+(** 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.
+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.
+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.
+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.
+Qed.
+
+Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
+Proof.
+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.
+Qed.
+
+(** 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) ] ]).
+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 ].
+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.
+Qed.
+
+(** 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.
+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.
+Qed.
+
+(** 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.
+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.
+Qed.
+
+(** 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.
+Qed.
+
+(** 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.
+Qed.
+
+Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
+Proof.
+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.
+Qed.
+
+Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
+Proof.
+intros; symmetry  in |- *; apply Zmult_succ_l.
+Qed.
+
+(** 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.
+Qed.
+
+(**********************************************************************)
+(** 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.
+Qed.
+
+Lemma Zpos_xO : forall p:positive, Zpos (xO p) = Zpos 2 * Zpos p.
+Proof.
+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.
+Qed.
+
+Lemma Zneg_xO : forall p:positive, Zneg (xO p) = Zpos 2 * Zneg p.
+Proof.
+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.
+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.
+Qed.
+
+(**********************************************************************)
+(** Order relations *)
+
+Definition Zlt (x y:Z) := (x ?= y) = Lt.
+Definition Zgt (x y:Z) := (x ?= y) = Gt.
+Definition Zle (x y:Z) := (x ?= y) <> Gt.
+Definition Zge (x y:Z) := (x ?= y) <> Lt.
+Definition Zne (x y:Z) := x <> y.
+
+Infix "<=" := Zle : Z_scope.
+Infix "<" := Zlt : Z_scope.
+Infix ">=" := Zge : Z_scope.
+Infix ">" := Zgt : Z_scope.
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope.
+Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope.
+Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
+Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.
+
+(**********************************************************************)
+(** 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
+  end.
+
+Definition Zabs (z:Z) : Z :=
+  match z with
+  | Z0 => Z0
+  | Zpos p => Zpos p
+  | Zneg p => Zpos p
+  end.
+
+(**********************************************************************)
+(** From [nat] to [Z] *)
+
+Definition Z_of_nat (x:nat) :=
+  match x with
+  | 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
+  end.
+
+Definition Z_of_N (x:N) := match x with
+                           | N0 => Z0
+                           | Npos p => Zpos p
+                           end.
\ No newline at end of file
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
new file mode 100644
index 00000000..069ddd42
--- /dev/null
+++ b/theories/ZArith/Wf_Z.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.20.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Znat.
+Require Import Zmisc.
+Require Import Wf_nat.
+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 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 ] ].
+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 ].
+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 ] ].
+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.
+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.
+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 ].
+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 ].
+Qed.
+
+Section Efficient_Rec. 
+
+(** [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_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.
+
+(** 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.
+
+(** A more general induction principal using [Zlt]. *)
+
+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.
+
+End Efficient_Rec.
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
new file mode 100644
index 00000000..78295591
--- /dev/null
+++ b/theories/ZArith/ZArith.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: ZArith.v,v 1.5.2.1 2004/07/16 19:31:20 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.
\ No newline at end of file
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
new file mode 100644
index 00000000..694e071e
--- /dev/null
+++ b/theories/ZArith/ZArith_base.v
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:20 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]. *)
+
+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 ZArith_dec.
+Require Export Zbool.
+Require Export Zmisc.
+Require Export Wf_Z.
+
+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
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
new file mode 100644
index 00000000..dbd0df6c
--- /dev/null
+++ b/theories/ZArith/ZArith_dec.v
@@ -0,0 +1,226 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:20 herbelin Exp $ i*)
+
+Require Import Sumbool.
+
+Require Import BinInt.
+Require Import Zorder.
+Require Import Zcompare.
+Open Local Scope Z_scope.
+
+Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}.
+Proof.
+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.
+Proof.
+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.
+
+End decidability.
+
+(** 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.
+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.
+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.
+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.
+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.
+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) ].
+Defined.
+
+
+
+Definition Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
+Proof.
+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
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
new file mode 100644
index 00000000..90e4c2a4
--- /dev/null
+++ b/theories/ZArith/Zabs.v
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import Arith.
+Require Import BinPos.
+Require Import BinInt.
+Require Import Zorder.
+Require Import ZArith_dec.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** 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.
+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.
+Qed.
+
+Theorem Zabs_Zopp : forall n:Z, Zabs (- n) = Zabs n.
+Proof.
+intros z; case z; simpl in |- *; auto.
+Qed.
+
+(** 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).
+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.
+Qed.
+
+Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Zabs n).
+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.
+Defined.
+
+Lemma Zabs_pos : forall n:Z, 0 <= Zabs n.
+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.
+Qed.
+
+(** 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.
+Qed.
+
+(** 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.
+Qed.
+
+Lemma Zabs_Zsgn : forall n:Z, Zabs n * Zsgn n = n.
+Proof.
+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.
+Qed.
+
+(** 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.
+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
diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v
new file mode 100644
index 00000000..fa5f00dc
--- /dev/null
+++ b/theories/ZArith/Zbinary.v
@@ -0,0 +1,426 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Bit vectors interpreted as integers. 
+    Contribution by Jean Duprat (ENS Lyon). *)
+
+Require Import Bvector.
+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.
+	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 :=
+  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
+*)
+
+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))
+*)
+
+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))
+*)	
+
+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.
+
+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 :
+ 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
new file mode 100644
index 00000000..bb8abef4
--- /dev/null
+++ b/theories/ZArith/Zbool.v
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.4.2.1 2004/07/16 19:31:21 herbelin Exp $ *)
+
+Require Import BinInt.
+Require Import Zeven.
+Require Import Zorder.
+Require Import Zcompare.
+Require Import ZArith_dec.
+Require Import 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) :=
+  match (x ?= y)%Z with
+  | Gt => false
+  | _ => true
+  end.
+Definition Zge_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Lt => false
+  | _ => true
+  end.
+Definition Zlt_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Lt => true
+  | _ => false
+  end.
+Definition Zgt_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Gt => true
+  | _ => false
+  end.
+Definition Zeq_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Eq => true
+  | _ => false
+  end.
+Definition Zneq_bool (x y:Z) :=
+  match (x ?= y)%Z with
+  | Eq => false
+  | _ => true
+  end.
+
+Lemma Zle_cases :
+ 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.
+Qed.
+
+Lemma Zlt_cases :
+ 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.
+Qed.
+
+Lemma Zge_cases :
+ 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.
+Qed.
+
+Lemma Zgt_cases :
+ 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.
+Qed.
+
+(** Lemmas on [Zle_bool] used in contrib/graphs *)
+
+Lemma Zle_bool_imp_le : forall n m:Z, Zle_bool n m = true -> (n <= m)%Z.
+Proof.
+  unfold Zle_bool, Zle in |- *. intros x y. unfold not in |- *. 
+  case (x ?= y)%Z; intros; discriminate.
+Qed.
+
+Lemma Zle_imp_le_bool : forall n m:Z, (n <= m)%Z -> Zle_bool n m = true.
+Proof.
+  unfold Zle, Zle_bool in |- *. intros x y. case (x ?= y)%Z; trivial. intro. elim (H (refl_equal _)).
+Qed.
+
+Lemma Zle_bool_refl : forall n:Z, Zle_bool n n = true.
+Proof.
+  intro. apply Zle_imp_le_bool. apply Zeq_le. reflexivity.
+Qed.
+
+Lemma Zle_bool_antisym :
+ 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.
+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 :
+  forall x y:Z, {Zle_bool x y = true} + {Zle_bool y x = true}.
+Proof.
+  intros x y; intros. unfold Zle_bool in |- *. cut ((x ?= y)%Z = Gt <-> (y ?= x)%Z = Lt).
+  case (x ?= y)%Z. left. reflexivity.
+  left. reflexivity.
+  right. rewrite (proj1 H (refl_equal _)). reflexivity.
+  apply Zcompare_Gt_Lt_antisym.
+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.
+Proof.
+  intros. apply Zle_imp_le_bool. apply Zplus_le_compat. 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 : forall n:Z, Zle_bool n 0 = false -> Zle_bool 1 n = true.
+Proof.
+  intros x; intros. apply Zle_imp_le_bool. change (Zsucc 0 <= x)%Z in |- *. apply Zgt_le_succ. generalize H.
+  unfold Zle_bool, Zgt in |- *. case (x ?= 0)%Z. intro H0. discriminate H0.
+  intro H0. discriminate H0.
+  reflexivity.
+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
new file mode 100644
index 00000000..714abfc4
--- /dev/null
+++ b/theories/ZArith/Zcompare.v
@@ -0,0 +1,501 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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 Import Lt.
+Require Import Gt.
+Require Import Plus.
+Require Import Mult.
+
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France)            *)
+(**********************************************************************)
+
+(**********************************************************************)
+(** 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 ].
+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 ] ].
+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 ].
+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.
+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 ].
+Qed.
+
+(** Transitivity of comparison *)
+
+Lemma Zcompare_Gt_trans :
+ 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 ].
+Qed.
+
+(** 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.
+Qed.
+
+Hint Local Resolve Pcompare_refl.
+
+(** Comparison first-order specification *)
+
+Lemma Zcompare_Gt_spec :
+ 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 ].
+Qed.
+
+(** 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).
+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 ].
+Qed.
+
+Hint Local Resolve ZC4.
+
+Lemma weak_Zcompare_Zplus_compatible :
+ 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 ] ] ].
+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).
+Qed.
+
+Lemma Zplus_compare_compat :
+ 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 ] ].
+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.
+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) ] ] ].
+Qed.
+
+(** 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.
+Qed.
+ 
+(** Multiplication and comparison *)
+
+Lemma Zcompare_mult_compat :
+ 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 ].
+Qed.
+
+
+(** Reverting [x ?= y] to trichotomy *)
+
+Lemma rename :
+ forall (A:Set) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x.
+Proof.
+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.
+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 ].
+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.
+Proof.
+intros c1 c2 c3 x y; intros.
+rewrite H0; rewrite Zcompare_refl.
+assumption.
+Qed.
+
+(** 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).
+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.
+Qed.
+
+(** 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.
+Proof.
+intros x y; unfold Zle in |- *; elim (x ?= y); auto with arith.
+Qed.
+
+Lemma Zlt_compare :
+ forall n m:Z,
+   n < m -> match n ?= m with
+            | Eq => False
+            | Lt => True
+            | Gt => False
+            end.
+Proof.
+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.
+Proof.
+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.
+Proof.
+intros x y; unfold Zgt in |- *; elim (x ?= y); intros;
+ discriminate || trivial with arith.
+Qed.
+
+(**********************************************************************)
+(* Other properties *)
+
+
+Lemma Zmult_compare_compat_l :
+ forall n m p:Z, p > 0 -> (n ?= m) = (p * n ?= p * m).
+Proof.
+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).
+Proof.
+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
new file mode 100644
index 00000000..b60cd37c
--- /dev/null
+++ b/theories/ZArith/Zcomplements.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.26.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+Require Import ZArithRing.
+Require Import ZArith_base.
+Require Import Omega.
+Require Import Wf_nat.
+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}. 
+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.
+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 :=
+  match a with
+  | 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********************************************************************)
+(** A list length in Z, tail recursive.  *)
+
+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
+  end. 
+
+Definition Zlength := Zlength_aux 0.
+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.
+
+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
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
new file mode 100644
index 00000000..84eb2259
--- /dev/null
+++ b/theories/ZArith/Zdiv.v
@@ -0,0 +1,423 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.21.2.1 2004/07/16 19:31:21 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 Import Zbool.
+Require Import Omega.
+Require Import ZArithRing.
+Require Import Zcomplements.
+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) (b:Z) {struct a} : 
+ Z * Z :=
+  match a with
+  | 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 (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)
+  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 :=
+  match a, b with
+  | 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' =>
+      let (q, r) := Zdiv_eucl_POS a' (Zpos b') in
+      match r with
+      | Z0 => (- 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 :
+ 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 |- *.
+
+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 BinInt.Zpos_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 BinInt.Zpos_xO;
+ change (Zpos (xO p)) with (2 * Zpos p) in |- *; 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 :
+ 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.
+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}.
+Proof.
+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}.
+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 ].
+Qed.
+
+Implicit Arguments Zdiv_eucl_extended.
+
+(** 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.
+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.
+Qed.
+
+Lemma Z_div_POS_ge0 :
+ 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.
+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.
+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.
+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]). *)
+
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
new file mode 100644
index 00000000..a4a9abde
--- /dev/null
+++ b/theories/ZArith/Zeven.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+Require Import BinInt.
+
+(**********************************************************************)
+(** About parity: even and odd predicates on Z, division by 2 on Z *)
+
+(**********************************************************************)
+(** [Zeven], [Zodd], [Zdiv2] and their related properties *)
+
+Definition Zeven (z:Z) :=
+  match z with
+  | 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
+  end.
+
+Definition Zeven_bool (z:Z) :=
+  match z with
+  | 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
+  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) ].
+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) ].
+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) ].
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Hint 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) :=
+  match z with
+  | 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.
+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.
+Qed.
+
+Lemma Zodd_div2_neg :
+ 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.
+Qed.
+
+Lemma Z_modulo_2 :
+ 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.
+Qed.
+
+Lemma Zsplit2 :
+ 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
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
new file mode 100644
index 00000000..a9ee2c87
--- /dev/null
+++ b/theories/ZArith/Zhints.v
@@ -0,0 +1,386 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.8.2.1 2004/07/16 19:31:21 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 Import BinInt.
+Require Import Zorder.
+Require Import Zmin.
+Require Import Zabs.
+Require Import Zcompare.
+Require Import Znat.
+Require Import auxiliary.
+Require Import Zmisc.
+Require Import Wf_Z.
+
+(**********************************************************************)
+(*                  Simplification lemmas                             *)
+(* No subgoal or smaller subgoals                                     *)
+
+Hint Resolve 
+  (* A) Reversible simplification lemmas (no loss of information)      *)
+  (* Should clearly declared as hints                                  *)
+  
+  (* Lemmas ending by eq *)
+  Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
+  
+  (* 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 *)
+  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 *)
+  Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
+  Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
+  Zle_refl (* :(n:Z)`n <= n` *)
+  Zle_succ (* :(n:Z)`n <= (Zs n)` *)
+  Zsucc_le_compat (* :(n,m:Z)`m <= n`->`(Zs m) <= (Zs n)` *)
+  Zle_pred (* :(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` *)
+  Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
+  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 *)
+  
+  (* 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 *)
+  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 *)
+  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 *)
+  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` *)
+  Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
+  Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
+  Zplus_le_compat (* :(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*)
\ No newline at end of file
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
new file mode 100644
index 00000000..b575de88
--- /dev/null
+++ b/theories/ZArith/Zlogarithm.v
@@ -0,0 +1,265 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.14.2.1 2004/07/16 19:31:21 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 Import ZArith_base.
+Require Import Omega.
+Require Import Zcomplements.
+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] 
+    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*)
+
+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.
+
+End divers.
+
+
+
+
+
+
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
new file mode 100644
index 00000000..d48e62c5
--- /dev/null
+++ b/theories/ZArith/Zmin.v
@@ -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        *)
+(************************************************************************)
+(*i $Id: Zmin.v,v 1.3.2.1 2004/07/16 19:31:21 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import Arith.
+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
+  end.
+
+(** Properties of minimum on binary integer numbers *)
+
+Lemma Zmin_SS : forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc 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.
+Qed.
+
+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 ].
+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 ].
+Qed.
+
+Lemma Zmin_case : forall (n m:Z) (P:Z -> Set), 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.
+
+Lemma Zmin_or : forall n m:Z, Zmin n m = n \/ Zmin n m = m.
+Proof.
+unfold Zmin in |- *; intros; elim (n ?= m); auto.
+Qed.
+
+Lemma Zmin_n_n : forall n:Z, Zmin n n = n.
+Proof.
+unfold Zmin in |- *; intros; elim (n ?= n); auto.
+Qed.
+
+Lemma Zmin_plus : forall n m p:Z, Zmin (n + p) (m + p) = Zmin n m + p.
+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.
+Qed.
+
+(**********************************************************************)
+(** Maximum of two binary integer numbers *)
+
+Definition Zmax a b := match a ?= b with
+                       | Lt => b
+                       | _ => a
+                       end.
+
+(** Properties of maximum on binary integer numbers *)
+
+Ltac CaseEq name :=
+  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+
+Theorem Zmax1 : forall a b, a <= Zmax a b.
+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.
+Qed.
+
+Theorem Zmax2 : forall a b, b <= Zmax a b.
+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).
+Qed.
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
new file mode 100644
index 00000000..adcaf0ba
--- /dev/null
+++ b/theories/ZArith/Zmisc.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: Zmisc.v,v 1.20.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Bool.
+Open Local Scope Z_scope.
+
+(**********************************************************************)
+(** Iterators *)
+
+(** [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)
+  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))
+  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
+  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).
+Proof.    
+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.
+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 ].
+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).
+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.
+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).
+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 ].
+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).
+Proof.    
+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
new file mode 100644
index 00000000..d051ed74
--- /dev/null
+++ b/theories/ZArith/Znat.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.3.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+
+Require Export Arith.
+Require Import BinPos.
+Require Import BinInt.
+Require Import Zcompare.
+Require Import Zorder.
+Require Import Decidable.
+Require Import 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 : 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 ].
+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 ].
+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 ].
+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 ].
+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 ] ].
+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.
+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.
+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.
+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.
+Qed.
+
+Theorem intro_Z :
+ 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 ].
+Qed.
+
+Theorem inj_minus1 :
+ 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.
+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 ].
+Qed.
+
+Theorem Zpos_eq_Z_of_nat_o_nat_of_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.
+Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
new file mode 100644
index 00000000..715cdc7d
--- /dev/null
+++ b/theories/ZArith/Znumtheory.v
@@ -0,0 +1,640 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.5.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import ZArith_base.
+Require Import ZArithRing.
+Require Import Zcomplements.
+Require Import Zdiv.
+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 : forall q:Z, b = q * a -> Zdivide a b.
+
+(** Syntax for divisibility *)
+
+Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope.
+
+(** Results concerning divisibility*)
+
+Lemma Zdivide_refl : forall a:Z, (a | a).
+Proof.
+intros; apply Zdivide_intro with 1; ring.
+Qed.
+
+Lemma Zone_divide : forall a:Z, (1 | a).
+Proof.
+intros; apply Zdivide_intro with a; ring.
+Qed.
+
+Lemma Zdivide_0 : forall a:Z, (a | 0).
+Proof.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma Zdivide_factor_r : forall a b:Z, (a | a * b).
+Proof.
+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.
+Qed.
+
+Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
+  Zdivide_opp_l_rev Zdivide_minus_l Zdivide_mult_l Zdivide_mult_r
+  Zdivide_factor_r Zdivide_factor_l: zarith.
+
+(** Auxiliary result. *)
+
+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].
+  assumption.
+  rewrite Hneg in H; simpl in H.
+  contradiction (Zle_not_lt 0 (-1)).
+    apply Zge_le; assumption.
+    apply Zorder.Zlt_neg_0.
+Qed.
+
+(** Only [1] and [-1] divide [1]. *)
+
+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.
+Qed.
+
+(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)
+
+Lemma Zdivide_antisym : forall a b:Z, (a | b) -> (b | a) -> a = b \/ a = - b.
+Proof.
+simple 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_l with a.
+assumption.
+ring.
+pattern a at 2 in |- *; 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.
+Qed.
+
+(** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)
+
+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.
+Qed.
+
+(** * 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 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.
+
+(** 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.
+Qed.
+
+Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 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.
+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.
+Qed.
+
+Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
+
+(** * Extended Euclid algorithm. *)
+
+(** Euclid's algorithm to compute the [gcd] mainly relies on
+    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.
+Proof.
+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.
+Proof.
+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,
+    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.
+
+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)]. *)
+
+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.
+
+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'.
+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).
+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.
+
+(** 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.
+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.
+Qed.
+
+(** * Relative primality *)
+
+Definition rel_prime (a b:Z) : Prop := Zis_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 : forall a b:Z, rel_prime a b -> Bezout a b 1.
+Proof.
+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.
+Qed.
+
+(** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
+    relatively prime, then [a] divides [c]. *)
+
+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 ].
+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).
+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.
+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.
+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.
+Qed.
+
+(** * Primality *)
+
+Inductive prime (p:Z) : Prop :=
+    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.
+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.
+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.
+Qed.
+
+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.
+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.
+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.
+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).
+Proof.
+intro p; simple induction 1; intros.
+case (Zdivide_dec p a); intuition.
+right; apply Gauss with a; auto with zarith.
+Qed.
+
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
new file mode 100644
index 00000000..55d4d958
--- /dev/null
+++ b/theories/ZArith/Zorder.v
@@ -0,0 +1,965 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.6.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
+
+Require Import BinPos.
+Require Import BinInt.
+Require Import Arith.
+Require Import Decidable.
+Require Import Zcompare.
+
+Open Local Scope Z_scope.
+
+Implicit Types x y z : Z.
+
+(**********************************************************************)
+(** Properties of the order relations on binary integers *)
+
+(** 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)).
+  set (x := m ?= n) in H at 2 |- *.
+  destruct x;
+   [ 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.
+Qed.
+
+(**********************************************************************)
+(** 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 ].
+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 ] ].
+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 ].
+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 ].
+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 ]. 
+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 ].
+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 ] ].
+Qed. 
+
+(** 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.
+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.
+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.
+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.
+Qed.
+
+Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
+Proof.
+trivial.
+Qed.
+
+Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
+Proof.
+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.
+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.
+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 ].
+Qed.
+ 
+Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
+Proof.
+unfold Zlt, Zge in |- *; auto with arith.
+Qed.
+
+Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
+Proof.
+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 ].
+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.
+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.
+Qed.
+ 
+(** Reflexivity *)
+
+Lemma Zle_refl : forall n:Z, n <= n.
+Proof.
+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.
+Qed.
+
+Hint Resolve Zle_refl: zarith.
+
+(** Antisymmetry *)
+
+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]]. 
+  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_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 ].
+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.
+Qed.
+
+(** Irreflexivity *)
+
+Lemma Zgt_irrefl : forall n:Z, ~ n > n.
+Proof.
+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).
+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).
+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.
+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 ].
+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 ].
+Qed.
+
+(** Transitivity of strict orders *)
+
+Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
+Proof.
+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.
+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 ].
+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 ].
+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 ].
+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 ].
+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).
+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.
+Qed.
+
+Hint Resolve Zle_trans: zarith.
+
+(** 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.
+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.
+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.
+Qed.
+
+Hint Resolve Zsucc_le_compat: zarith.
+
+(** Simplification of successor wrt to order *)
+
+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.
+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.
+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.
+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.
+Qed.
+
+Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
+Proof.
+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.
+Qed.
+
+Lemma Zlt_pred : forall n:Z, Zpred n < n.
+Proof.
+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 ].
+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.
+  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.
+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.
+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.
+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.
+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 ].
+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.
+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.
+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 ].
+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.
+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 ].
+Qed.
+
+Hint Resolve Zle_le_succ: zarith.
+
+(** Relating order wrt successor and order wrt predecessor *)
+
+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.
+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.
+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.
+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.
+Qed.
+
+
+(** Special cases of ordered integers *)
+
+Lemma Zlt_0_1 : 0 < 1.
+Proof.
+change (0 < Zsucc 0) in |- *. apply Zlt_succ.
+Qed.
+
+Lemma Zle_0_1 : 0 <= 1.
+Proof.
+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.
+Qed.
+
+Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
+unfold Zgt in |- *; trivial.
+Qed.
+
+  (* weaker but useful (in [Zpower] for instance) *)
+Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
+intro; unfold Zle in |- *; discriminate.
+Qed.
+
+Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
+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 ].
+Qed.
+
+Hint Immediate Zeq_le: zarith.
+
+(** Transitivity using successor *)
+
+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 ].
+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).
+  apply Zgt_succ_le; assumption.
+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 *)
+
+
+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.
+  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 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.
+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.
+  contradiction (Zlt_irrefl 0).
+  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
+    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.
+Qed.
+
+Lemma Zmult_gt_0_lt_compat_r :
+ 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 ].
+Qed.
+
+Lemma Zmult_gt_0_le_compat_r :
+ 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.
+Qed.
+
+Lemma Zmult_lt_0_le_compat_r :
+ 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.
+Qed.
+
+Lemma Zmult_gt_0_lt_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_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.
+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.
+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.
+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.
+Qed.
+
+Lemma Zmult_ge_compat :
+ 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.
+Qed.
+
+Lemma Zmult_le_compat :
+ 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.
+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.
+  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.
+  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.
+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.
+  intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
+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.
+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.
+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.
+Qed.
+
+
+(** Compatibility of multiplication by a positive wrt to being positive *)
+
+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 |- *.
+  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.
+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)).
+  rewrite Zcompare_mult_compat; trivial.
+intros p H; discriminate H.
+Qed.
+
+Lemma Zmult_lt_O_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.
+Qed.
+
+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.
+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 ].
+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 ].
+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.
+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.
+Qed.
+
+(** Simplification of square wrt order *)
+
+Lemma Zgt_square_simpl :
+ forall n m:Z, n >= 0 -> m >= 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.
+Qed.
+
+Lemma Zlt_square_simpl :
+ forall n m:Z, 0 <= n -> 0 <= m -> 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.
+Qed.
+
+(** 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.
+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.
+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. 
+  assumption.
+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.
+Qed.
+
+Lemma Zlt_O_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.
+Qed.
\ No newline at end of file
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
new file mode 100644
index 00000000..e5bf8b04
--- /dev/null
+++ b/theories/ZArith/Zpower.v
@@ -0,0 +1,372 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+Require Import ZArith_base.
+Require Import Omega.
+Require Import Zcomplements.
+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 (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.
+
+End section1.
+
+(* Exporting notation "^" *)
+
+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.
+
+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.
+  
+(** 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.
+
+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
+            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 :=
+    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
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v
new file mode 100644
index 00000000..583c5828
--- /dev/null
+++ b/theories/ZArith/Zsqrt.v
@@ -0,0 +1,163 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.11.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+
+Require Import Omega.
+Require Export ZArith_base.
+Require Export ZArithRing.
+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. *)
+Ltac compute_POS :=
+  match goal with
+  |  |- context [(Zpos (xI ?X1))] =>
+      match constr:X1 with
+      | context [1%positive] => fail
+      | _ => rewrite (BinInt.Zpos_xI X1)
+      end
+  |  |- context [(Zpos (xO ?X1))] =>
+      match constr:X1 with
+      | context [1%positive] => fail
+      | _ => 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.
+
+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)
+                  (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)
+                  (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)
+                  (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)
+                  (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.
+Defined.
+
+(** Define with integer input, but with a strong (readable) specification. *)
+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
+        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
+                (fun s:Z =>
+                   {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
+            {s : Z & 
+            {r : Z |
+            Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
+            (h (refl_equal Datatypes.Gt))
+    | Z0 =>
+        fun h =>
+          existS
+            (fun s:Z =>
+               {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 ].
+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 =>
+      match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
+      | existS s _ => s
+      end
+  | 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.
+Qed.
+
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
new file mode 100644
index 00000000..8633986b
--- /dev/null
+++ b/theories/ZArith/Zwf.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.7.2.1 2004/07/16 19:31:22 herbelin Exp $ *)
+
+Require Import ZArith_base.
+Require Export Wf_nat.
+Require Import Omega.
+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 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|] *)
+
+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.
+
+Hint 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 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|] *)
+
+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.
+
+End wf_proof_up.
+
+Hint Resolve Zwf_up_well_founded: datatypes v62.
\ No newline at end of file
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
new file mode 100644
index 00000000..ecd2daab
--- /dev/null
+++ b/theories/ZArith/auxiliary.v
@@ -0,0 +1,150 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.12.2.1 2004/07/16 19:31:22 herbelin Exp $ i*)
+
+(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
+
+Require Export Arith.
+Require Import BinInt.
+Require Import Zorder.
+Require Import Decidable.
+Require Import 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 : 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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+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.
+Qed.
+
+(**********************************************************************)
+(** Factorization lemmas *)
+
+Theorem Zred_factor0 : forall n:Z, n = n * 1.
+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.
+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.
+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.
+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.
+Qed.
+
+Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
+
+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.
+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 ].
+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 ].
+
+Qed.
diff --git a/theories/ZArith/intro.tex b/theories/ZArith/intro.tex
new file mode 100755
index 00000000..21e52c19
--- /dev/null
+++ b/theories/ZArith/intro.tex
@@ -0,0 +1,6 @@
+\section{Binary integers : ZArith}
+The {\tt ZArith} library deals with binary integers (those used
+by the {\tt Omega} decision tactic).
+Here are defined various arithmetical notions and their properties,
+similar to those of {\tt Arith}.
+
diff --git a/theories7/Arith/Arith.v b/theories7/Arith/Arith.v
new file mode 100755
index 00000000..181fadbc
--- /dev/null
+++ b/theories7/Arith/Arith.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Arith.v,v 1.1.2.1 2004/07/16 19:31:23 herbelin Exp $ i*)
+
+Require Export Le.
+Require Export Lt.
+Require Export Plus.
+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/theories7/Arith/Between.v b/theories7/Arith/Between.v
new file mode 100755
index 00000000..b3fef325
--- /dev/null
+++ b/theories7/Arith/Between.v
@@ -0,0 +1,185 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c36f8f15
--- /dev/null
+++ b/theories7/Arith/Bool_nat.v
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..1bca3fbe
--- /dev/null
+++ b/theories7/Arith/Compare.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        *)
+(************************************************************************)
+
+(*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
new file mode 100755
index 00000000..504c0562
--- /dev/null
+++ b/theories7/Arith/Compare_dec.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..59694628
--- /dev/null
+++ b/theories7/Arith/Div.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: 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
new file mode 100644
index 00000000..8bd0160f
--- /dev/null
+++ b/theories7/Arith/Div2.v
@@ -0,0 +1,174 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..9f5ee7ee
--- /dev/null
+++ b/theories7/Arith/EqNat.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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..adeaf713
--- /dev/null
+++ b/theories7/Arith/Euclid.v
@@ -0,0 +1,65 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..bcc413f5
--- /dev/null
+++ b/theories7/Arith/Even.v
@@ -0,0 +1,310 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..a8a60c98
--- /dev/null
+++ b/theories7/Arith/Factorial.v
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100755
index 00000000..16b6f203
--- /dev/null
+++ b/theories7/Arith/Gt.v
@@ -0,0 +1,149 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..cdb98645
--- /dev/null
+++ b/theories7/Arith/Le.v
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..9bb1d564
--- /dev/null
+++ b/theories7/Arith/Lt.v
@@ -0,0 +1,176 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..aea389d1
--- /dev/null
+++ b/theories7/Arith/Max.v
@@ -0,0 +1,87 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..fd5da61a
--- /dev/null
+++ b/theories7/Arith/Min.v
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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
new file mode 100755
index 00000000..709d5f0b
--- /dev/null
+++ b/theories7/Arith/Minus.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100755
index 00000000..9bd4aaf9
--- /dev/null
+++ b/theories7/Arith/Mult.v
@@ -0,0 +1,224 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..6646545a
--- /dev/null
+++ b/theories7/Arith/Peano_dec.v
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..23488b4c
--- /dev/null
+++ b/theories7/Arith/Plus.v
@@ -0,0 +1,223 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..be1003ce
--- /dev/null
+++ b/theories7/Arith/Wf_nat.v
@@ -0,0 +1,200 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..cd75cf30
--- /dev/null
+++ b/theories7/Bool/Bool.v
@@ -0,0 +1,544 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b670dbdd
--- /dev/null
+++ b/theories7/Bool/BoolEq.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..e6545381
--- /dev/null
+++ b/theories7/Bool/Bvector.v
@@ -0,0 +1,266 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/DecBool.v b/theories7/Bool/DecBool.v
new file mode 100755
index 00000000..c22cd032
--- /dev/null
+++ b/theories7/Bool/DecBool.v
@@ -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        *)
+(************************************************************************)
+
+(*i $Id: DecBool.v,v 1.1.2.1 2004/07/16 19:31:25 herbelin Exp $ i*)
+
+Set Implicit Arguments.
+
+Definition ifdec : (A,B:Prop)(C:Set)({A}+{B})->C->C->C
+   := [A,B,C,H,x,y]if H then [_]x else [_]y.
+
+
+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.
diff --git a/theories7/Bool/IfProp.v b/theories7/Bool/IfProp.v
new file mode 100755
index 00000000..bcfa4be3
--- /dev/null
+++ b/theories7/Bool/IfProp.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..8d55cbb6
--- /dev/null
+++ b/theories7/Bool/Sumbool.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: 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
new file mode 100755
index 00000000..24e48c28
--- /dev/null
+++ b/theories7/Bool/Zerob.v
@@ -0,0 +1,36 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..006ec08e
--- /dev/null
+++ b/theories7/Init/Datatypes.v
@@ -0,0 +1,125 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..6ba9c7a1
--- /dev/null
+++ b/theories7/Init/Logic.v
@@ -0,0 +1,306 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..793b671c
--- /dev/null
+++ b/theories7/Init/Logic_Type.v
@@ -0,0 +1,304 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..34bfcbfa
--- /dev/null
+++ b/theories7/Init/Notations.v
@@ -0,0 +1,94 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..72d19399
--- /dev/null
+++ b/theories7/Init/Peano.v
@@ -0,0 +1,218 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/Prelude.v b/theories7/Init/Prelude.v
new file mode 100755
index 00000000..2752f462
--- /dev/null
+++ b/theories7/Init/Prelude.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: Prelude.v,v 1.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*)
+
+Require Export Notations.
+Require Export Logic.
+Require Export Datatypes.
+Require Export Specif.
+Require Export Peano.
+Require Export Wf.
diff --git a/theories7/Init/Specif.v b/theories7/Init/Specif.v
new file mode 100755
index 00000000..c39e5ed8
--- /dev/null
+++ b/theories7/Init/Specif.v
@@ -0,0 +1,204 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..b65057eb
--- /dev/null
+++ b/theories7/Init/Wf.v
@@ -0,0 +1,158 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9e8dd1b3
--- /dev/null
+++ b/theories7/IntMap/Adalloc.v
@@ -0,0 +1,339 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..50dc1480
--- /dev/null
+++ b/theories7/IntMap/Addec.v
@@ -0,0 +1,179 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9f362772
--- /dev/null
+++ b/theories7/IntMap/Addr.v
@@ -0,0 +1,456 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..a7948c72
--- /dev/null
+++ b/theories7/IntMap/Adist.v
@@ -0,0 +1,321 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e76e210f
--- /dev/null
+++ b/theories7/IntMap/Allmaps.v
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..545c1716
--- /dev/null
+++ b/theories7/IntMap/Fset.v
@@ -0,0 +1,338 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..31b71c62
--- /dev/null
+++ b/theories7/IntMap/Lsort.v
@@ -0,0 +1,537 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..00ba3f8a
--- /dev/null
+++ b/theories7/IntMap/Map.v
@@ -0,0 +1,786 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..085afd69
--- /dev/null
+++ b/theories7/IntMap/Mapaxioms.v
@@ -0,0 +1,670 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..181050b1
--- /dev/null
+++ b/theories7/IntMap/Mapc.v
@@ -0,0 +1,457 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*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
new file mode 100644
index 00000000..7beb1fd4
--- /dev/null
+++ b/theories7/IntMap/Mapcanon.v
@@ -0,0 +1,376 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..5c5e2a93
--- /dev/null
+++ b/theories7/IntMap/Mapcard.v
@@ -0,0 +1,670 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..8061f253
--- /dev/null
+++ b/theories7/IntMap/Mapfold.v
@@ -0,0 +1,381 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..144572fd
--- /dev/null
+++ b/theories7/IntMap/Mapiter.v
@@ -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        *)
+(************************************************************************)
+(*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
new file mode 100644
index 00000000..f01ee3d8
--- /dev/null
+++ b/theories7/IntMap/Maplists.v
@@ -0,0 +1,399 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c0b1cccd
--- /dev/null
+++ b/theories7/IntMap/Mapsubset.v
@@ -0,0 +1,554 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..574b2688
--- /dev/null
+++ b/theories7/Lists/List.v
@@ -0,0 +1,261 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9bf259da
--- /dev/null
+++ b/theories7/Lists/ListSet.v
@@ -0,0 +1,389 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..2ab78f7f
--- /dev/null
+++ b/theories7/Lists/MonoList.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e69ecd10
--- /dev/null
+++ b/theories7/Lists/PolyList.v
@@ -0,0 +1,646 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..15c57166
--- /dev/null
+++ b/theories7/Lists/PolyListSyntax.v
@@ -0,0 +1,10 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..ccfc4895
--- /dev/null
+++ b/theories7/Lists/Streams.v
@@ -0,0 +1,170 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..f7adda70
--- /dev/null
+++ b/theories7/Lists/TheoryList.v
@@ -0,0 +1,386 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..db9007ec
--- /dev/null
+++ b/theories7/Logic/Berardi.v
@@ -0,0 +1,170 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..5b7e002a
--- /dev/null
+++ b/theories7/Logic/ChoiceFacts.v
@@ -0,0 +1,134 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/Classical.v b/theories7/Logic/Classical.v
new file mode 100755
index 00000000..8d7fe1d1
--- /dev/null
+++ b/theories7/Logic/Classical.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: Classical.v,v 1.1.2.1 2004/07/16 19:31:29 herbelin Exp $ i*)
+
+(** Classical Logic *)
+
+Require Export Classical_Prop.
+Require Export Classical_Pred_Type.
diff --git a/theories7/Logic/ClassicalChoice.v b/theories7/Logic/ClassicalChoice.v
new file mode 100644
index 00000000..5419e958
--- /dev/null
+++ b/theories7/Logic/ClassicalChoice.v
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $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
new file mode 100644
index 00000000..85700c22
--- /dev/null
+++ b/theories7/Logic/ClassicalDescription.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: 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
new file mode 100644
index 00000000..1d37652e
--- /dev/null
+++ b/theories7/Logic/ClassicalFacts.v
@@ -0,0 +1,214 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..b1c26e6d
--- /dev/null
+++ b/theories7/Logic/Classical_Pred_Set.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: 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
new file mode 100755
index 00000000..69175ec7
--- /dev/null
+++ b/theories7/Logic/Classical_Pred_Type.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: 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
new file mode 100755
index 00000000..1dc7ec57
--- /dev/null
+++ b/theories7/Logic/Classical_Prop.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..e34170cd
--- /dev/null
+++ b/theories7/Logic/Classical_Type.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100644
index 00000000..537b5e88
--- /dev/null
+++ b/theories7/Logic/Decidable.v
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9f5f91a0
--- /dev/null
+++ b/theories7/Logic/Diaconescu.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        *)
+(************************************************************************)
+
+(*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
new file mode 100755
index 00000000..fc2dfe52
--- /dev/null
+++ b/theories7/Logic/Eqdep.v
@@ -0,0 +1,183 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..959395e3
--- /dev/null
+++ b/theories7/Logic/Eqdep_dec.v
@@ -0,0 +1,149 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..066e51aa
--- /dev/null
+++ b/theories7/Logic/Hurkens.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        *)
+(************************************************************************)
+(*                              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
new file mode 100644
index 00000000..38dfa5e6
--- /dev/null
+++ b/theories7/Logic/JMeq.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: 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
new file mode 100644
index 00000000..3f031ff7
--- /dev/null
+++ b/theories7/Logic/ProofIrrelevance.v
@@ -0,0 +1,113 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e61f3582
--- /dev/null
+++ b/theories7/Logic/RelationalChoice.v
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..5e04e22e
--- /dev/null
+++ b/theories7/NArith/BinNat.v
@@ -0,0 +1,205 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..ae61587d
--- /dev/null
+++ b/theories7/NArith/BinPos.v
@@ -0,0 +1,894 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/NArith.v b/theories7/NArith/NArith.v
new file mode 100644
index 00000000..d924ae2e
--- /dev/null
+++ b/theories7/NArith/NArith.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: NArith.v,v 1.1.2.1 2004/07/16 19:31:31 herbelin Exp $ *)
+
+(** Library for binary natural numbers *)
+
+Require Export BinPos.
+Require Export BinNat.
diff --git a/theories7/NArith/Pnat.v b/theories7/NArith/Pnat.v
new file mode 100644
index 00000000..d62661ed
--- /dev/null
+++ b/theories7/NArith/Pnat.v
@@ -0,0 +1,472 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..702daffc
--- /dev/null
+++ b/theories7/Reals/Alembert.v
@@ -0,0 +1,549 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..af4b558a
--- /dev/null
+++ b/theories7/Reals/AltSeries.v
@@ -0,0 +1,362 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..468675ca
--- /dev/null
+++ b/theories7/Reals/ArithProp.v
@@ -0,0 +1,134 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..1dfd2ec0
--- /dev/null
+++ b/theories7/Reals/Binomial.v
@@ -0,0 +1,181 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9442eff0
--- /dev/null
+++ b/theories7/Reals/Cauchy_prod.v
@@ -0,0 +1,347 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..481e51bf
--- /dev/null
+++ b/theories7/Reals/Cos_plus.v
@@ -0,0 +1,1017 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e29825ab
--- /dev/null
+++ b/theories7/Reals/Cos_rel.v
@@ -0,0 +1,360 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..31c90727
--- /dev/null
+++ b/theories7/Reals/DiscrR.v
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..6ed9c00b
--- /dev/null
+++ b/theories7/Reals/Exp_prop.v
@@ -0,0 +1,890 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..410429ed
--- /dev/null
+++ b/theories7/Reals/Integration.v
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..eae414b1
--- /dev/null
+++ b/theories7/Reals/MVT.v
@@ -0,0 +1,517 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..56e5f15e
--- /dev/null
+++ b/theories7/Reals/NewtonInt.v
@@ -0,0 +1,600 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..68645379
--- /dev/null
+++ b/theories7/Reals/PSeries_reg.v
@@ -0,0 +1,194 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..ee5fa498
--- /dev/null
+++ b/theories7/Reals/PartSum.v
@@ -0,0 +1,476 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.1 2004/07/16 19:31:33 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; Pose l1 := (sum_f_R0 An N).
+Fold l1 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
new file mode 100644
index 00000000..00d41c70
--- /dev/null
+++ b/theories7/Reals/RIneq.v
@@ -0,0 +1,1631 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b89296fb
--- /dev/null
+++ b/theories7/Reals/RList.v
@@ -0,0 +1,427 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..621cca64
--- /dev/null
+++ b/theories7/Reals/R_Ifp.v
@@ -0,0 +1,552 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..fc01a164
--- /dev/null
+++ b/theories7/Reals/R_sqr.v
@@ -0,0 +1,232 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..8c87659b
--- /dev/null
+++ b/theories7/Reals/R_sqrt.v
@@ -0,0 +1,251 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d5d84f50
--- /dev/null
+++ b/theories7/Reals/Ranalysis.v
@@ -0,0 +1,477 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..8cb4c358
--- /dev/null
+++ b/theories7/Reals/Ranalysis1.v
@@ -0,0 +1,1046 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..35fa58d5
--- /dev/null
+++ b/theories7/Reals/Ranalysis2.v
@@ -0,0 +1,302 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..6ce63bbc
--- /dev/null
+++ b/theories7/Reals/Ranalysis3.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..061854dc
--- /dev/null
+++ b/theories7/Reals/Ranalysis4.v
@@ -0,0 +1,313 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..caf8524c
--- /dev/null
+++ b/theories7/Reals/Raxioms.v
@@ -0,0 +1,172 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..54226206
--- /dev/null
+++ b/theories7/Reals/Rbase.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100644
index 00000000..3d143e34
--- /dev/null
+++ b/theories7/Reals/Rbasic_fun.v
@@ -0,0 +1,476 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..5985a382
--- /dev/null
+++ b/theories7/Reals/Rcomplete.v
@@ -0,0 +1,175 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..79be0176
--- /dev/null
+++ b/theories7/Reals/Rdefinitions.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b55aa6ea
--- /dev/null
+++ b/theories7/Reals/Rderiv.v
@@ -0,0 +1,453 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d0f879ab
--- /dev/null
+++ b/theories7/Reals/Reals.v
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100644
index 00000000..fe6ccd96
--- /dev/null
+++ b/theories7/Reals/Rfunctions.v
@@ -0,0 +1,832 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..12c52e37
--- /dev/null
+++ b/theories7/Reals/Rgeom.v
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..c9301b56
--- /dev/null
+++ b/theories7/Reals/RiemannInt.v
@@ -0,0 +1,1699 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.1 2004/07/16 19:31:34 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; Pose phi1 := (phi_sequence RinvN pr1); 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.
+Fold phi1 in u0; 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; Pose phi1 := (phi_sequence RinvN pr1 n); Fold phi1 in H8; Pose phi2 := (phi_sequence RinvN pr2 n); Fold phi2 in H3; Pose phi3 := (phi_sequence RinvN pr3 n); Fold phi2 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 ``(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.
+Fold phi3 in H1; 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
new file mode 100644
index 00000000..3e2cc457
--- /dev/null
+++ b/theories7/Reals/RiemannInt_SF.v
@@ -0,0 +1,1400 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..3308b2e3
--- /dev/null
+++ b/theories7/Reals/Rlimit.v
@@ -0,0 +1,539 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..0acfa8d2
--- /dev/null
+++ b/theories7/Reals/Rpower.v
@@ -0,0 +1,560 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..a524a915
--- /dev/null
+++ b/theories7/Reals/Rprod.v
@@ -0,0 +1,164 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..a38099dd
--- /dev/null
+++ b/theories7/Reals/Rseries.v
@@ -0,0 +1,279 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..f9e8e92b
--- /dev/null
+++ b/theories7/Reals/Rsigma.v
@@ -0,0 +1,117 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..17367dce
--- /dev/null
+++ b/theories7/Reals/Rsqrt_def.v
@@ -0,0 +1,688 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..7b1b6266
--- /dev/null
+++ b/theories7/Reals/Rsyntax.v
@@ -0,0 +1,236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..f2ae19b9
--- /dev/null
+++ b/theories7/Reals/Rtopology.v
@@ -0,0 +1,1178 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..2b19a00a
--- /dev/null
+++ b/theories7/Reals/Rtrigo.v
@@ -0,0 +1,1111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..db0e2fea
--- /dev/null
+++ b/theories7/Reals/Rtrigo_alt.v
@@ -0,0 +1,294 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..ab181106
--- /dev/null
+++ b/theories7/Reals/Rtrigo_calc.v
@@ -0,0 +1,350 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..0897416b
--- /dev/null
+++ b/theories7/Reals/Rtrigo_def.v
@@ -0,0 +1,357 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..bc72c0e1
--- /dev/null
+++ b/theories7/Reals/Rtrigo_fun.v
@@ -0,0 +1,118 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..02e40caf
--- /dev/null
+++ b/theories7/Reals/Rtrigo_reg.v
@@ -0,0 +1,497 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b34fa339
--- /dev/null
+++ b/theories7/Reals/SeqProp.v
@@ -0,0 +1,1089 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..dd93c304
--- /dev/null
+++ b/theories7/Reals/SeqSeries.v
@@ -0,0 +1,307 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/SplitAbsolu.v b/theories7/Reals/SplitAbsolu.v
new file mode 100644
index 00000000..30580a0c
--- /dev/null
+++ b/theories7/Reals/SplitAbsolu.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i      $Id: SplitAbsolu.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $       i*)
+
+Require Rbasic_fun.
+
+Recursive Tactic Definition SplitAbs :=
+  Match Context With
+    | [ |- [(case_Rabsolu ?1)] ] -> 
+         Case (case_Rabsolu ?1); Try SplitAbs.
+
+
+Recursive Tactic Definition SplitAbsolu :=
+  Match Context With
+    | [ id:[(Rabsolu ?)] |- ? ] -> Generalize id; Clear id;Try SplitAbsolu
+    | [ |- [(Rabsolu ?1)] ] ->  Unfold Rabsolu; Try SplitAbs;Intros.
diff --git a/theories7/Reals/SplitRmult.v b/theories7/Reals/SplitRmult.v
new file mode 100644
index 00000000..392675c3
--- /dev/null
+++ b/theories7/Reals/SplitRmult.v
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: SplitRmult.v,v 1.1.2.1 2004/07/16 19:31:36 herbelin Exp $ i*)
+
+(*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
+
+
+Require Rbase.
+
+Recursive Tactic Definition SplitRmult :=
+  Match Context With
+  | [ |- ~(Rmult ?1 ?2)==R0 ] -> Apply mult_non_zero; Split;Try SplitRmult.
+
diff --git a/theories7/Reals/Sqrt_reg.v b/theories7/Reals/Sqrt_reg.v
new file mode 100644
index 00000000..d2068e5d
--- /dev/null
+++ b/theories7/Reals/Sqrt_reg.v
@@ -0,0 +1,297 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..c53db971
--- /dev/null
+++ b/theories7/Relations/Newman.v
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..4f1818bc
--- /dev/null
+++ b/theories7/Relations/Operators_Properties.v
@@ -0,0 +1,98 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..1e38e753
--- /dev/null
+++ b/theories7/Relations/Relation_Definitions.v
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100755
index 00000000..14c2ae30
--- /dev/null
+++ b/theories7/Relations/Relation_Operators.v
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..694d0eec
--- /dev/null
+++ b/theories7/Relations/Relations.v
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100755
index 00000000..3747b45e
--- /dev/null
+++ b/theories7/Relations/Rstar.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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..f8176f60
--- /dev/null
+++ b/theories7/Setoids/Setoid.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..a6928ffd
--- /dev/null
+++ b/theories7/Sets/Classical_sets.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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..35c88e9d
--- /dev/null
+++ b/theories7/Sets/Constructive_sets.v
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..2fe46be6
--- /dev/null
+++ b/theories7/Sets/Cpo.v
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..c3a044c0
--- /dev/null
+++ b/theories7/Sets/Ensembles.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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..fb53994d
--- /dev/null
+++ b/theories7/Sets/Finite_sets.v
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..63d4d2ad
--- /dev/null
+++ b/theories7/Sets/Finite_sets_facts.v
@@ -0,0 +1,345 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..0794a3bb
--- /dev/null
+++ b/theories7/Sets/Image.v
@@ -0,0 +1,199 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..bf423753
--- /dev/null
+++ b/theories7/Sets/Infinite_sets.v
@@ -0,0 +1,232 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..7dee371f
--- /dev/null
+++ b/theories7/Sets/Integers.v
@@ -0,0 +1,166 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..b5d5edf7
--- /dev/null
+++ b/theories7/Sets/Multiset.v
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..759cf4e2
--- /dev/null
+++ b/theories7/Sets/Partial_Order.v
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..2d0413a8
--- /dev/null
+++ b/theories7/Sets/Permut.v
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..b1fa892c
--- /dev/null
+++ b/theories7/Sets/Powerset.v
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..1a51c562
--- /dev/null
+++ b/theories7/Sets/Powerset_Classical_facts.v
@@ -0,0 +1,338 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..fbe7d93e
--- /dev/null
+++ b/theories7/Sets/Powerset_facts.v
@@ -0,0 +1,276 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..d4ed823b
--- /dev/null
+++ b/theories7/Sets/Relations_1.v
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..cf73ce8b
--- /dev/null
+++ b/theories7/Sets/Relations_1_facts.v
@@ -0,0 +1,109 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..92a1236e
--- /dev/null
+++ b/theories7/Sets/Relations_2.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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..b82438eb
--- /dev/null
+++ b/theories7/Sets/Relations_2_facts.v
@@ -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        *)
+(************************************************************************)
+(****************************************************************************)
+(*                                                                          *)
+(*                         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
new file mode 100755
index 00000000..092fc534
--- /dev/null
+++ b/theories7/Sets/Relations_3.v
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100755
index 00000000..822f550a
--- /dev/null
+++ b/theories7/Sets/Relations_3_facts.v
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..33880214
--- /dev/null
+++ b/theories7/Sets/Uniset.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..63e7f324
--- /dev/null
+++ b/theories7/Sorting/Heap.v
@@ -0,0 +1,223 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..46b8da00
--- /dev/null
+++ b/theories7/Sorting/Permutation.v
@@ -0,0 +1,111 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..a6e38976
--- /dev/null
+++ b/theories7/Sorting/Sorting.v
@@ -0,0 +1,117 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..04930170
--- /dev/null
+++ b/theories7/Wellfounded/Disjoint_Union.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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..6a515333
--- /dev/null
+++ b/theories7/Wellfounded/Inclusion.v
@@ -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: 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
new file mode 100644
index 00000000..6c9c3e65
--- /dev/null
+++ b/theories7/Wellfounded/Inverse_Image.v
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..17f6d650
--- /dev/null
+++ b/theories7/Wellfounded/Lexicographic_Exponentiation.v
@@ -0,0 +1,386 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..f31d8c3f
--- /dev/null
+++ b/theories7/Wellfounded/Lexicographic_Product.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..4d6cbe28
--- /dev/null
+++ b/theories7/Wellfounded/Transitive_Closure.v
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..9b31f72d
--- /dev/null
+++ b/theories7/Wellfounded/Union.v
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..5c2b2405
--- /dev/null
+++ b/theories7/Wellfounded/Well_Ordering.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..d1a8dd01
--- /dev/null
+++ b/theories7/Wellfounded/Wellfounded.v
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..9071896b
--- /dev/null
+++ b/theories7/ZArith/BinInt.v
@@ -0,0 +1,1005 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e6cf4610
--- /dev/null
+++ b/theories7/ZArith/Wf_Z.v
@@ -0,0 +1,194 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..e1746433
--- /dev/null
+++ b/theories7/ZArith/ZArith.v
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: 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
new file mode 100644
index 00000000..7f2863d6
--- /dev/null
+++ b/theories7/ZArith/ZArith_base.v
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..985f7601
--- /dev/null
+++ b/theories7/ZArith/ZArith_dec.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: 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
new file mode 100644
index 00000000..57778cae
--- /dev/null
+++ b/theories7/ZArith/Zabs.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c3efbe1e
--- /dev/null
+++ b/theories7/ZArith/Zbinary.v
@@ -0,0 +1,425 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..258a485d
--- /dev/null
+++ b/theories7/ZArith/Zbool.v
@@ -0,0 +1,158 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..fd11ae9b
--- /dev/null
+++ b/theories7/ZArith/Zcompare.v
@@ -0,0 +1,480 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..72d837b6
--- /dev/null
+++ b/theories7/ZArith/Zcomplements.v
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..84d53931
--- /dev/null
+++ b/theories7/ZArith/Zdiv.v
@@ -0,0 +1,432 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..04b3ec09
--- /dev/null
+++ b/theories7/ZArith/Zeven.v
@@ -0,0 +1,184 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..01860d18
--- /dev/null
+++ b/theories7/ZArith/Zhints.v
@@ -0,0 +1,387 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..dc850738
--- /dev/null
+++ b/theories7/ZArith/Zlogarithm.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..753fe461
--- /dev/null
+++ b/theories7/ZArith/Zmin.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: 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
new file mode 100644
index 00000000..bd89ec66
--- /dev/null
+++ b/theories7/ZArith/Zmisc.v
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..99d1422f
--- /dev/null
+++ b/theories7/ZArith/Znat.v
@@ -0,0 +1,138 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..b8e5f300
--- /dev/null
+++ b/theories7/ZArith/Znumtheory.v
@@ -0,0 +1,629 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..d49a0800
--- /dev/null
+++ b/theories7/ZArith/Zorder.v
@@ -0,0 +1,969 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..97c2b3c9
--- /dev/null
+++ b/theories7/ZArith/Zpower.v
@@ -0,0 +1,394 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..72a2e9cf
--- /dev/null
+++ b/theories7/ZArith/Zsqrt.v
@@ -0,0 +1,136 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..3c7f3a57
--- /dev/null
+++ b/theories7/ZArith/Zsyntax.v
@@ -0,0 +1,278 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..c2e6ca2a
--- /dev/null
+++ b/theories7/ZArith/Zwf.v
@@ -0,0 +1,96 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..8db2c852
--- /dev/null
+++ b/theories7/ZArith/auxiliary.v
@@ -0,0 +1,219 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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
new file mode 100644
index 00000000..7e3fe306
--- /dev/null
+++ b/theories7/ZArith/fast_integer.v
@@ -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        *)
+(************************************************************************)
+
+(*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
new file mode 100644
index 00000000..cd67d46b
--- /dev/null
+++ b/theories7/ZArith/zarith_aux.v
@@ -0,0 +1,163 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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/README.coq-tex b/tools/README.coq-tex
new file mode 100755
index 00000000..5c7606a9
--- /dev/null
+++ b/tools/README.coq-tex
@@ -0,0 +1,13 @@
+DESCRIPTION.
+
+The coq-tex filter extracts Coq phrases embedded in LaTeX files,
+evaluates them, and insert the outcome of the evaluation after each
+phrase.
+
+The filter is written in Perl, so you'll need Perl version 4 installed
+on your machine.
+
+USAGE. See the manual page (coq-tex.1).
+
+AUTHOR. Jean-Christophe Filliatre (jcfillia@lip.ens-lyon.fr)
+  from caml-tex of Xavier Leroy.
diff --git a/tools/README.emacs b/tools/README.emacs
new file mode 100755
index 00000000..0d27b607
--- /dev/null
+++ b/tools/README.emacs
@@ -0,0 +1,31 @@
+
+DESCRIPTION:
+
+An emacs mode to help editing Coq vernacular files.
+
+AUTHOR:
+
+Jean-Christophe Filliatre (jcfillia@lri.fr),
+	from the Caml mode of Xavier Leroy.
+
+CONTENTS:
+
+    coq.el         A major mode for editing Coq files in Gnu Emacs
+
+USAGE:
+
+Add the following lines to your .emacs file:
+
+(setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
+(autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+
+The Coq major mode is triggered by visiting a file with extension .v,
+or manually by M-x coq-mode. It gives you the correct syntax table for
+the Coq language, and also a rudimentary indentation facility:
+
+- pressing TAB at the beginning of a line indents the line like the line above
+
+- extra TABs increase the indentation level (by 2 spaces by default)
+
+- M-TAB decreases the indentation level.
+
diff --git a/tools/check-v8 b/tools/check-v8
new file mode 100755
index 00000000..9dfa0be3
--- /dev/null
+++ b/tools/check-v8
@@ -0,0 +1,24 @@
+#!/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-inferior.el b/tools/coq-inferior.el
new file mode 100644
index 00000000..d4f96a16
--- /dev/null
+++ b/tools/coq-inferior.el
@@ -0,0 +1,324 @@
+;;; inferior-coq.el --- Run an inferior Coq process.
+;;;
+;;; Copyright (C) Marco Maggesi <maggesi@math.unifi.it>
+;;; Time-stamp: "2002-02-28 12:15:04 maggesi"
+
+
+;; Emacs Lisp Archive Entry
+;; Filename: inferior-coq.el
+;; Version: 1.0
+;; Keywords: process coq
+;; Author: Marco Maggesi <maggesi@math.unifi.it>
+;; Maintainer: Marco Maggesi <maggesi@math.unifi.it>
+;; Description: Run an inferior Coq process.
+;; URL: http://www.math.unifi.it/~maggesi/
+;; Compatibility: Emacs20, Emacs21, XEmacs21
+
+;; This 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, or (at your option) any later
+;; version.
+;;
+;; This 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;; MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Coq is a proof assistant (http://coq.inria.fr/).  This code run an
+;; inferior Coq process and defines functions to send bits of code
+;; from other buffers to the inferior process.  This is a
+;; customisation of comint-mode (see comint.el).  For a more complex
+;; and full featured Coq interface under Emacs look at Proof General
+;; (http://zermelo.dcs.ed.ac.uk/~proofgen/).
+;;
+;; Written by Marco Maggesi <maggesi@math.unifi.it> with code heavly
+;; borrowed from emacs cmuscheme.el
+;;
+;; Please send me bug reports, bug fixes, and extensions, so that I can
+;; merge them into the master source.
+
+;;; Installation:
+
+;; You need to have coq.el already installed (it comes with the
+;; standard Coq distribution) in order to use this code.  Put this
+;; file somewhere in you load-path and add the following lines in your
+;; "~/.emacs":
+;;
+;;   (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
+;;   (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+;;   (autoload 'run-coq "inferior-coq" "Run an inferior Coq process." t)
+;;   (autoload 'run-coq-other-window "inferior-coq"
+;;     "Run an inferior Coq process in a new window." t)
+;;   (autoload 'run-coq-other-frame "inferior-coq"
+;;     "Run an inferior Coq process in a new frame." t)
+
+;;; Usage:
+
+;; Call `M-x "run-coq'.
+;;
+;; Functions and key bindings (Learn more keys with `C-c C-h' or `C-h m'):
+;;   C-return ('M-x coq-send-line)     send the current line.
+;;   C-c C-r  (`M-x coq-send-region')  send the current region.
+;;   C-c C-a  (`M-x coq-send-abort')   send the command "Abort".
+;;   C-c C-t  (`M-x coq-send-restart') send the command "Restart".
+;;   C-c C-s  (`M-x coq-send-show')    send the command "Show".
+;;   C-c C-u  (`M-x coq-send-undo')    send the command "Undo".
+;;   C-c C-v  (`M-x coq-check-region') run command "Check" on region.
+;;   C-c .    (`M-x coq-come-here')    Restart and send until current point.
+
+;;; Change Log:
+
+;; From -0.0 to 1.0 brought into existence.
+
+
+(require 'coq)
+(require 'comint)
+
+(setq coq-program-name "coqtop")
+
+(defgroup inferior-coq nil
+  "Run a coq process in a buffer."
+  :group 'coq)
+
+(defcustom inferior-coq-mode-hook nil
+  "*Hook for customising inferior-coq mode."
+  :type 'hook
+  :group 'coq)
+
+(defvar inferior-coq-mode-map
+  (let ((m (make-sparse-keymap)))
+    (define-key m "\C-c\C-r" 'coq-send-region)
+    (define-key m "\C-c\C-a" 'coq-send-abort)
+    (define-key m "\C-c\C-t" 'coq-send-restart)
+    (define-key m "\C-c\C-s" 'coq-send-show)
+    (define-key m "\C-c\C-u" 'coq-send-undo)
+    (define-key m "\C-c\C-v" 'coq-check-region)
+    m))
+
+;; Install the process communication commands in the coq-mode keymap.
+(define-key coq-mode-map [(control return)] 'coq-send-line)
+(define-key coq-mode-map "\C-c\C-r" 'coq-send-region)
+(define-key coq-mode-map "\C-c\C-a" 'coq-send-abort)
+(define-key coq-mode-map "\C-c\C-t" 'coq-send-restart)
+(define-key coq-mode-map "\C-c\C-s" 'coq-send-show)
+(define-key coq-mode-map "\C-c\C-u" 'coq-send-undo)
+(define-key coq-mode-map "\C-c\C-v" 'coq-check-region)
+(define-key coq-mode-map "\C-c." 'coq-come-here)
+
+(defvar coq-buffer)
+
+(define-derived-mode inferior-coq-mode comint-mode "Inferior Coq"
+  "\
+Major mode for interacting with an inferior Coq process.
+
+The following commands are available:
+\\{inferior-coq-mode-map}
+
+A Coq process can be fired up with M-x run-coq.
+
+Customisation: Entry to this mode runs the hooks on comint-mode-hook
+and inferior-coq-mode-hook (in that order).
+
+You can send text to the inferior Coq process from other buffers
+containing Coq source.
+
+Functions and key bindings (Learn more keys with `C-c C-h'):
+  C-return ('M-x coq-send-line)     send the current line.
+  C-c C-r  (`M-x coq-send-region')  send the current region.
+  C-c C-a  (`M-x coq-send-abort')   send the command \"Abort\".
+  C-c C-t  (`M-x coq-send-restart') send the command \"Restart\".
+  C-c C-s  (`M-x coq-send-show')    send the command \"Show\".
+  C-c C-u  (`M-x coq-send-undo')    send the command \"Undo\".
+  C-c C-v  (`M-x coq-check-region') run command \"Check\" on region.
+  C-c .    (`M-x coq-come-here')    Restart and send until current point.
+"
+  ;; Customise in inferior-coq-mode-hook
+  (setq comint-prompt-regexp "^[^<]* < *")
+  (coq-mode-variables)
+  (setq mode-line-process '(":%s"))
+  (setq comint-input-filter (function coq-input-filter))
+  (setq comint-get-old-input (function coq-get-old-input)))
+
+(defcustom inferior-coq-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
+  "*Input matching this regexp are not saved on the history list.
+Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters."
+  :type 'regexp
+  :group 'inferior-coq)
+
+(defun coq-input-filter (str)
+  "Don't save anything matching `inferior-coq-filter-regexp'."
+  (not (string-match inferior-coq-filter-regexp str)))
+
+(defun coq-get-old-input ()
+  "Snarf the sexp ending at point."
+  (save-excursion
+    (let ((end (point)))
+      (backward-sexp)
+      (buffer-substring (point) end))))
+
+(defun coq-args-to-list (string)
+  (let ((where (string-match "[ \t]" string)))
+    (cond ((null where) (list string))
+	  ((not (= where 0))
+	   (cons (substring string 0 where)
+		 (coq-args-to-list (substring string (+ 1 where)
+						 (length string)))))
+	  (t (let ((pos (string-match "[^ \t]" string)))
+	       (if (null pos)
+		   nil
+		 (coq-args-to-list (substring string pos
+						 (length string)))))))))
+
+;;;###autoload
+(defun run-coq (cmd)
+  "Run an inferior Coq process, input and output via buffer *coq*.
+If there is a process already running in `*coq*', switch to that buffer.
+With argument, allows you to edit the command line (default is value
+of `coq-program-name').  Runs the hooks `inferior-coq-mode-hook'
+\(after the `comint-mode-hook' is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+
+  (interactive (list (if current-prefix-arg
+			 (read-string "Run Coq: " coq-program-name)
+			 coq-program-name)))
+  (if (not (comint-check-proc "*coq*"))
+      (let ((cmdlist (coq-args-to-list cmd)))
+	(set-buffer (apply 'make-comint "coq" (car cmdlist)
+			   nil (cdr cmdlist)))
+	(inferior-coq-mode)))
+  (setq coq-program-name cmd)
+  (setq coq-buffer "*coq*")
+  (switch-to-buffer "*coq*"))
+;;;###autoload (add-hook 'same-window-buffer-names "*coq*")
+
+;;;###autoload
+(defun run-coq-other-window (cmd)
+  "Run an inferior Coq process, input and output via buffer *coq*.
+If there is a process already running in `*coq*', switch to that buffer.
+With argument, allows you to edit the command line (default is value
+of `coq-program-name').  Runs the hooks `inferior-coq-mode-hook'
+\(after the `comint-mode-hook' is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+
+  (interactive (list (if current-prefix-arg
+			 (read-string "Run Coq: " coq-program-name)
+			 coq-program-name)))
+  (if (not (comint-check-proc "*coq*"))
+      (let ((cmdlist (coq-args-to-list cmd)))
+	(set-buffer (apply 'make-comint "coq" (car cmdlist)
+			   nil (cdr cmdlist)))
+	(inferior-coq-mode)))
+  (setq coq-program-name cmd)
+  (setq coq-buffer "*coq*")
+  (pop-to-buffer "*coq*"))
+;;;###autoload (add-hook 'same-window-buffer-names "*coq*")
+
+(defun run-coq-other-frame (cmd)
+  "Run an inferior Coq process, input and output via buffer *coq*.
+If there is a process already running in `*coq*', switch to that buffer.
+With argument, allows you to edit the command line (default is value
+of `coq-program-name').  Runs the hooks `inferior-coq-mode-hook'
+\(after the `comint-mode-hook' is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+
+  (interactive (list (if current-prefix-arg
+			 (read-string "Run Coq: " coq-program-name)
+			 coq-program-name)))
+  (if (not (comint-check-proc "*coq*"))
+      (let ((cmdlist (coq-args-to-list cmd)))
+	(set-buffer (apply 'make-comint "coq" (car cmdlist)
+			   nil (cdr cmdlist)))
+	(inferior-coq-mode)))
+  (setq coq-program-name cmd)
+  (setq coq-buffer "*coq*")
+  (switch-to-buffer-other-frame "*coq*"))
+
+(defun switch-to-coq (eob-p)
+  "Switch to the coq process buffer.
+With argument, position cursor at end of buffer."
+  (interactive "P")
+  (if (get-buffer coq-buffer)
+      (pop-to-buffer coq-buffer)
+      (error "No current process buffer.  See variable `coq-buffer'"))
+  (cond (eob-p
+	 (push-mark)
+	 (goto-char (point-max)))))
+
+(defun coq-send-region (start end)
+  "Send the current region to the inferior Coq process."
+  (interactive "r")
+  (comint-send-region (coq-proc) start end)
+  (comint-send-string (coq-proc) "\n"))
+
+(defun coq-send-line ()
+  "Send the current line to the Coq process."
+  (interactive)
+  (save-excursion
+    (end-of-line)
+    (let ((end (point)))
+      (beginning-of-line)
+      (coq-send-region (point) end)))
+  (next-line 1))
+
+(defun coq-send-abort ()
+  "Send the command \"Abort.\" to the inferior Coq process."
+  (interactive)
+  (comint-send-string (coq-proc) "Abort.\n"))
+
+(defun coq-send-restart ()
+  "Send the command \"Restart.\" to the inferior Coq process."
+  (interactive)
+  (comint-send-string (coq-proc) "Restart.\n"))
+
+(defun coq-send-undo ()
+  "Reset coq to the initial state and send the region between the
+   beginning of file and the point."
+  (interactive)
+  (comint-send-string (coq-proc) "Undo.\n"))
+
+(defun coq-check-region (start end)
+  "Run the commmand \"Check\" on the current region."
+  (interactive "r")
+  (comint-proc-query (coq-proc)
+		     (concat "Check "
+			     (buffer-substring start end)
+			     ".\n")))
+
+(defun coq-send-show ()
+  "Send the command \"Show.\" to the inferior Coq process."
+  (interactive)
+  (comint-send-string (coq-proc) "Show.\n"))
+
+(defun coq-come-here ()
+  "Reset coq to the initial state and send the region between the
+   beginning of file and the point."
+  (interactive)
+  (comint-send-string (coq-proc) "Reset Initial.\n")
+  (coq-send-region 1 (point)))
+
+(defvar coq-buffer nil "*The current coq process buffer.")
+
+(defun coq-proc ()
+  "Return the current coq process.  See variable `coq-buffer'."
+  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-coq-mode)
+				      (current-buffer)
+				      coq-buffer))))
+    (or proc
+	(error "No current process.  See variable `coq-buffer'"))))
+
+(defcustom inferior-coq-load-hook nil
+  "This hook is run when inferior-coq is loaded in.
+This is a good place to put keybindings."
+  :type 'hook
+  :group 'inferior-coq)
+	
+(run-hooks 'inferior-coq-load-hook)
+
+(provide 'inferior-coq)
diff --git a/tools/coq-sl.sty b/tools/coq-sl.sty
new file mode 100755
index 00000000..9f6e5480
--- /dev/null
+++ b/tools/coq-sl.sty
@@ -0,0 +1,37 @@
+% COQ style option, for use with the coq-latex filter.
+
+\typeout{Document Style option `coq-sl' <7 Apr 92>.}
+
+\ifcase\@ptsize
+    \font\sltt = cmsltt10
+\or \font\sltt = cmsltt10 \@halfmag
+\or \font\sltt = cmsltt10 \@magscale1
+\fi
+
+{\catcode`\^^M=\active %
+ \gdef\@coqinputline#1^^M{\tt Coq < #1\par} %
+ \gdef\@coqoutputline#1^^M{\sltt#1\par} } %
+\def\@coqblankline{\medskip}
+\chardef\@coqbackslash="5C
+
+\def\coq{
+  \bgroup
+  \flushleft
+  \parindent 0pt
+  \parskip 0pt
+  \let\do\@makeother\dospecials
+  \catcode`\^^M=\active
+  \catcode`\\=0
+  \catcode`\ \active
+  \frenchspacing
+  \@vobeyspaces
+  \let\?\@coqinputline
+  \let\:\@coqoutputline
+  \let\;\@coqblankline
+  \let\\\@coqbackslash
+}
+
+\def\endcoq{
+  \endflushleft
+  \egroup\noindent
+}
diff --git a/tools/coq-tex.ml4 b/tools/coq-tex.ml4
new file mode 100644
index 00000000..6987d78b
--- /dev/null
+++ b/tools/coq-tex.ml4
@@ -0,0 +1,292 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq-tex.ml4,v 1.5.2.1 2004/07/16 19:31:45 herbelin Exp $ *)
+
+(* coq-tex
+ * JCF, 16/1/98
+ * adapted from caml-tex (perl script written by Xavier Leroy)
+ *
+ * Perl isn't as portable as it pretends to be, and is quite difficult 
+ * to read and maintain... Let us rewrite the stuff in Caml! *)
+
+let _ =
+  match Sys.os_type with
+    | "Unix" -> ()
+    | _ -> begin
+      	print_string "This program only runs under Unix !\n";
+      	flush stdout;
+      	exit 1
+      end
+
+let linelen = ref 72
+let output = ref ""
+let output_specified = ref false
+let image = ref ""
+let cut_at_blanks = ref false
+let verbose = ref false
+let slanted = ref false
+let hrule = ref false
+let small = ref false
+
+let coq_prompt = Str.regexp "Coq < "
+let any_prompt = Str.regexp "^[A-Z0-9a-z_\\$']* < "
+
+let remove_prompt s = Str.replace_first any_prompt "" s
+
+(* First pass: extract the Coq phrases to evaluate from [texfile]
+ * and put them into the file [inputv] *)
+
+let begin_coq = Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$"
+let end_coq   = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\|eval\\)}[ \t]*$"
+
+let extract texfile inputv =
+  let chan_in = open_in texfile in
+  let chan_out = open_out inputv in
+  let rec inside () =
+    let s = input_line chan_in in
+    if Str.string_match end_coq s 0 then
+      outside ()
+    else begin
+      output_string chan_out (s ^ "\n");
+      inside ()
+    end
+  and outside () =
+    let s = input_line chan_in in
+    if Str.string_match begin_coq s 0 then
+      inside ()
+    else
+      outside ()
+  in
+  try
+    output_string chan_out 
+      ("Set Printing Width " ^ (string_of_int !linelen) ^".\n");
+    outside ()
+  with End_of_file -> 
+    begin close_in chan_in; close_out chan_out end
+
+(* Second pass: insert the answers of Coq from [coq_output] into the
+ * TeX file [texfile]. The result goes in file [result]. *)
+
+let begin_coq_example =
+  Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$"
+let begin_coq_eval = Str.regexp "\\\\begin{coq_eval}[ \t]*$"
+let end_coq_example = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$"
+let end_coq_eval = Str.regexp "\\\\end{coq_eval}[ \t]*$"
+let dot_end_line = Str.regexp "\\.[ \t]*\\((\\*.*\\*)\\)?[ \t]*$"
+
+let has_match r s =
+  try let _ = Str.search_forward r s 0 in true with Not_found -> false
+
+let percent = Str.regexp "%"
+let bang    = Str.regexp "!"
+let expos   = Str.regexp "^"
+
+let tex_escaped s =
+  let rec trans = parser
+    | [< s1 = (parser 
+		 | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> 
+		     "\\" ^ (String.make 1 c)
+		 | [< ''\\' >] -> "\\char'134" 
+		 | [< ''^'  >] -> "\\char'136" 
+		 | [< ''~'  >] -> "\\char'176"
+		 | [< '' '  >] -> "~"
+		 | [< ''<'  >] -> "{<}"
+		 | [< ''>'  >] -> "{>}"
+		 | [< 'c >]    -> String.make 1 c);
+	 s2 = trans >] -> s1 ^ s2
+    | [< >] -> ""
+  in 
+  trans (Stream.of_string s)
+
+let encapsule sl c_out s =
+  if sl then
+    Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s)
+  else
+    Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s)
+      
+let print_block c_out bl =
+  List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl
+
+let insert texfile coq_output result =
+  let c_tex = open_in texfile in
+  let c_coq = open_in coq_output in
+  let c_out = open_out result in
+  (* next_block k : this function reads the next block of Coq output
+   * removing the k leading prompts.
+   * it returns the block as a list of string) *)
+  let last_read = ref "" in
+  let next_block k =
+    if !last_read = "" then last_read := input_line c_coq;
+    (* skip k prompts *)
+    for i = 1 to k do
+      last_read := remove_prompt !last_read;
+    done;
+    (* read and return the following lines until a prompt is found *)
+    let rec read_lines () =
+      let s = input_line c_coq in
+      if Str.string_match any_prompt s 0 then begin
+	last_read := s; []
+      end else
+	s :: (read_lines ())
+    in
+    let first = !last_read in first :: (read_lines ())
+  in
+  (* we are just after \end{coq_...} block *)
+  let rec just_after () = 
+    let s = input_line c_tex in
+    if Str.string_match begin_coq_example s 0 then begin
+      inside (Str.matched_group 1 s <> "example*")
+             (Str.matched_group 1 s <> "example#") 0 false
+    end
+    else begin
+      if !hrule then output_string c_out "\\hrulefill\\\\\n";
+      output_string c_out "\\end{flushleft}\n";
+      if !small then output_string c_out "\\end{small}\n";
+      if Str.string_match begin_coq_eval s 0 then
+	eval 0     
+      else begin
+	output_string c_out (s ^ "\n");
+	outside ()
+      end	  
+    end
+  (* we are outside of a \begin{coq_...} ... \end{coq_...} block *)
+  and outside () =
+    let s = input_line c_tex in
+    if Str.string_match begin_coq_example s 0 then begin
+      if !small then output_string c_out "\\begin{small}\n";
+      output_string c_out "\\begin{flushleft}\n";
+      if !hrule then output_string c_out "\\hrulefill\\\\\n";
+      inside (Str.matched_group 1 s <> "example*")
+             (Str.matched_group 1 s <> "example#") 0 true
+    end else if Str.string_match begin_coq_eval s 0 then
+      eval 0
+    else begin
+      output_string c_out (s ^ "\n");
+      outside ()
+    end
+  (* we are inside a \begin{coq_example?} ... \end{coq_example?} block
+   * show_answers tells what kind of block it is
+   * k is the number of lines read until now *)
+  and inside show_answers  show_questions k first_block = 
+    let s = input_line c_tex in
+    if Str.string_match end_coq_example s 0 then begin
+      just_after ()
+    end else begin
+      if !verbose then Printf.printf "Coq < %s\n" s;
+      if (not first_block) & k=0 then output_string c_out "\\medskip\n";
+      if show_questions then encapsule false c_out ("Coq < " ^ s);
+      if has_match dot_end_line s then begin
+	let bl = next_block (succ k) in
+	if !verbose then List.iter print_endline bl; 
+	if show_answers then print_block c_out bl;
+	inside show_answers  show_questions 0 false
+      end else
+	inside show_answers  show_questions (succ k) first_block
+    end
+  (* we are inside a \begin{coq_eval} ... \end{coq_eval} block
+   * k is the number of lines read until now *)
+  and eval k =
+    let s = input_line c_tex in
+    if Str.string_match end_coq_eval s 0 then
+      outside ()
+    else begin
+      if !verbose then Printf.printf "Coq < %s\n" s;
+      if has_match dot_end_line s then
+       	let bl = next_block (succ k) in
+	if !verbose then List.iter print_endline bl;
+	eval 0
+      else
+       	eval (succ k)
+    end
+  in
+  try
+    let _ = next_block 0 in (* to skip the Coq banner *)
+    let _ = next_block 0 in (* to skip the Coq answer to Set Printing Width *)
+    outside ()
+  with End_of_file -> begin
+    close_in c_tex;
+    close_in c_coq;
+    close_out c_out
+  end
+
+(* Process of one TeX file *)
+
+let rm f = try Sys.remove f with _ -> ()
+
+let one_file texfile =
+  let inputv = Filename.temp_file "coq_tex" ".v" in
+  let coq_output = Filename.temp_file "coq_tex" ".coq_output"in
+  let result =
+    if !output_specified then
+      !output
+    else if Filename.check_suffix texfile ".tex" then
+      (Filename.chop_suffix texfile ".tex") ^ ".v.tex"
+    else
+      texfile ^ ".v.tex" 
+  in
+  try
+    (* 1. extract Coq phrases *)
+    extract texfile inputv;
+    (* 2. run Coq on input *)
+    let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv
+			   coq_output) 
+    in
+    (* 3. insert Coq output into original file *)
+    insert texfile coq_output result;
+    (* 4. clean up *)
+    rm inputv; rm coq_output
+  with e -> begin
+    rm inputv; rm coq_output;
+    raise e
+  end
+
+(* Parsing of the command line, check of the Coq command and process
+ * of all the files in the command line, one by one *)
+
+let files = ref []
+      
+let parse_cl () =
+  Arg.parse
+      [ "-o", Arg.String (fun s -> output_specified := true; output := s),
+	"output-file    Specifiy the resulting LaTeX file";
+	"-n", Arg.Int (fun n -> linelen := n),
+	"line-width     Set the line width";
+	"-image", Arg.String (fun s -> image := s),
+	"coq-image  Use coq-image as Coq command";
+	"-w", Arg.Set cut_at_blanks,
+	"               Try to cut lines at blanks";
+	"-v", Arg.Set verbose,
+	"               Verbose mode (show Coq answers on stdout)";
+	"-sl", Arg.Set slanted,
+	"              Coq answers in slanted font (only with LaTeX2e)";
+	"-hrule", Arg.Set hrule,
+	"           Coq parts are written between 2 horizontal lines";
+	"-small", Arg.Set small,
+	"           Coq parts are written in small font"
+      ]
+      (fun s -> files := s :: !files)
+      "coq-tex [options] file ..."
+
+let main () =
+  parse_cl ();
+  if !image = "" then begin
+    Printf.printf "Warning: preprocessing with default image \"coqtop\"\n";
+    image := "coqtop"
+  end;
+  if Sys.command (!image ^ " -batch > /dev/null 2>&1") <> 0 then begin
+    Printf.printf "Error: ";
+    let _ = Sys.command (!image ^ " -batch") in
+    exit 1
+  end else begin
+    Printf.printf "Your version of coqtop seems OK\n";
+    flush stdout
+  end;
+  List.iter one_file (List.rev !files)
+
+let _ = Printexc.catch main ()
diff --git a/tools/coq.el b/tools/coq.el
new file mode 100644
index 00000000..0eb04d8d
--- /dev/null
+++ b/tools/coq.el
@@ -0,0 +1,182 @@
+;; coq.el --- Coq mode editing commands for Emacs
+;;
+;; Jean-Christophe Filliatre, march 1995
+;; Honteusement pompé de caml.el, Xavier Leroy, july 1993.
+;;
+;; modified by Marco Maggesi <maggesi@math.unifi.it> for coq-inferior
+
+(defvar coq-mode-map nil
+  "Keymap used in Coq mode.")
+(if coq-mode-map
+    ()
+  (setq coq-mode-map (make-sparse-keymap))
+  (define-key coq-mode-map "\t"      'coq-indent-command)
+  (define-key coq-mode-map "\M-\t"   'coq-unindent-command)
+  (define-key coq-mode-map "\C-c\C-c"   'compile)
+)
+
+(defvar coq-mode-syntax-table nil
+  "Syntax table in use in Coq mode buffers.")
+(if coq-mode-syntax-table
+    ()
+  (setq coq-mode-syntax-table (make-syntax-table))
+  ; ( is first character of comment start
+  (modify-syntax-entry ?\( "()1" coq-mode-syntax-table)
+  ; * is second character of comment start,
+  ; and first character of comment end
+  (modify-syntax-entry ?*  ". 23" coq-mode-syntax-table)
+  ; ) is last character of comment end
+  (modify-syntax-entry ?\) ")(4" coq-mode-syntax-table)
+  ; quote is a string-like delimiter (for character literals)
+  (modify-syntax-entry ?' "\"" coq-mode-syntax-table)
+  ; quote is part of words
+  (modify-syntax-entry ?' "w" coq-mode-syntax-table)
+)
+
+(defvar coq-mode-indentation 2
+  "*Indentation for each extra tab in Coq mode.")
+
+(defun coq-mode-variables ()
+  (set-syntax-table coq-mode-syntax-table)
+  (make-local-variable 'paragraph-start)
+  (setq paragraph-start (concat "^$\\|" page-delimiter))
+  (make-local-variable 'paragraph-separate)
+  (setq paragraph-separate paragraph-start)
+  (make-local-variable 'paragraph-ignore-fill-prefix)
+  (setq paragraph-ignore-fill-prefix t)
+  (make-local-variable 'require-final-newline)
+  (setq require-final-newline t)
+  (make-local-variable 'comment-start)
+  (setq comment-start "(* ")
+  (make-local-variable 'comment-end)
+  (setq comment-end " *)")
+  (make-local-variable 'comment-column)
+  (setq comment-column 40)
+  (make-local-variable 'comment-start-skip)
+  (setq comment-start-skip "(\\*+ *")
+  (make-local-variable 'parse-sexp-ignore-comments)
+  (setq parse-sexp-ignore-comments nil)
+  (make-local-variable 'indent-line-function)
+  (setq indent-line-function 'coq-indent-command))
+
+;;; The major mode
+
+(defun coq-mode ()
+  "Major mode for editing Coq code.
+Tab at the beginning of a line indents this line like the line above.
+Extra tabs increase the indentation level.
+\\{coq-mode-map}
+The variable coq-mode-indentation indicates how many spaces are
+inserted for each indentation level."
+  (interactive)
+  (kill-all-local-variables)
+  (setq major-mode 'coq-mode)
+  (setq mode-name "coq")
+  (use-local-map coq-mode-map)
+  (coq-mode-variables)
+  (run-hooks 'coq-mode-hook))
+
+;;; Indentation stuff
+
+(defun coq-in-indentation ()
+  "Tests whether all characters between beginning of line and point
+are blanks."
+  (save-excursion
+    (skip-chars-backward " \t")
+    (bolp)))
+
+(defun coq-indent-command ()
+  "Indent the current line in Coq mode.
+When the point is at the beginning of an empty line, indent this line like
+the line above.
+When the point is at the beginning of an indented line
+\(i.e. all characters between beginning of line and point are blanks\),
+increase the indentation by one level.
+The indentation size is given by the variable coq-mode-indentation.
+In all other cases, insert a tabulation (using insert-tab)."
+  (interactive)
+  (let* ((begline
+          (save-excursion
+            (beginning-of-line)
+            (point)))
+         (current-offset
+          (- (point) begline))
+         (previous-indentation
+          (save-excursion
+            (if (eq (forward-line -1) 0) (current-indentation) 0))))
+    (cond ((and (bolp)
+                (looking-at "[ \t]*$")
+                (> previous-indentation 0))
+           (indent-to previous-indentation))
+          ((coq-in-indentation)
+           (indent-to (+ current-offset coq-mode-indentation)))
+          (t
+           (insert-tab)))))
+
+(defun coq-unindent-command ()
+  "Decrease indentation by one level in Coq mode.
+Works only if the point is at the beginning of an indented line
+\(i.e. all characters between beginning of line and point are blanks\).
+Does nothing otherwise."
+  (interactive)
+  (let* ((begline
+          (save-excursion
+            (beginning-of-line)
+            (point)))
+         (current-offset
+          (- (point) begline)))
+    (if (and (>= current-offset coq-mode-indentation)
+             (coq-in-indentation))
+        (backward-delete-char-untabify coq-mode-indentation))))
+
+;;; Hilight
+
+(cond 
+ (window-system
+  (setq hilit-mode-enable-list  '(not text-mode)
+        hilit-inhibit-hooks     nil
+        hilit-inhibit-rebinding nil)
+  
+  (require 'hilit19)
+       (setq  hilit-quietly t)
+       (hilit-set-mode-patterns
+        'coq-mode
+        '(;;comments
+          ("(\\*" "\\*)" comment)
+          ;;strings
+          (hilit-string-find ?' string)
+	  ;;directives
+          ("^[ \t]*\\(AddPath\\|DelPath\\|Add[ \t]+ML[ \t]+Path\\|Declare[ \t]+ML[ \t]+Module\\|Require\\|Export\\|Module\\|Opaque\\|Transparent\\|Section\\|Chapter\\|End\\|Load\\|Print\\|Show\\)[ \t]+[^.]*" nil include)
+	  ("Implicit[ \t]+Arguments[ \t]+\\(On\\|Off\\)[^.]*" nil include)
+          ;;grammar definitions
+	  ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)" nil define)
+	  ("^[ \t]*Syntax[ \t]+\\(tactic\\|command\\)[ \t]*level[ \t]+[0-9]+[ \t]*" nil define)
+	  ("^[ \t]*level[ \t]+[0-9]+[ \t]*:" nil define)
+	  ("^[ \t]*Grammar.*" ":=" define)
+          ("^[ \t]*Tactic[ \t]+Definition" ":=" define) 
+	  ("^[ \t]*Token[^.]*" nil define)
+	  ("^[ \t]*\\(Coercion\\|Class\\|Infix\\)[ \t]+[[A-Za-z0-9$_\\']+" nil define)
+          ;;declarations
+	  ("^[ \t]*Recursive[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+          ("^[ \t]*Syntactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+          ("^[ \t]*Tactic[ \t]+Definition[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+	  ("^[ \t]*Inductive[ \t]+\\(Set\\|Prop\\|Type\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+	  ("^[ \t]*Mutual[ \t]+\\(Inductive\\|CoInductive\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+	  ("^[ \t]*\\(Inductive\\|CoInductive\\|CoFixpoint\\|Definition\\|Local\\|Fixpoint\\|with\\|Record\\|Correctness\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+	  ("^[ \t]*\\(Derive\\|Dependant[ \t]+Derive\\)[ \t]+\\(Inversion\\|Inversion_clear\\)[ \t]+[A-Za-z0-9$_\\']+" nil defun)
+	  ("^[ \t]*\\(Variable\\|Parameter\\|Hypothesis\\).*" ":" defun)
+	  ("^[ \t]*\\(Global[ \t]+Variable\\).*" ":" defun)
+	  ("^[ \t]*\\(Realizer[ \t]+Program\\|Realizer\\)" nil defun)
+	  ;;proofs
+	  ("^[ \t]*\\(Lemma\\|Theorem\\|Remark\\|Axiom\\).*" ":" defun)
+	  ("^[ \t]*Proof" nil decl)
+	  ("^[ \t]*\\(Save\\|Qed\\|Defined\\|Hint\\|Immediate\\)[^.]*" nil decl)
+          ;;keywords
+          ("[^_]\\<\\(Case\\|Cases\\|case\\|esac\\|of\\|end\\|in\\|Match\\|with\\|Fix\\|let\\|if\\|then\\|else\\)\\>[^_]" 1 keyword)
+          ("[^_]\\<\\(begin\\|assert\\|invariant\\|variant\\|for\\|while\\|do\\|done\\|state\\)\\>[^_]" 1 keyword)
+          ))
+))
+
+;;; coq.el ends here
+
+(provide 'coq)
diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4
new file mode 100644
index 00000000..4879e97d
--- /dev/null
+++ b/tools/coq_makefile.ml4
@@ -0,0 +1,454 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coq_makefile.ml4,v 1.16.2.1 2004/07/16 19:31:45 herbelin Exp $ *)
+
+(* créer un Makefile pour un développement Coq automatiquement *)
+
+type target =
+  | ML of string (* ML file : foo.ml -> (ML "foo") *)
+  | V of string  (* V file : foo.v -> (V "foo") *)
+  | Special of string * string * string (* file, dependencies, command *)
+  | Subdir of string
+  | Def of string * string (* X=foo -> Def ("X","foo") *)
+  | Include of string
+  | RInclude of string * string (* -R physicalpath logicalpath *)
+
+let output_channel = ref stdout
+let makefile_name = ref "Makefile"
+let make_name = ref ""
+
+let some_file = ref false
+let some_vfile = ref false
+let some_mlfile = ref false
+
+let opt = ref "-opt"
+let impredicative_set = ref false
+
+let print x = output_string !output_channel x
+let printf x = Printf.fprintf !output_channel x
+
+let rec print_list sep = function
+  | [ x ] -> print x
+  | x :: l -> print x; print sep; print_list sep l
+  | [] -> ()
+
+let section s =
+  let l = String.length s in
+  let sep = String.make (l+5) '#'
+  and sep2 = String.make (l+5) ' ' in
+  String.set sep (l+4) '\n';
+  String.set sep2 0 '#';
+  String.set sep2 (l+3) '#';
+  String.set sep2 (l+4) '\n';
+  print sep;
+  print sep2;
+  print "# "; print s; print " #\n";
+  print sep2;
+  print sep;
+  print "\n"
+
+let usage () =
+  output_string stderr "Usage summary:
+
+coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom
+  command dependencies file] ... [-I dir] ... [-R physicalpath logicalpath]
+  ... [VARIABLE = value] ...  [-opt|-byte] [-f file] [-o file] [-h] [--help]
+
+[file.v]: Coq file to be compiled
+[file.ml]: ML file to be compiled
+[subdirectory] : subdirectory that should be \"made\"
+[-custom command dependencies file]: add target \"file\" with command
+  \"command\" and dependencies \"dependencies\"
+[-I dir]: look for dependencies in \"dir\"
+[-R physicalpath logicalpath]: look for dependencies resursively starting from
+ \"physicalpath\". The logical path associated to the physical path is
+ \"logicalpath\".
+[VARIABLE = value]: Add the variable definition \"VARIABLE=value\"
+[-byte]: compile with byte-code version of coq
+[-opt]: compile with native-code version of coq
+[-impredicative-set]: compile with option -impredicative-set of coq
+[-f file]: take the contents of file as arguments
+[-o file]: output should go in file file 
+[-h]: print this usage summary
+[--help]: equivalent to [-h]\n";
+  exit 1
+
+let standard sds =
+  print "byte:\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";
+  if !some_file then print "include .depend\n\n";
+  print ".depend depend:\n";
+  if !some_file then begin
+    print "\trm -f .depend\n";
+    print "\t$(COQDEP) -i $(COQLIBS) *.v *.ml *.mli >.depend\n";
+    print "\t$(COQDEP) $(COQLIBS) -suffix .html *.v >>.depend\n";
+  end;
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) depend)\n")
+    sds;
+  print "\n";
+  print "install:\n";
+  print "\tmkdir -p `$(COQC) -where`/user-contrib\n";
+  if !some_vfile then print "\tcp -f *.vo `$(COQC) -where`/user-contrib\n";
+  if !some_mlfile then print "\tcp -f *.cmo `$(COQC) -where`/user-contrib\n";
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) install)\n")
+    sds;
+  print "\n";
+  if !make_name <> "" then begin
+    printf "%s: %s\n" !makefile_name !make_name;
+    printf "\tmv -f %s %s.bak\n" !makefile_name !makefile_name;
+    printf "\t$(COQBIN)coq_makefile -f %s -o %s\n" !make_name !makefile_name;
+    print "\n";
+    List.iter
+      (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n")
+      sds;
+    print "\n";
+  end;
+  print "clean:\n";
+  print "\trm -f *.cmo *.cmi *.cmx *.o *.vo *.vi *.g *~\n";
+  print "\trm -f all.ps all-gal.ps $(HTMLFILES) $(GHTMLFILES)\n";
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n")
+    sds;
+  print "\n";
+  print "archclean:\n";
+  print "\trm -f *.cmx *.o\n";
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n")
+    sds;
+  print "\n";
+  print "html:\n";
+  List.iter
+    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) html)\n")
+    sds;
+  print "\n"
+
+let implicit () =
+  let ml_rules () =
+    print ".mli.cmi:\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print ".ml.cmo:\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n";
+    print ".ml.cmx:\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) $<\n\n";
+  and v_rule () =
+    print ".v.vo:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print ".v.vi:\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print ".v.g:\n\t$(GALLINA) $<\n\n";
+    print ".v.tex:\n\t$(COQDOC) -latex $< -o $@\n\n";
+    print ".v.html:\n\t$(COQDOC) -html $< -o $@\n\n";
+    print ".v.g.tex:\n\t$(COQDOC) -latex -g $< -o $@\n\n";
+    print ".v.g.html:\n\t$(COQDOC) -html -g $< -o $@\n\n"
+  and ml_suffixes =
+    if !some_mlfile then 
+      [ ".mli"; ".ml"; ".cmo"; ".cmi"; ".cmx" ]
+    else 
+      []
+  and v_suffixes =
+    if !some_vfile then 
+      [ ".v"; ".vo"; ".vi"; ".g"; ".html"; ".tex"; ".g.tex"; ".g.html" ] 
+    else 
+      []
+  in
+  let suffixes = ml_suffixes @ v_suffixes in
+  if suffixes <> [] then begin
+    print ".SUFFIXES: "; print_list " " suffixes;
+    print "\n\n"
+  end;
+  if !some_mlfile then ml_rules ();
+  if !some_vfile then v_rule ()
+
+let variables l =
+  let rec var_aux = function
+    | [] -> ()
+    | Def(v,def) :: r -> print v; print "="; print def; print "\n"; var_aux r
+    | _ :: r -> var_aux r
+  in
+  section "Variables definitions.";
+  print "CAMLP4LIB=`camlp4 -where`\n";
+(*  print "MAKE=make \"COQBIN=$(COQBIN)\" \"OPT=$(OPT)\"\n"; *)
+  print "COQSRC=-I $(COQTOP)/kernel -I $(COQTOP)/lib \\
+  -I $(COQTOP)/library -I $(COQTOP)/parsing \\
+  -I $(COQTOP)/pretyping -I $(COQTOP)/interp \\
+  -I $(COQTOP)/proofs -I $(COQTOP)/syntax -I $(COQTOP)/tactics \\
+  -I $(COQTOP)/toplevel -I $(COQTOP)/contrib/correctness \\
+  -I $(COQTOP)/contrib/extraction -I $(COQTOP)/contrib/field \\
+  -I $(COQTOP)/contrib/fourier -I $(COQTOP)/contrib/graphs \\
+  -I $(COQTOP)/contrib/interface -I $(COQTOP)/contrib/jprover \\
+  -I $(COQTOP)/contrib/omega -I $(COQTOP)/contrib/romega \\
+  -I $(COQTOP)/contrib/ring -I $(COQTOP)/contrib/xml \\
+  -I $(CAMLP4LIB)\n";
+  print "ZFLAGS=$(OCAMLLIBS) $(COQSRC)\n";
+  if !opt = "-byte" then 
+    print "override OPT=-byte\n"
+  else
+    print "OPT=\n";
+  if !impredicative_set = true then print "OTHERFLAGS=-impredicative-set\n";
+  print "COQFLAGS=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
+  print "COQC=$(COQBIN)coqc\n";
+  print "GALLINA=gallina\n";
+  print "COQDOC=coqdoc\n";
+  print "CAMLC=ocamlc -c\n";
+  print "CAMLOPTC=ocamlopt -c\n";
+  print "CAMLLINK=ocamlc\n";
+  print "CAMLOPTLINK=ocamlopt\n";
+  print "COQDEP=$(COQBIN)coqdep -c\n";
+  print "GRAMMARS=grammar.cma\n";
+  print "CAMLP4EXTEND=pa_extend.cmo pa_ifdef.cmo q_MLast.cmo\n";
+  print "PP=-pp \"camlp4o -I . -I $(COQTOP)/parsing $(CAMLP4EXTEND) $(GRAMMARS) -impl\"\n";
+  var_aux l;
+  print "\n"
+
+let include_dirs l =
+  let include_aux' includeR =
+   let rec include_aux = function
+     | [] -> []
+     | Include x :: r -> ("-I " ^ x) :: (include_aux r)
+     | RInclude (p,l) :: r when includeR ->
+        let l' = if l = "" then "\"\"" else l in
+        ("-R " ^ p ^ " " ^ l') :: (include_aux r)
+     | _ :: r -> include_aux r
+   in
+    include_aux
+  in
+  let i_ocaml = "-I ." :: (include_aux' false l) in
+  let i_coq   = "-I ." :: (include_aux' true  l) in
+  section "Libraries definition.";
+  print "OCAMLLIBS="; print_list "\\\n  " i_ocaml; print "\n";
+  print "COQLIBS=";   print_list "\\\n  " i_coq; print "\n\n"
+
+let special l =
+  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
+
+let subdirs l =
+  let rec subdirs_aux = function
+    | [] -> []
+    | Subdir x :: r -> x :: (subdirs_aux r)
+    | _ :: r -> subdirs_aux r
+  and pr_subdir s =
+    print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n"
+  in
+  let sds = subdirs_aux l in
+  if sds <> [] then section "Subdirectories.";
+  List.iter pr_subdir sds;
+  section "Special targets.";
+  print ".PHONY: ";
+  print_list " "
+    ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install" 
+     :: "depend" :: "html" :: sds);
+  print "\n\n";
+  sds
+
+(* Extract gallina/html filenames (foo.v) from the list of all targets *)
+
+let rec other_files suff = function
+  | V n :: r -> 
+      let f = (Filename.chop_suffix n ".vo") ^ suff in
+      f :: (other_files suff r)
+  | _   :: r -> 
+      other_files suff r
+  | [] -> 
+      []
+
+let vfiles = other_files ".v"
+let gfiles = other_files ".g"
+let hfiles = other_files ".html"
+let tfiles = other_files ".tex"
+let vifiles = other_files ".vi"
+let gtfiles l = List.map (fun f -> f ^ ".tex") (gfiles l)
+let ghfiles l = List.map (fun f -> f ^ ".html") (gfiles l)
+let vofiles = other_files ".vo"
+
+let all_target l =
+  let rec fnames = function
+    | ML n :: r -> n :: (fnames r)
+    | Subdir n :: r -> n :: (fnames r)
+    | V n :: r -> n :: (fnames r)
+    | Special (n,_,_) :: r -> n :: (fnames r)
+    | Include _ :: r -> fnames r
+    | RInclude _ :: r -> fnames r
+    | Def _ :: r -> fnames r
+    | [] -> []
+  in
+  section "Definition of the \"all\" target.";
+  print "VFILES="; print_list "\\\n  " (vfiles l); print "\n";
+  print "VOFILES=$(VFILES:.v=.vo)\n";
+  print "VIFILES=$(VFILES:.v=.vi)\n";
+  print "GFILES=$(VFILES:.v=.g)\n";
+  print "HTMLFILES=$(VFILES:.v=.html)\n";
+  print "GHTMLFILES=$(VFILES:.v=.g.html)\n";
+  print "\n";
+  print "all: "; print_list "\\\n  " (fnames l);
+  print "\n\n";
+  if !some_vfile then begin
+    print "spec: $(VIFILES)\n\n";
+    print "gallina: $(GFILES)\n\n";
+    print "html: $(HTMLFILES)\n\n";
+    print "gallinahtml: $(GHTMLFILES)\n\n";
+    print "all.ps: $(VFILES)\n";
+    print "\t$(COQDOC) -ps -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
+    print "all-gal.ps: $(VFILES)\n";
+    print "\t$(COQDOC) -ps -g -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n";
+    print "\n\n"
+  end
+
+let parse f =
+  let rec string = parser 
+    | [< '' ' | '\n' | '\t' >] -> ""
+    | [< 'c; s >] -> (String.make 1 c)^(string s)
+    | [< >] -> ""
+  and string2 = parser 
+    | [< ''"' >] -> ""
+    | [< 'c; s >] -> (String.make 1 c)^(string2 s)
+  and skip_comment = parser 
+    | [< ''\n'; s >] -> s
+    | [< 'c; s >] -> skip_comment s
+    | [< >] -> [< >]
+  and args = parser 
+    | [< '' ' | '\n' | '\t'; s >] -> args s
+    | [< ''#'; s >] -> args (skip_comment s)
+    | [< ''"'; str = string2; s >] -> ("" ^ str) :: args s
+    | [< 'c; str = string; s >] -> ((String.make 1 c) ^ str) :: (args s)
+    | [< >] -> []
+  in
+  let c = open_in f in
+  let res = args (Stream.of_channel c) in
+  close_in c;
+  res
+
+let rec process_cmd_line = function
+  | [] -> 
+      some_file := !some_file or !some_mlfile or !some_vfile; []
+  | ("-h"|"--help") :: _ -> 
+      usage ()
+  | ("-no-opt"|"-byte") :: r -> 
+      opt := "-byte"; process_cmd_line r
+  | ("-full"|"-opt") :: r -> 
+      opt := "-opt"; process_cmd_line r
+  | "-impredicative-set" :: r ->
+      impredicative_set := true; process_cmd_line r
+  | "-custom" :: com :: dependencies :: file :: r ->
+      some_file := true;
+      Special (file,dependencies,com) :: (process_cmd_line r)
+  | "-I" :: d :: r ->
+      Include d :: (process_cmd_line r)
+  | "-R" :: p :: l :: r ->
+      RInclude (p,l) :: (process_cmd_line r)
+  | ("-I"|"-custom") :: _ -> 
+      usage ()
+  | "-f" :: file :: r -> 
+      make_name := file;
+      process_cmd_line ((parse file)@r)
+  | ["-f"] -> 
+      usage ()
+  | "-o" :: file :: r -> 
+      makefile_name := file;
+      output_channel := (open_out file);
+      (process_cmd_line r)
+  | v :: "=" :: def :: r -> 
+      Def (v,def) :: (process_cmd_line r)
+  | f :: r ->
+      if Filename.check_suffix f ".v" then begin
+        some_vfile := true; 
+	V (f^"o") :: (process_cmd_line r)
+      end else if Filename.check_suffix f ".ml" then begin
+        some_mlfile := true; 
+	ML ((Filename.chop_suffix f "ml")^"cmo") :: (process_cmd_line r)
+      end else
+        Subdir f :: (process_cmd_line r)
+
+let banner () =
+  print
+"##############################################################################
+##                 The Calculus of Inductive Constructions                  ##
+##                                                                          ##
+##                                Projet Coq                                ##
+##                                                                          ##
+##                     INRIA                        ENS-CNRS                ##
+##              Rocquencourt                        Lyon                    ##
+##                                                                          ##
+##                                  Coq V7                                  ##
+##                                                                          ##
+##                                                                          ##
+##############################################################################
+
+"
+
+let warning () =
+  print "# WARNING\n#\n";
+  print "# This Makefile has been automagically generated by coq_makefile\n";
+  print "# Edit at your own risks !\n";
+  print "#\n# END OF WARNING\n\n"
+
+let print_list l = List.iter (fun x -> print x; print " ") l
+
+let command_line args =
+  print "#\n# This Makefile was generated by the command line :\n";
+  print "# coq_makefile ";
+  print_list args;
+  print "\n#\n\n"
+
+let directories_deps l =
+  let print_dep f dep = 
+    if dep <> [] then begin print f; print ": "; print_list dep; print "\n" end
+  in
+  let rec iter ((dirs,before) as acc) = function
+    | [] -> 
+	()
+    | (Subdir d) :: l -> 
+	print_dep d before; iter (d :: dirs, d :: before) l
+    | (ML f) :: l ->
+	print_dep f dirs; iter (dirs, f :: before) l
+    | (V f) :: l ->
+	print_dep f dirs; iter (dirs, f :: before) l
+    | (Special (f,_,_)) :: l ->
+	print_dep f dirs; iter (dirs, f :: before) l
+    | _ :: l -> 
+	iter acc l
+  in
+  iter ([],[]) l
+
+let do_makefile args =
+  let l = process_cmd_line args in
+  banner ();
+  warning ();
+  command_line args;
+  variables l;
+  include_dirs l;
+  all_target l;
+  special l;
+  let sds = subdirs l in
+  implicit ();
+  standard sds;
+  (* TEST directories_deps l; *)
+  warning ();
+  if not (!output_channel == stdout) then close_out !output_channel;
+  exit 0
+
+let main () =
+  let args =
+    if Array.length Sys.argv = 1 then usage ();
+    List.tl (Array.to_list Sys.argv)
+  in
+  do_makefile args
+
+let _ = Printexc.catch main ()
+
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
new file mode 100755
index 00000000..ab7cef92
--- /dev/null
+++ b/tools/coqdep.ml
@@ -0,0 +1,537 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqdep.ml,v 1.15.2.1 2004/07/16 19:31:46 herbelin Exp $ *)
+
+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
+
+let coqlib = ref Coq_config.coqlib
+
+let option_c = ref false
+let option_D = ref false
+let option_w = ref false
+let option_i = ref false
+let option_sort = ref false
+
+let suffixe = ref ".vo"
+let suffixe_spec = ref ".vi"
+
+type dir = string option
+
+(* Files specified on the command line *)
+let mlAccu  = ref ([] : (string * string * dir) list) 
+and mliAccu = ref ([] : (string * string * dir) list) 
+and vAccu   = ref ([] : string list)
+
+(* Queue operations *)
+let addQueue q v = q := v :: !q
+
+let safe_addQueue clq q (k,v) =
+  try
+    let v2 = List.assoc k !q in
+    if v<>v2 then 
+      let rec add_clash = function
+          (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl
+        | cl::cltl -> cl::add_clash cltl
+        | [] -> [(k,[v;v2])] in
+      clq := add_clash !clq
+  with Not_found -> addQueue q (k,v)
+
+(* Files found in the loadpaths *)
+let mlKnown     = ref ([] : (string * dir) list) 
+and mliKnown    = ref ([] : (string * dir) list) 
+and vKnown      = ref ([] : (string list * string) list) 
+and coqlibKnown = ref ([] : (string list * string) list)
+
+let clash_v = ref ([]: (string list * string list) list)
+
+
+let warning_module_notfound f s =
+  eprintf "*** Warning : in file %s, module " f;
+  eprintf "%s.v is required and has not been found in loadpath !\n"
+    (String.concat "." s);
+  flush stderr
+
+let warning_notfound f s =
+  eprintf "*** Warning : in file %s, the file " f;
+  eprintf "%s.v is required and has not been found !\n" s;
+  flush stderr
+
+let warning_clash file dir =
+  match List.assoc dir !clash_v with
+    (f1::f2::fl) ->
+      let f = Filename.basename f1 in
+      let d1 = Filename.dirname f1 in
+      let d2 = Filename.dirname f2 in
+      let dl = List.map Filename.dirname (List.rev fl) in
+      eprintf
+        "*** Warning : in file %s, \n    required module %s is ambiguous!\n    (found %s.v in "
+        file (String.concat "." dir) f;
+      List.iter (fun s -> eprintf "%s, " s) dl;
+      eprintf "%s and %s)\n" d2 d1
+  | _ -> assert false
+
+let safe_assoc verbose file k =
+  if verbose && List.mem_assoc k !clash_v then warning_clash file k;
+  List.assoc k !vKnown
+
+
+     
+let file_name = function
+  | (s,None)     -> file_concat s 
+  | (s,Some ".") -> file_concat s
+  | (s,Some d)   -> d / file_concat s
+
+let traite_fichier_ML md ext =
+  try 
+    let chan = open_in (md ^ ext) in 
+    let buf = Lexing.from_channel chan in 
+    let deja_vu = ref [md] in
+    let a_faire = ref "" in
+    let a_faire_opt = ref "" in
+    begin try 
+      while true do
+	let (Use_module str) = caml_action buf in
+	if List.mem str !deja_vu then 
+	  ()
+	else begin
+	  addQueue deja_vu str;
+          begin try
+            let mlidir = List.assoc str !mliKnown in
+            let filename = file_name ([str],mlidir) in
+      	    a_faire := !a_faire ^ " " ^ filename ^ ".cmi"; 
+          with Not_found ->
+            try
+              let mldir = List.assoc str !mlKnown in
+              let filename = file_name ([str],mldir) in
+              a_faire := !a_faire ^ " " ^ filename ^ ".cmo";
+            with Not_found -> ()
+          end;
+          begin try
+            let mldir = List.assoc str !mlKnown in
+            let filename = file_name ([str],mldir) in
+    	    a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmx"
+          with Not_found ->
+            try
+              let mlidir = List.assoc str !mliKnown in
+              let filename = file_name ([str],mlidir) in
+              a_faire_opt := !a_faire_opt ^ " " ^ filename ^ ".cmi"
+            with Not_found -> ()
+          end
+	end
+      done
+    with Fin_fichier -> ()
+    end;
+    close_in chan;
+    (!a_faire, !a_faire_opt)
+  with Sys_error _ -> ("","")
+
+let cut_prefix p s =
+  let lp = String.length p in
+  let ls = String.length s in
+  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
+  | _ -> cut_prefix "./" f
+
+let sort () = 
+  let seen = Hashtbl.create 97 in
+  let rec loop file =
+    let file = canonize file in
+    if not (Hashtbl.mem seen file) then begin
+      Hashtbl.add seen file ();
+      let cin = open_in (file ^ ".v") in
+      let lb = Lexing.from_channel cin in
+      try
+	while true do
+	  match coq_action lb with
+	    | Require (_, s) ->
+		(try loop (List.assoc s !vKnown) with Not_found -> ())
+	    | RequireString (_, s) -> loop s
+	    | _ -> ()
+	done
+      with Fin_fichier ->
+	close_in cin;
+	printf "%s%s " file !suffixe
+    end
+  in
+  List.iter loop !vAccu
+
+let traite_fichier_Coq verbose f = 
+  try 
+    let chan = open_in f in 
+    let buf = Lexing.from_channel chan in 
+    let deja_vu_v = ref ([]: string list list)
+    and deja_vu_ml = ref ([] : string list) in
+    try 
+      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
+	  | RequireString (spec,s) -> 
+	      let str = Filename.basename s in
+	      if not (List.mem [str] !deja_vu_v) then begin
+	        addQueue deja_vu_v [str];
+                try
+                  let file_str = List.assoc [str] !vKnown in
+                  printf " %s%s" (canonize file_str)
+                    (if spec then !suffixe_spec else !suffixe)
+                with Not_found -> 
+                  begin try  let _ = List.assoc [str] !coqlibKnown in ()
+                  with Not_found -> warning_notfound f s end
+       	      end
+	  | Declare sl -> 
+	      List.iter 
+		(fun str ->
+		   if not (List.mem str !deja_vu_ml) then begin
+		     addQueue deja_vu_ml str;
+               	     try
+              	       let mldir = List.assoc str !mlKnown in
+              	       printf " %s.cmo" (file_name ([str],mldir))
+              	     with Not_found -> () 
+		   end)
+		sl
+	  | Load str -> 
+	      let str = Filename.basename str in
+	      if not (List.mem [str] !deja_vu_v) then begin
+	        addQueue deja_vu_v [str];
+                try
+                  let file_str = List.assoc [str] !vKnown in
+                  printf " %s.v" (canonize file_str)
+                with Not_found -> ()
+       	      end
+      done
+    with Fin_fichier -> ();
+      close_in chan
+  with Sys_error _ -> () 
+
+
+let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151
+						     
+let mL_dep_list b f = 
+  try 
+    Hashtbl.find dep_tab f
+  with Not_found ->
+    let deja_vu = ref ([] : string list) in 
+    try 
+      let chan = open_in f in 
+      let buf = Lexing.from_channel chan in 
+      try 
+	while true do
+	  let (Use_module str) = caml_action buf in
+	  if str = b then begin
+	    eprintf "*** Warning : in file %s the" f;
+	    eprintf " notation %s. is useless !\n" b;
+	    flush stderr
+	  end else
+            if not (List.mem str !deja_vu) then addQueue deja_vu str
+      	done; []
+      with Fin_fichier -> begin
+	close_in chan; 
+	let rl = List.rev !deja_vu in
+      	Hashtbl.add dep_tab f rl;
+	rl
+      end
+    with Sys_error _ -> []
+
+let affiche_Declare f dcl = 
+  printf "\n*** In file %s: \n" f;
+  printf "Declare ML Module";
+  List.iter (fun str -> printf " \"%s\"" str) dcl;
+  printf ".\n";
+  flush stdout
+
+let warning_Declare f dcl =
+  eprintf "*** Warning : in file %s, the ML modules" f;
+  eprintf " declaration should be\n";
+  eprintf "*** Declare ML Module";
+  List.iter (fun str -> eprintf " \"%s\"" str) dcl;
+  eprintf ".\n";
+  flush stderr
+
+let traite_Declare f = 
+  let decl_list = ref ([] : string list) in
+  let rec treat = function
+    | s :: ll -> 
+	if (List.mem_assoc s !mlKnown) & not (List.mem s !decl_list) then begin
+       	  let mldir = List.assoc s !mlKnown in
+	  let fullname = file_name ([s],mldir) in
+	  let depl = mL_dep_list s (fullname ^ ".ml") in
+	  treat depl;
+	  decl_list := s :: !decl_list
+	end;
+	treat ll
+    | [] -> ()
+  in
+  try
+    let chan = open_in f in
+    let buf = Lexing.from_channel chan in
+    begin try 
+      while true do
+      	let tok = coq_action buf in
+      	(match tok with
+	   | Declare sl -> 
+	       decl_list := [];
+	       treat sl;
+	       decl_list := List.rev !decl_list;
+	       if !option_D then 
+		 affiche_Declare f !decl_list
+	       else if !decl_list <> sl then
+		 warning_Declare f !decl_list
+	   | _ -> ())
+      done
+    with Fin_fichier -> () end;
+    close_in chan
+  with Sys_error _ -> ()
+
+let file_mem (f,_,d) =
+  let rec loop = function
+    | (f1,_,d1) :: l -> (f1 = f && d1 = d) || (loop l)
+    | _ -> false
+  in 
+  loop
+
+let mL_dependencies () =
+  List.iter 
+    (fun ((name,ext,dirname) as pairname) ->
+       let fullname = file_name ([name],dirname) in
+       let (dep,dep_opt) = traite_fichier_ML fullname ext in
+       printf "%s.cmo: %s%s" fullname fullname ext;
+       if file_mem pairname !mliAccu then printf " %s.cmi" fullname;
+       printf "%s\n" dep;
+       printf "%s.cmx: %s%s" fullname fullname ext;
+       if file_mem pairname !mliAccu then printf " %s.cmi" fullname;
+       printf "%s\n" dep_opt;
+       flush stdout)
+    (List.rev !mlAccu);
+  List.iter
+    (fun ((name,ext,dirname) as pairname) ->
+       let fullname = file_name ([name],dirname) in
+       let (dep,_) = traite_fichier_ML fullname ext in
+       printf "%s.cmi: %s%s" fullname fullname ext;
+       printf "%s\n" dep;
+       flush stdout)
+    (List.rev !mliAccu)
+
+let coq_dependencies () =
+  List.iter
+    (fun name ->
+       printf "%s%s: %s.v" name !suffixe name;
+       traite_fichier_Coq true (name ^ ".v");
+       printf "\n";
+       if !option_i then begin
+	 printf "%s%s: %s.v" name !suffixe_spec name;
+	 traite_fichier_Coq false (name ^ ".v");
+	 printf "\n";
+       end;
+       flush stdout)
+    (List.rev !vAccu)
+
+let declare_dependencies () =
+  List.iter
+    (fun name ->
+       traite_Declare (name^".v");      
+       flush stdout)
+    (List.rev !vAccu)
+
+let rec warning_mult suf l = 
+  let tab = Hashtbl.create 151 in
+  List.iter 
+    (fun (f,d) -> 
+       begin try 
+	 let d' = Hashtbl.find tab f in
+	 if (Filename.dirname (file_name ([f],d)))
+      	   <> (Filename.dirname (file_name ([f],d'))) then begin
+	     eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf);
+	     flush stderr
+	   end
+       with Not_found -> () end;
+       Hashtbl.add tab f d) 
+    l
+
+(* Gives the list of all the directories under [dir], including [dir] *)
+let all_subdirs root_dir log_dir =
+  let l = ref [(root_dir,[log_dir])] in
+  let add f = l := f :: !l in
+  let rec traverse phys_dir dir =
+    let dirh = handle_unix_error opendir phys_dir in
+    try
+      while true do
+	let f = readdir dirh in
+	if f <> "." && f <> ".." then
+	  let file = dir@[f] in
+          let filename = phys_dir/f in
+	  if (stat filename).st_kind = S_DIR then begin
+	    add (filename,file);
+	    traverse filename file
+	  end
+      done
+    with End_of_file ->
+      closedir dirh
+  in
+  traverse root_dir [log_dir]; List.rev !l
+
+let usage () =
+  eprintf
+  "[ usage: coqdep [-w] [-I dir] [-coqlib dir] [-c] [-i] [-D] <filename>+ ]\n";
+  flush stderr;
+  exit 1
+
+let add_coqlib_known dir_name f =
+  let complete_name = dir_name/f in
+  let lib_name = Filename.basename dir_name in
+  match try (stat complete_name).st_kind with _ -> S_BLK with 
+    | S_REG -> 
+	if Filename.check_suffix f ".vo" then
+	  let basename = Filename.chop_suffix f ".vo" in
+	  addQueue coqlibKnown ([basename],complete_name);
+	  addQueue coqlibKnown (["Coq";lib_name;basename],complete_name)
+    | _ -> ()
+
+let add_coqlib_directory dir_name = 
+  match try (stat dir_name).st_kind with _ -> S_BLK with 
+    | S_DIR -> 
+	(let dir = opendir dir_name in
+      	 try
+	   while true do add_coqlib_known dir_name (readdir dir) done
+	 with End_of_file -> closedir dir)
+    | _ -> ()
+
+let coqdep () =
+  let lg_command = Array.length Sys.argv in
+  if lg_command < 2 then usage ();
+  let rec treat old_dirname old_name =
+    let name = Filename.basename old_name 
+    and new_dirname = Filename.dirname old_name in
+    let dirname = 
+      match (old_dirname,new_dirname) with 
+	| (d, ".") -> d
+	| (None,d) -> Some d
+	| (Some d1,d2) -> Some (d1/d2) 
+    in
+    let complete_name = file_name ([name],dirname) in
+    match try (stat complete_name).st_kind with _ -> S_BLK with 
+      | S_DIR ->
+	  (if name <> "." & name <> ".." then
+	     let dir=opendir complete_name in
+             let newdirname = 
+               match dirname with 
+                 | None -> name
+                 | Some d -> d/name 
+	     in
+	     try 
+	       while true do treat (Some newdirname) (readdir dir) done
+	     with End_of_file -> closedir dir)
+      | S_REG -> 
+	  if Filename.check_suffix name ".ml" then
+	    let basename = Filename.chop_suffix name ".ml" in
+	    addQueue mlAccu (basename,".ml",dirname)
+	  else if Filename.check_suffix name ".ml4" then
+	    let basename = Filename.chop_suffix name ".ml4" in
+	    addQueue mlAccu (basename,".ml4",dirname)
+	  else if Filename.check_suffix name ".mli" then
+	    let basename = Filename.chop_suffix name ".mli" in
+	    addQueue mliAccu (basename,".mli",dirname)
+	  else if Filename.check_suffix name ".v" then
+	    let basename = Filename.chop_suffix name ".v" in
+	    addQueue vAccu (file_name ([basename], dirname))
+      | _ -> ()
+  in 
+  let add_known phys_dir log_dir f =
+    let complete_name = phys_dir/f in
+    match try (stat complete_name).st_kind with _ -> S_BLK with 
+	| S_REG ->
+	    if Filename.check_suffix f ".ml" then
+	      let basename = Filename.chop_suffix f ".ml" in
+	      addQueue mlKnown (basename,Some phys_dir)
+	    else if Filename.check_suffix f ".ml4" then
+	      let basename = Filename.chop_suffix f ".ml4" in
+	      addQueue mlKnown (basename,Some phys_dir)
+	    else if Filename.check_suffix f ".mli" then
+	      let basename = Filename.chop_suffix f ".mli" in
+	      addQueue mliKnown (basename,Some phys_dir)
+	    else if Filename.check_suffix f ".v" then
+	      let basename = Filename.chop_suffix f ".v" in
+              let name = log_dir@[basename] in
+              let file = phys_dir/basename in
+              let paths = [name;[basename]] in
+	      List.iter
+                (fun n -> safe_addQueue clash_v vKnown (n,file)) paths
+        | _ -> () in
+  let add_directory (phys_dir, log_dir) = 
+      match try (stat phys_dir).st_kind with _ -> S_BLK with 
+	| S_DIR -> 
+	    (let dir = opendir phys_dir in
+      	     try
+	       while true do
+                 add_known phys_dir log_dir (readdir dir) done
+	     with End_of_file -> closedir dir)
+        | _ -> ()
+  in
+  let add_rec_directory dir_name log_name =
+    List.iter add_directory (all_subdirs dir_name log_name)
+  in
+  let rec parse = function
+      | "-c" :: ll -> option_c := true; parse ll
+      | "-D" :: ll -> option_D := true; parse ll
+      | "-w" :: ll -> option_w := true; parse ll
+      | "-i" :: ll -> option_i := true; parse ll
+      | "-sort" :: ll -> option_sort := true; parse ll
+      | "-I" :: r :: ll -> add_directory (r, []); parse ll
+      | "-I" :: [] -> usage ()
+      | "-R" :: r :: ln :: ll -> add_rec_directory r ln; parse ll
+      | "-R" :: ([] | [_]) -> usage ()
+      | "-coqlib" :: (r :: ll) -> coqlib := r; parse ll
+      | "-coqlib" :: [] -> usage ()
+      | "-suffix" :: (s :: ll) -> suffixe := s ; suffixe_spec := s; parse ll
+      | "-suffix" :: [] -> usage ()
+      | f :: ll -> treat None f; parse ll
+      | [] -> ()
+  in
+  add_directory (".", []);
+  parse (List.tl (Array.to_list Sys.argv));
+  List.iter
+    (fun (s,_) -> add_coqlib_directory s)
+    (all_subdirs (!coqlib/"theories") "Coq");
+  List.iter 
+    (fun (s,_) -> add_coqlib_directory s)
+    (all_subdirs (!coqlib/"contrib") "Coq");
+  mliKnown := !mliKnown @ (List.map (fun (f,_,d) -> (f,d)) !mliAccu);
+  mlKnown  := !mlKnown @ (List.map (fun (f,_,d) -> (f,d)) !mlAccu);
+  warning_mult ".mli" !mliKnown;
+  warning_mult ".ml" !mlKnown;
+(*  warning_mult ".v" (List.map (fun (s,d) -> (file_concat s, d))
+  !vKnown);*)
+  if !option_sort then begin sort (); exit 0 end;
+  if !option_c && not !option_D then mL_dependencies ();
+  if not !option_D then coq_dependencies ();
+  if !option_w || !option_D then declare_dependencies ()
+
+let _ = Printexc.catch coqdep ()
diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
new file mode 100755
index 00000000..4f5f172f
--- /dev/null
+++ b/tools/coqdep_lexer.mll
@@ -0,0 +1,231 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqdep_lexer.mll,v 1.6.6.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+  
+{
+
+  open Filename 
+  open Lexing
+   
+  type mL_token = Use_module of string
+
+  type spec = bool
+		
+  type coq_token = 
+    | Require of spec * string list
+    | RequireString of spec * string
+    | Declare of string list
+    | Load of string
+
+  let comment_depth = ref 0
+ 
+  exception Fin_fichier
+    
+  let module_name = ref []
+  let ml_module_name = ref ""
+		      
+  let specif = ref false
+		 
+  let mllist = ref ([] : string list)
+
+  let field_name s = String.sub s 1 (String.length s - 1)
+}
+
+let space = [' ' '\t' '\n' '\r']
+let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255']
+let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let identchar = 
+  ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+let coq_ident = ['a'-'z' '_' '0'-'9' 'A'-'Z']+
+let coq_field = '.'['a'-'z' '_' '0'-'9' 'A'-'Z']+
+let dot = '.' ( space+ | eof)
+
+rule coq_action = parse
+  | "Require" space+
+      { specif := false; opened_file lexbuf }
+  | "Require" space+ "Export" space+
+      { specif := false; opened_file lexbuf}
+  | "Require" space+ "Syntax" space+
+      { specif := false; opened_file lexbuf}
+  | "Require" space+ "Import" space+
+      { specif := false; opened_file lexbuf}
+  | "Declare" space+ "ML" space+ "Module" space+
+      { mllist := []; modules lexbuf}
+  | "Load" space+
+      { load_file lexbuf }
+  | "\""
+      { string lexbuf; coq_action lexbuf}
+  | "(*" (* "*)" *)
+      { comment_depth := 1; comment lexbuf; coq_action lexbuf }  
+  | eof 
+      { raise Fin_fichier} 
+  | _   
+      { coq_action lexbuf }
+
+and caml_action = parse
+  | [' ' '\010' '\013' '\009' '\012'] +
+      { caml_action lexbuf }
+  | "open" [' ' '\010' '\013' '\009' '\012']*
+        { caml_opened_file lexbuf }
+  | lowercase identchar*
+      { caml_action lexbuf }
+  | uppercase identchar*
+      { ml_module_name := Lexing.lexeme lexbuf;
+        qual_id lexbuf }
+  | ['0'-'9']+
+    | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
+    | '0' ['o' 'O'] ['0'-'7']+
+    | '0' ['b' 'B'] ['0'-'1']+
+      { caml_action lexbuf }
+  | ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+      { caml_action lexbuf }
+  | "\""
+      { string lexbuf; caml_action lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { caml_action lexbuf }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { caml_action lexbuf }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { caml_action lexbuf }
+  | "(*" (* "*)" *)
+      { comment_depth := 1; comment lexbuf; caml_action lexbuf }
+  | "#" | "&"  | "&&" | "'" | "(" | ")" | "*" | "," | "?" | "->" | "." | ".."
+   | ".(" | ".[" | ":" | "::" | ":=" | ";" | ";;" | "<-" | "=" | "[" | "[|"
+   | "[<" | "]" | "_" | "{" | "|" | "||" | "|]" | ">]" | "}" | "!=" | "-"
+   | "-."    { caml_action lexbuf }
+
+  | ['!' '?' '~']
+    ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
+            { caml_action lexbuf }
+  | ['=' '<' '>' '@' '^' '|' '&' '$']
+    ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
+            { caml_action lexbuf }
+  | ['+' '-']
+    ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
+            { caml_action lexbuf }
+  | "**"
+    ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
+            { caml_action lexbuf }
+  | ['*' '/' '%']
+    ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] *
+            { caml_action lexbuf }
+  | eof { raise Fin_fichier }
+  | _ { caml_action lexbuf }
+
+and comment = parse
+  | "(*" (* "*)" *)
+      { comment_depth := succ !comment_depth; comment lexbuf }
+  | "*)"
+      { comment_depth := pred !comment_depth;
+        if !comment_depth > 0 then comment lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { comment lexbuf }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { comment lexbuf }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { comment lexbuf }
+  | eof
+      { raise Fin_fichier } 
+  | _ { comment lexbuf }
+
+and string = parse
+  | '"' (* '"' *)
+      { () }
+  | '\\' ("\010" | "\013" | "\010\013") [' ' '\009'] *
+      { string lexbuf }
+  | '\\' ['\\' '"' 'n' 't' 'b' 'r'] (*'"'*)
+      { string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { string lexbuf }
+  | eof
+      { raise Fin_fichier }
+  | _
+      { string lexbuf }
+
+and load_file = parse
+  | '"' [^ '"']* '"' (*'"'*)
+      { let s = lexeme lexbuf in
+	let f = String.sub s 1 (String.length s - 2) in
+	skip_to_dot lexbuf;
+	Load (if check_suffix f ".v" then chop_suffix f ".v" else f) }
+  | coq_ident
+      { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s }
+  | eof	
+      { raise Fin_fichier }
+  | _
+      { load_file lexbuf }
+
+and skip_to_dot = parse
+  | dot { () }
+  | eof { () }
+  | _   { skip_to_dot lexbuf }
+
+and opened_file = parse
+  | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; opened_file lexbuf }
+  | space+
+      	       	{ opened_file lexbuf }
+  | "Implementation"
+                { opened_file lexbuf }
+  | "Specification"
+                { specif := true; opened_file lexbuf }
+  | coq_ident
+       	       	{ module_name := [Lexing.lexeme lexbuf];
+                  opened_file_fields lexbuf }
+
+  | '"' [^'"']* '"'   { (*'"'*)
+                        let lex = Lexing.lexeme lexbuf in
+      	       	       	let str = String.sub lex 1 (String.length lex - 2) in
+                        let str =
+                          if Filename.check_suffix str ".v" then
+                            Filename.chop_suffix str ".v"
+                          else str in
+			RequireString (!specif, str) }
+  | 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 }
+  | coq_field
+       	       	{ module_name :=
+                    field_name (Lexing.lexeme lexbuf) :: !module_name;
+                  opened_file_fields lexbuf }
+  | dot               { Require (!specif, List.rev !module_name) }
+  | eof		      { raise Fin_fichier }
+  | _		      { opened_file_fields lexbuf }
+
+
+and modules = parse
+  | space+              { modules lexbuf }
+  | "(*" (* "*)" *)	{ comment_depth := 1; comment lexbuf;
+      	       	       	  modules lexbuf }
+  | '"' [^'"']* '"'
+        { let lex = (Lexing.lexeme lexbuf) in 
+	  let str = String.sub lex 1 (String.length lex - 2) in
+	  mllist := str :: !mllist; modules lexbuf }
+  | _   { (Declare (List.rev !mllist)) }   
+
+and qual_id = parse
+  | '.' [^ '.' '(' '['] { Use_module (String.uncapitalize !ml_module_name) }
+  | eof { raise Fin_fichier }
+  | _ { caml_action lexbuf }
+
+and caml_opened_file = parse
+  | uppercase identchar*
+      { let lex = (Lexing.lexeme lexbuf) in 
+        let str = String.sub lex 0 (String.length lex) in
+        (Use_module (String.uncapitalize str)) }
+  | eof {raise Fin_fichier }
+  | _ { caml_action lexbuf }
+
+
+
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
new file mode 100644
index 00000000..2418b6e1
--- /dev/null
+++ b/tools/coqdoc/alpha.ml
@@ -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: alpha.ml,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+
+let norm_char c = match Char.uppercase c with
+  | '\192'..'\198' -> 'A'
+  | '\199' -> 'C'
+  | '\200'..'\203' -> 'E'
+  | '\204'..'\207' -> 'I'
+  | '\209' -> 'N'
+  | '\210'..'\214' -> 'O'
+  | '\217'..'\220' -> 'U'
+  | '\221' -> 'Y'
+  | c -> c
+
+let norm_string s =
+  let u = String.copy s in
+  for i = 0 to String.length s - 1 do
+    u.[i] <- norm_char s.[i]
+  done;
+  u
+
+let compare_char c1 c2 = match norm_char c1, norm_char c2 with
+  | ('A'..'Z' as c1), ('A'..'Z' as c2) -> compare c1 c2
+  | 'A'..'Z', _ -> -1
+  | _, 'A'..'Z' -> 1
+  | c1, c2 -> compare c1 c2
+
+let compare_string s1 s2 = 
+  let n1 = String.length s1 in
+  let n2 = String.length s2 in
+  let rec cmp i = 
+    if i == n1 || i == n2 then
+      n1 - n2
+    else
+      let c = compare_char s1.[i] s2.[i] in
+      if c == 0 then cmp (succ i) else c
+  in
+  cmp 0
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
new file mode 100644
index 00000000..46409c9a
--- /dev/null
+++ b/tools/coqdoc/alpha.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: alpha.mli,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+
+(* Alphabetic order. *)
+
+val compare_char : char -> char -> int
+val compare_string : string -> string -> int
+
+(* Alphabetic normalization. *)
+
+val norm_char : char -> char
+val norm_string : string -> string
diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty
new file mode 100644
index 00000000..7f7aa9aa
--- /dev/null
+++ b/tools/coqdoc/coqdoc.sty
@@ -0,0 +1,58 @@
+
+% This is coqdoc.sty, by Jean-Christophe Filliâtre
+% This LaTeX package is used by coqdoc (http://www.lri.fr/~filliatr/coqdoc)
+%
+% You can modify the following macros to customize the appearance
+% of the document.
+
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesPackage{coqdoc}[2002/02/11]
+
+% Headings
+
+\usepackage{fancyhdr}
+\newcommand{\coqdocleftpageheader}{\thepage\ -- \today}
+\newcommand{\coqdocrightpageheader}{\today\ -- \thepage}
+\pagestyle{fancyplain}
+
+%BEGIN LATEX
+\plainheadrulewidth 0.4pt
+\plainfootrulewidth 0pt
+\lhead[\coqdocleftpageheader]{\leftmark}
+\rhead[\leftmark]{\coqdocrightpageheader}
+\cfoot{}
+%END LATEX
+
+% Hevea puts to much space with \medskip and \bigskip
+%HEVEA\renewcommand{\medskip}{}
+%HEVEA\renewcommand{\bigskip}{}
+
+% own name
+\newcommand{\coqdoc}{\textsf{coqdoc}}
+
+% pretty underscores (the package fontenc causes ugly underscores)
+%BEGIN LATEX
+\def\_{\kern.08em\vbox{\hrule width.35em height.6pt}\kern.08em}
+%END LATEX
+
+% macro for typesetting keywords
+\newcommand{\coqdockw}[1]{\textsf{#1}}
+
+% macro for typesetting identifiers
+\newcommand{\coqdocid}[1]{\textit{#1}}
+
+% newline and indentation 
+%BEGIN LATEX
+\newcommand{\coqdoceol}{\setlength\parskip{0pt}\par}
+\newcommand{\coqdocindent}[1]{\noindent\kern#1}
+%END LATEX
+%HEVEA\newcommand{\coqdoceol}{\begin{rawhtml}<BR>\end{rawhtml}}
+%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}{}}
+
+%HEVEA\newcommand{\lnot}{\coqwkw{not}}
+%HEVEA\newcommand{\lor}{\coqwkw{or}}
+%HEVEA\newcommand{\land}{\&}
+
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
new file mode 100644
index 00000000..60c21387
--- /dev/null
+++ b/tools/coqdoc/index.mli
@@ -0,0 +1,59 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: index.mli,v 1.1.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+
+type coq_module = string
+
+type loc = int
+
+type entry_type = 
+  | Library
+  | Module
+  | Definition
+  | Inductive
+  | Constructor
+  | Lemma
+  | Variable
+  | Axiom
+  | TacticDefinition
+
+type index_entry = 
+  | Def of string * entry_type
+  | Ref of coq_module * string
+  | Mod of coq_module * string
+
+val find : coq_module -> loc -> index_entry
+
+val add_module : coq_module -> unit
+
+type module_kind = Local | Coqlib | Unknown
+
+val find_module : coq_module -> module_kind
+
+(*s Scan identifiers introductions from a file *)
+
+val scan_file : string -> coq_module -> unit
+
+(*s Read globalizations from a file (produced by coqc -dump-glob) *)
+
+val read_glob : string -> unit
+
+(*s Indexes *)
+
+type 'a index = { 
+  idx_name : string;
+  idx_entries : (char * (string * 'a) list) list;
+  idx_size : int }
+
+val all_entries : unit -> 
+      (coq_module * entry_type) index *
+      (entry_type * coq_module index) list
+
+val map : (string -> 'a -> 'b) -> 'a index -> 'b index
+
diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll
new file mode 100644
index 00000000..799825ad
--- /dev/null
+++ b/tools/coqdoc/index.mll
@@ -0,0 +1,327 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: index.mll,v 1.2.2.1 2004/07/16 19:31:46 herbelin Exp $ i*)
+
+{
+
+open Filename
+open Lexing 
+open Printf
+
+type coq_module = string
+
+type loc = int
+
+type entry_type = 
+  | Library
+  | Module
+  | Definition
+  | Inductive
+  | Constructor
+  | Lemma
+  | Variable
+  | Axiom
+  | TacticDefinition
+
+type index_entry = 
+  | Def of string * entry_type
+  | Ref of coq_module * string
+  | Mod of coq_module * string
+
+let table = Hashtbl.create 97
+
+let current_module = ref ""
+
+let add_def loc ty id = Hashtbl.add table (!current_module, loc) (Def (id, ty))
+
+let add_ref m loc m' id = Hashtbl.add table (m, loc) (Ref (m', id))
+
+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
+
+(* Coq modules *)
+
+let split_sp s = 
+  try
+    let i = String.rindex s '.' in
+    String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)
+  with Not_found -> 
+    "", s
+
+let modules = Hashtbl.create 97
+let local_modules = Hashtbl.create 97
+
+let add_module m =
+  let _,id = split_sp m in
+  Hashtbl.add modules id m;
+  Hashtbl.add local_modules m ()
+
+type module_kind = Local | Coqlib | Unknown
+
+let coq_module m =
+  String.length m >= 4 && String.sub m 0 4 = "Coq."
+
+let find_module m =
+  if Hashtbl.mem local_modules m then 
+    Local
+  else if coq_module m then
+    Coqlib
+  else
+    Unknown
+
+let ref_module loc s =
+  try
+    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
+  with Not_found -> 
+    ()
+
+(* Building indexes *)
+
+type 'a index = { 
+  idx_name : string;
+  idx_entries : (char * (string * 'a) list) list;
+  idx_size : int }
+		  
+let map f i = 
+  { i with idx_entries = 
+      List.map 
+	(fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) 
+	i.idx_entries }
+
+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
+    
+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"
+  | Definition -> "definition"
+  | Inductive -> "inductive"
+  | Constructor -> "constructor"
+  | Lemma -> "lemma"
+  | 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)
+  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; 
+				   idx_entries = sort_entries e; 
+				   idx_size = List.length e }) :: l) bt []
+
+}
+
+(*s Shortcuts for regular expressions. *)
+
+let space = 
+  [' ' '\010' '\013' '\009' '\012']
+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*
+
+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 }
+  | "Tactic" space+ "Definition" space
+      { current_type := TacticDefinition; index_ident lexbuf; traverse lexbuf }
+  | ("Axiom" | "Parameter") space 
+      { current_type := Axiom; index_ident lexbuf; traverse lexbuf }
+  | "Fixpoint" space
+      { current_type := Definition; index_ident lexbuf; fixpoint lexbuf;
+	traverse lexbuf }
+  | ("Lemma" | "Theorem") space
+      { current_type := Lemma; index_ident lexbuf; traverse lexbuf }
+  | "Inductive" space
+      { current_type := Inductive; 
+	index_ident lexbuf; inductive lexbuf; traverse lexbuf }
+  | "Record" space
+      { current_type := Inductive; index_ident lexbuf; traverse lexbuf }
+  | "Module" (space+ "Type")? space
+      { current_type := Module; index_ident lexbuf; traverse lexbuf }
+(*i***
+  | "Variable" 's'? space
+      { current_type := Variable; index_idents lexbuf; traverse lexbuf }
+***i*)
+  | "Require" (space+ "Export")? space+ ident
+      { ref_module (lexeme_start lexbuf) (lexeme lexbuf); traverse lexbuf }
+  | begin_hide 
+      { skip_hide lexbuf; traverse lexbuf }
+  | "(*" 
+      { comment lexbuf; traverse lexbuf }
+  | '"'
+      { string lexbuf; traverse lexbuf }
+  | eof          
+      { () }
+  | _            
+      { traverse lexbuf }
+
+(*s Index one identifier. *)
+
+and index_ident = parse
+  | space+ 
+      { index_ident lexbuf }
+  | ident  
+      { add_def (lexeme_start lexbuf) !current_type (lexeme lexbuf) }
+  | eof    
+      { () }
+  | _      
+      { () }
+
+(*s Index identifiers separated by blanks and/or commas. *)
+
+and index_idents = parse
+  | space+ | ','
+      { index_idents lexbuf }
+  | ident  
+      { add_def (lexeme_start lexbuf) !current_type (lexeme lexbuf);
+	index_idents lexbuf }
+  | eof    
+      { () }
+  | _
+      { 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 }
+  | "with" space
+      { current_type := Inductive; index_ident lexbuf; inductive lexbuf }
+  | '.'    
+      { () }
+  | eof    
+      { () }
+  | _      
+      { inductive lexbuf }
+
+(*s Index identifiers in a Fixpoint declaration. *)
+
+and fixpoint = parse
+  | "with" space
+      { index_ident lexbuf; fixpoint lexbuf }
+  | '.' 
+      { () }
+  | eof    
+      { () }
+  | _      
+      { fixpoint lexbuf }
+
+(*s Skip a possibly nested comment. *)
+
+and comment = parse
+  | "*)" { () }
+  | "(*" { comment lexbuf; comment lexbuf }
+  | '"'  { string lexbuf; comment lexbuf }
+  | eof  { eprintf " *** Unterminated comment while indexing" }
+  | _    { 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 }
+
+{
+  
+  let read_glob f = 
+    let c = open_in f in
+    let cur_mod = ref "" in
+    try
+      while true do
+	let s = input_line c in
+	let n = String.length s in
+	if n > 0 then begin
+	  match s.[0] with
+	    | 'F' -> 
+		cur_mod := String.sub s 1 (n - 1)
+	    | 'R' ->
+		(try
+		   let i = String.index s ' ' 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
+		 with Not_found -> 
+		   ())
+	    | _ -> ()
+	end
+      done
+    with End_of_file -> 
+      close_in c
+
+  let scan_file f m = 
+    current_module := m;
+    let c = open_in f in
+    let lb = from_channel c in
+    traverse lb;
+    close_in c
+}
diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
new file mode 100644
index 00000000..66d2a993
--- /dev/null
+++ b/tools/coqdoc/main.ml
@@ -0,0 +1,420 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: main.ml,v 1.4.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004:
+ *  - handling of absolute filenames (function coq_module)
+ *  - coq_module: chop ./// (arbitrary amount of slashes), not only "./"
+ *  - function chop_prefix not useful anymore. Deleted.
+ *  - correct typo in usage message: "-R" -> "--R"
+ *  - shorten the definition of make_path
+ * This notice is made to comply with section 2.a of the GPLv2.
+ * It may be removed or abbreviated as far as I am concerned.
+ *)
+
+open Filename
+open Printf
+open Output
+open Pretty
+
+(*s \textbf{Usage.} Printed on error output. *)
+
+let usage () =
+  prerr_endline "";
+  prerr_endline "Usage: coqdoc <options and files>";
+  prerr_endline "  --html              produce a HTML document (default)";
+  prerr_endline "  --latex             produce a LaTeX document";
+  prerr_endline "  --texmacs           produce a TeXmacs document";
+  prerr_endline "  --dvi               output the DVI";
+  prerr_endline "  --ps                output the PostScript";
+  prerr_endline "  -o <file>           write output in file <file>";
+  prerr_endline "  -d <dir>            output files into directory <dir>";
+  prerr_endline "  -g                  (gallina) skip proofs";
+  prerr_endline "  -s                  (short) no titles for files";
+  prerr_endline "  -l                  light mode (only defs and statements)";
+  prerr_endline "  -t <string>         give a title to the document";
+  prerr_endline "  --body-only         suppress LaTeX/HTML header and trailer";
+  prerr_endline "  --no-index          do not output the index";
+  prerr_endline "  --multi-index       index split in multiple files";
+  prerr_endline "  --toc               output a table of contents";
+  prerr_endline "  --vernac <file>     consider <file> as a .v file";
+  prerr_endline "  --tex <file>        consider <file> as a .tex file";
+  prerr_endline "  -p <string>         insert <string> in LaTeX preamble";
+  prerr_endline "  --files-from <file> read file names to process in <file>";
+  prerr_endline "  --quiet             quiet mode";
+  prerr_endline "  --glob-from <file>  read Coq globalizations from file <file>";
+  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 "  -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
+    output, so that when the output of [coqdoc] is redirected this header
+    is not (unless both standard and error outputs are redirected, of 
+    course). *)
+
+let banner () =
+  eprintf "This is coqdoc version %s, compiled on %s\n"
+    Coq_config.version Coq_config.compile_date;
+  flush stderr
+    
+
+(*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\
+    files have suffix \verb!.tex!. *)
+
+let check_if_file_exists f =
+  if not (Sys.file_exists f) then begin
+    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
+
+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
+  in
+  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()?
+ *)
+  let f = chop_extension file in
+  (* 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;;
+
+let what_file f =
+  check_if_file_exists f;
+  if check_suffix f ".v" || check_suffix f ".g" then
+    Vernac_file (f, coq_module f)
+  else if check_suffix f ".tex" then
+    Latex_file f
+  else begin
+    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.
+ *)
+
+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
+  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
+
+(*s \textbf{Parsing of the command line.} *)
+
+let output_file = ref ""
+let dvi = ref false
+let ps = ref false
+
+let parse () =
+  let files = ref [] in
+  let add_file f = files := f :: !files in
+  let rec parse_rec = function
+    | [] -> ()
+
+    | ("-nopreamble" | "--nopreamble" | "--no-preamble"
+    |  "-bodyonly"   | "--bodyonly"   | "--body-only") :: rem ->
+	header_trailer := false; parse_rec rem
+    | ("-p" | "--preamble") :: s :: rem ->
+	push_in_preamble s; parse_rec rem
+    | ("-p" | "--preamble") :: [] ->
+	usage ()
+    | ("-noindex" | "--noindex" | "--no-index") :: rem ->
+	index := false; parse_rec rem
+    | ("-multi-index" | "--multi-index") :: rem ->
+	multi_index := true; parse_rec rem
+    | ("-toc" | "--toc" | "--table-of-contents") :: rem ->
+	toc := true; parse_rec rem
+    | ("-o" | "--output") :: f :: rem ->
+	output_file := f; parse_rec rem
+    | ("-o" | "--output") :: [] -> 
+	usage ()
+    | ("-d" | "--directory") :: dir :: rem ->
+	output_dir := dir; parse_rec rem
+    | ("-d" | "--directory") :: [] -> 
+	usage ()
+    | ("-s" | "--short") :: rem ->
+	short := true; parse_rec rem
+    | ("-l" | "-light" | "--light") :: rem ->
+	gallina := true; light := true; parse_rec rem
+    | ("-g" | "-gallina" | "--gallina") :: rem ->
+	gallina := true; parse_rec rem
+    | ("-t" | "-title" | "--title") :: s :: rem ->
+	title := s; parse_rec rem
+    | ("-t" | "-title" | "--title") :: [] ->
+	usage ()
+    | ("-latex" | "--latex") :: rem ->
+	Output.target_language := LaTeX; parse_rec rem
+    | ("-dvi" | "--dvi") :: rem ->
+	Output.target_language := LaTeX; dvi := true; parse_rec rem
+    | ("-ps" | "--ps") :: rem ->
+	Output.target_language := LaTeX; ps := true; parse_rec rem
+    | ("-html" | "--html") :: rem ->
+	Output.target_language := HTML; parse_rec rem
+    | ("-texmacs" | "--texmacs") :: rem ->
+	Output.target_language := TeXmacs; parse_rec rem
+
+    | ("-charset" | "--charset") :: s :: rem ->
+	Output.charset := s; parse_rec rem
+    | ("-charset" | "--charset") :: [] ->
+	usage ()
+    | ("-inputenc" | "--inputenc") :: s :: rem ->
+	Output.inputenc := s; parse_rec rem
+    | ("-inputenc" | "--inputenc") :: [] ->
+	usage ()
+    | ("-raw-comments" | "--raw-comments") :: rem ->
+	Output.raw_comments := true; parse_rec rem
+    | ("-latin1" | "--latin1") :: rem ->
+	Output.set_latin1 (); parse_rec rem
+    | ("-utf8" | "--utf8") :: rem ->
+	Output.set_utf8 (); parse_rec rem
+
+    | ("-q" | "-quiet" | "--quiet") :: rem ->
+	quiet := true; parse_rec rem
+
+    | ("-h" | "-help" | "-?" | "--help") :: rem ->
+	banner (); usage ()
+    | ("-v" | "-version" | "--version") :: _ ->
+	banner (); exit 0
+
+    | ("-vernac-file" | "--vernac-file") :: f :: rem -> 
+	check_if_file_exists f;
+	add_file (Vernac_file (f, coq_module f)); parse_rec rem
+    | ("-vernac-file" | "--vernac-file") :: [] ->
+	usage ()
+    | ("-tex-file" | "--tex-file") :: f :: rem -> 
+	add_file (Latex_file f); parse_rec rem
+    | ("-tex-file" | "--tex-file") :: [] ->
+	usage ()
+    | ("-files" | "--files" | "--files-from") :: f :: rem ->
+	List.iter (fun f -> add_file (what_file f)) (files_from_file f); 
+	parse_rec rem
+    | ("-files" | "--files") :: [] ->
+	usage ()
+
+    | "-R" :: path :: log :: rem -> 
+	add_path path log; parse_rec rem
+    | "-R" :: ([] | [_]) ->
+	usage ()
+    | ("-glob-from" | "--glob-from") :: f :: rem ->
+	Index.read_glob f; parse_rec rem
+    | ("-glob-from" | "--glob-from") :: [] ->
+	usage ()
+    | ("--no-externals" | "-no-externals" | "-noexternals") :: rem ->
+	Output.externals := false; parse_rec rem
+    | ("--coqlib" | "-coqlib") :: u :: rem ->
+	Output.coqlib := u; parse_rec rem
+    | ("--coqlib" | "-coqlib") :: [] ->
+	usage ()
+
+    | f :: rem -> 
+	add_file (what_file f); parse_rec rem
+  in 
+  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
+    we make calls to \verb!latex! or \verb!dvips!  accordingly. *)
+
+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
+
+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")
+
+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
+
+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
+
+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
+      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
+
+
+(*s \textbf{Main program.} Print the banner, parse the command line,
+    read the files and then call [produce_document] from module [Web]. *)
+
+let main () =
+  let files = parse () in
+  if not !quiet then banner ();
+  if List.length files > 0 then produce_output files
+
+let _ = Printexc.catch main ()
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
new file mode 100644
index 00000000..c10f3683
--- /dev/null
+++ b/tools/coqdoc/output.ml
@@ -0,0 +1,812 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: output.ml,v 1.7.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+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
+
+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 *)
+
+let build_table l = 
+  let h = Hashtbl.create 101 in
+  List.iter (fun key ->Hashtbl.add h  key ()) l;
+  function s -> try Hashtbl.find h s; true with Not_found -> false
+
+let is_keyword = 
+  build_table
+    [ "Add"; "AddPath"; "Axiom"; "Chapter"; "CoFixpoint";
+      "CoInductive"; "Defined"; "Definition"; 
+      "End"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Hint";
+      "Hypothesis"; "Hypotheses"; 
+      "Immediate"; "Implicit"; "Import"; "Inductive"; 
+      "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; 
+      "Module"; "Module Type"; "Declare Module";
+      "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Qed";
+      "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme";
+      "Section"; "Show"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; 
+      "Unset"; "Variable"; "Variables"; 
+      "Notation"; 
+      (*i (* correctness *)
+      "array"; "assert"; "begin"; "do"; "done"; "else"; "end"; "if";
+      "in"; "invariant"; "let"; "of"; "ref"; "state"; "then"; "variant";
+      "while"; i*)
+      (*i (* coq terms *)
+      "with"; "Case"; "Cases"; "Prop"; "Set"; "Type"; i*)
+       ]
+
+(*s Current Coq module *)
+
+let current_module = ref ""
+
+let set_module m = current_module := m; page_title := m
+
+(*s Common to both LaTeX and HTML *)
+
+let item_level = ref 0
+
+(*s Customized pretty-print *)
+
+let token_pp = Hashtbl.create 97
+
+let add_printing_token = Hashtbl.replace token_pp
+
+let find_printing_token tok = 
+  try Hashtbl.find token_pp tok with Not_found -> None, None
+
+let remove_printing_token = Hashtbl.remove token_pp
+
+(* predefined pretty-prints *)
+let _ = List.iter 
+	  (fun (s,l) -> Hashtbl.add token_pp s (Some l, None))
+	  [ "*" ,  "\\ensuremath{\\times}";
+	    "->",  "\\ensuremath{\\rightarrow}";
+	    "->~",  "\\ensuremath{\\rightarrow\\lnot}";
+	    "->~~",  "\\ensuremath{\\rightarrow\\lnot\\lnot}";
+	    "<-",  "\\ensuremath{\\leftarrow}";
+	    "<->", "\\ensuremath{\\leftrightarrow}";
+	    "=>",  "\\ensuremath{\\Rightarrow}";
+	    "<=",  "\\ensuremath{\\le}";
+	    ">=",  "\\ensuremath{\\ge}";
+	    "<>",  "\\ensuremath{\\not=}";
+	    "~",   "\\ensuremath{\\lnot}";
+	    "/\\", "\\ensuremath{\\land}";
+	    "\\/", "\\ensuremath{\\lor}";
+	    "|-",  "\\ensuremath{\\vdash}";
+	    "forall", "\\ensuremath{\\forall}";
+	    "exists", "\\ensuremath{\\exists}";
+	  ]
+
+(*s Table of contents *)
+
+type toc_entry = 
+  | Toc_library of string
+  | Toc_section of int * (unit -> unit) * string
+
+let (toc_q : toc_entry Queue.t) = Queue.create ()
+
+let add_toc_entry e = Queue.add e toc_q
+
+let new_label = let r = ref 0 in fun () -> incr r; "lab" ^ string_of_int !r
+
+(*s LaTeX output *)
+
+module Latex = struct
+
+  (*s Latex preamble *)
+
+  let (preamble : string Queue.t) = Queue.create ()
+
+  let push_in_preamble s = Queue.add s preamble
+
+  let header () =
+    if !header_trailer then begin
+      printf "\\documentclass[12pt]{article}\n";
+      if !inputenc != "" then printf "\\usepackage[%s]{inputenc}\n" !inputenc;
+      printf "\\usepackage[T1]{fontenc}\n";
+      printf "\\usepackage{fullpage}\n";
+      printf "\\usepackage{coqdoc}\n";
+      Queue.iter (fun s -> printf "%s\n" s) preamble;
+      printf "\\begin{document}\n"
+    end;
+    output_string 
+      "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n";
+    output_string
+      "%% This file has been automatically generated with the command\n";
+    output_string "%% ";
+    Array.iter (fun s -> printf "%s " s) Sys.argv;
+    printf "\n";
+    output_string
+      "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"
+
+  let trailer () =
+    if !header_trailer then begin
+      printf "\\end{document}\n"
+    end
+
+  let char c = match c with
+    | '\\' -> 
+	printf "\\symbol{92}"
+    | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> 
+	output_char '\\'; output_char c
+    | '^' | '~' -> 
+	output_char '\\'; output_char c; printf "{}"
+    | _ -> 
+	output_char c
+
+  let latex_char = output_char
+  let latex_string = output_string
+
+  let html_char _ = ()
+  let html_string _ = ()
+
+  let raw_ident s =
+    for i = 0 to String.length s - 1 do char s.[i] done
+
+  let start_module () = 
+    if not !short then begin
+      printf "\\coqdocmodule{"; 
+      raw_ident !current_module; 
+      printf "}\n\n"
+    end
+
+  let start_latex_math () = output_char '$'
+
+  let stop_latex_math () = output_char '$'
+
+  let start_verbatim () = printf "\\begin{verbatim}"
+
+  let stop_verbatim () = printf "\\end{verbatim}\n"
+
+  let indentation n = 
+    if n == 0 then 
+      printf "\\noindent\n"
+    else
+      let space = 0.5 *. (float n) in
+      printf "\\coqdocindent{%2.2fem}\n" space
+
+  let with_latex_printing f tok =
+    try 
+      (match Hashtbl.find token_pp tok with
+	 | Some s, _ -> output_string s
+	 | _ -> f tok)
+    with Not_found -> 
+      f tok
+
+  let ident s _ = 
+    if is_keyword s then begin
+      printf "\\coqdockw{"; raw_ident s; printf "}"
+    end else begin
+      printf "\\coqdocid{"; raw_ident s; printf "}"
+    end
+
+  let ident s l = with_latex_printing (fun s -> ident s l) s
+
+  let symbol = with_latex_printing raw_ident
+
+  let rec reach_item_level n = 
+    if !item_level < n then begin
+      printf "\n\\begin{itemize}\n\\item "; incr item_level;
+      reach_item_level n
+    end else if !item_level > n then begin
+      printf "\n\\end{itemize}\n"; decr item_level;
+      reach_item_level n
+    end
+
+  let item n =
+    let old_level = !item_level in
+    reach_item_level n;
+    if n <= old_level then printf "\n\\item "
+
+  let stop_item () = reach_item_level 0
+
+  let start_doc () = printf "\n\n\n\\noindent\n"
+
+  let end_doc () = stop_item (); printf "\n\n\n"
+
+  let start_coq () = ()
+
+  let end_coq () = ()
+
+  let start_code () = end_doc (); start_coq ()
+
+  let end_code () = end_coq (); start_doc ()
+
+  let section_kind = function
+    | 1 -> "\\section{"
+    | 2 -> "\\subsection{"
+    | 3 -> "\\subsubsection{"
+    | 4 -> "\\paragraph{"
+    | _ -> assert false
+
+  let section lev f =
+    stop_item ();
+    output_string (section_kind lev);
+    f ();
+    printf "}\n\n"
+
+  let rule () =
+    printf "\\par\n\\noindent\\hrulefill\\par\n\\noindent{}"
+
+  let paragraph () = stop_item (); printf "\n\n\\medskip\n"
+
+  let line_break () = printf "\\coqdoceol\n"
+
+  let empty_line_of_code () = printf "\n\n\\medskip\n"
+
+  let start_inline_coq () = ()
+
+  let end_inline_coq () = ()
+
+  let make_index () = ()
+
+  let make_toc () = printf "\\tableofcontents\n"
+
+end
+
+
+(*s HTML output *)
+
+module Html = struct
+
+  let header () =
+    if !header_trailer then begin
+      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 "<title>%s</title>\n</head>\n\n" !page_title;
+      printf "<body>\n\n"
+    end
+
+  let self = "http://www.lri.fr/~filliatr/coqdoc/"
+
+  let trailer () =
+    if !index && !current_module <> "Index" then 
+      printf "<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>"
+    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
+    end
+
+  let indentation n = for i = 1 to n do printf "&nbsp;" done
+
+  let line_break () = printf "<br/>\n"
+
+  let empty_line_of_code () = printf "\n<br/>\n"
+
+  let char = function
+    | '<' -> printf "&lt;"
+    | '>' -> printf "&gt;"
+    | '&' -> printf "&amp;"
+    | c -> output_char c
+
+  let raw_ident s = for i = 0 to String.length s - 1 do char s.[i] done
+
+  let latex_char _ = ()
+  let latex_string _ = ()
+
+  let html_char = output_char
+  let html_string = output_string
+
+  let start_latex_math () = ()
+  let stop_latex_math () = ()
+
+  let start_verbatim () = printf "<pre>"
+  let stop_verbatim () = printf "</pre>\n"
+
+  let module_ref m s = 
+    printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
+    (*i
+    match find_module m with
+    | Local ->
+	printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
+    | Coqlib when !externals ->
+	let m = Filename.concat !coqlib m in
+	printf "<a href=\"%s.html\">" m; raw_ident s; printf "</a>"
+    | Coqlib | Unknown ->
+	raw_ident s
+    i*)
+
+  let ident_ref m s = match find_module m with
+    | Local ->
+	printf "<a href=\"%s.html#%s\">" m s; 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>"
+    | Coqlib | Unknown ->
+	raw_ident s
+
+  let ident s loc = 
+    if is_keyword s then begin
+      printf "<code class=\"keyword\">"; 
+      raw_ident s; 
+      printf "</code>"
+    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
+	  
+  let with_html_printing f tok =
+    try 
+      (match Hashtbl.find token_pp tok with
+	 | _, Some s -> output_string s
+	 | _ -> f tok)
+    with Not_found -> 
+      f tok
+
+  let ident s l = with_html_printing (fun s -> ident s l) s
+
+  let symbol = with_html_printing raw_ident
+
+  let rec reach_item_level n = 
+    if !item_level < n then begin
+      printf "\n<ul>\n<li>"; incr item_level;
+      reach_item_level n
+    end else if !item_level > n then begin
+      printf "\n</li>\n</ul>\n"; decr item_level;
+      reach_item_level n
+    end
+
+  let item n =
+    let old_level = !item_level in
+    reach_item_level n;
+    if n <= old_level then printf "\n</li>\n<li>"
+
+  let stop_item () = reach_item_level 0
+
+  let start_coq () = if not !raw_comments then printf "<code>\n"
+
+  let end_coq () = if not !raw_comments then printf "</code>\n"
+
+  let start_doc () = 
+    if not !raw_comments then
+      printf "\n<table width=\"100%%\"><tr class=\"doc\"><td>\n"
+
+  let end_doc () =
+    stop_item (); 
+    if not !raw_comments then printf "\n</td></tr></table>\n"
+
+  let start_code () = end_doc (); start_coq ()
+
+  let end_code () = end_coq (); start_doc ()
+
+  let start_inline_coq () = printf "<code>"
+
+  let end_inline_coq () = printf "</code>"
+
+  let paragraph () = stop_item (); printf "\n<br/><br/>\n"
+
+  let section lev f =
+    let lab = new_label () in
+    let r = sprintf "%s.html#%s" !current_module lab in
+    add_toc_entry (Toc_section (lev, f, r));
+    stop_item ();
+    printf "<a name=\"%s\"></a><h%d>" lab lev;
+    f ();
+    printf "</h%d>\n" lev
+
+  let rule () = printf "<hr/>\n"
+
+  let entry_type = function
+    | Library -> "library"
+    | Module -> "module"
+    | Definition -> "definition"
+    | Inductive -> "inductive"
+    | Constructor -> "constructor"
+    | Lemma -> "lemma"
+    | Variable -> "variable"
+    | Axiom -> "axiom"
+    | TacticDefinition -> "tactic definition"
+
+  (* make a HTML index from a list of triples (name,text,link) *)
+  let index_ref i c =
+    let idxc = sprintf "%s_%c" i.idx_name c in
+    if !multi_index then "index_" ^ idxc ^ ".html" else "index.html#" ^ idxc
+
+  let letter_index category idx (c,l) =
+    if l <> [] then begin
+      let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in
+      printf "<a name=\"%s_%c\"></a><h2>%c %s</h2>\n" idx c c cat;
+      List.iter 
+	(fun (id,(text,link)) -> 
+	   printf "<a href=\"%s\">%s</a> %s<br/>\n" link id text) l;
+      printf "<br/><br/>"
+    end
+		
+  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
+
+  let format_global_index =
+    Index.map 
+      (fun s (m,t) -> 
+	 if t = Library then 
+	   "[library]", m ^ ".html"
+	 else
+	   sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (entry_type t) m m ,
+	   sprintf "%s.html#%s" m s)
+
+  let format_bytype_index = function
+    | Library, idx ->
+	Index.map (fun id m -> "", m ^ ".html") idx
+    | (t,idx) ->
+	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
+
+  let navig_one_index i =
+    printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name);
+    List.iter 
+      (fun (c,l) -> 
+	 if l <> [] then
+	   printf "<td><a href=\"%s\">%c</a></td>\n" (index_ref i c) c
+	 else
+	   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"
+
+  let navig_index il = 
+    printf "<table>\n";
+    List.iter navig_one_index il;
+    printf "</table>\n"
+
+  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";
+      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
+
+  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 ();
+	  printf "<a href=\"%s.html\"><h2>Library %s</h2></a>\n" m m
+      | Toc_section (n, f, r) ->
+	  item n; 
+	  printf "<a href=\"%s\">" r; f (); printf "</a>\n"
+    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
+
+
+(*s TeXmacs-aware output *)
+
+module TeXmacs = struct
+
+  (*s Latex preamble *)
+
+  let in_doc = ref false
+
+  let (preamble : string Queue.t) = 
+    in_doc := false; Queue.create ()
+
+  let push_in_preamble s = Queue.add s preamble
+
+  let header () =
+    output_string 
+      "(*i This file has been automatically generated with the command  \n";
+    output_string 
+      "    "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n"
+
+  let trailer () = ()
+
+  let char_true c = match c with
+    | '\\' -> printf "\\\\"
+    | '<' -> printf "\\<"
+    | '|' -> printf "\\|"
+    | '>' -> printf "\\>"
+    | _ -> output_char c
+
+  let char c = if !in_doc then char_true c else output_char c
+
+  let latex_char = char_true
+  let latex_string = String.iter latex_char
+
+  let html_char _ = ()
+  let html_string _ = ()
+
+  let raw_ident s =
+    for i = 0 to String.length s - 1 do char s.[i] done
+
+  let start_module () = ()
+
+  let start_latex_math () = printf "<with|mode|math|"
+
+  let stop_latex_math () = output_char '>'
+
+  let start_verbatim () = in_doc := true; printf "<\\verbatim>"
+
+  let stop_verbatim () = in_doc := false; printf "</verbatim>"
+
+  let indentation n = ()
+
+  let ident_true s = 
+    if is_keyword s then begin
+      printf "<kw|"; raw_ident s; printf ">"
+    end else begin
+      raw_ident s
+    end
+
+  let ident s _ = if !in_doc then ident_true s else raw_ident s
+ 
+  let symbol_true s = 
+    let ensuremath x = printf "<with|mode|math|\\<%s\\>>" x in
+      match s with
+	| "*"  -> ensuremath "times"
+	| "->" -> ensuremath "rightarrow"
+	| "<-" -> ensuremath "leftarrow"
+	| "<->" ->ensuremath "leftrightarrow"
+	| "=>" -> ensuremath "Rightarrow"
+	| "<=" -> ensuremath "le"
+	| ">=" -> ensuremath "ge"
+	| "<>" -> ensuremath "noteq"
+	| "~" ->  ensuremath "lnot"
+	| "/\\" -> ensuremath "land"
+	| "\\/" -> ensuremath "lor"
+	| "|-" -> ensuremath "vdash"
+	| s    -> raw_ident s
+
+  let symbol s = if !in_doc then symbol_true s else raw_ident s
+
+  let rec reach_item_level n = 
+    if !item_level < n then begin
+      printf "\n<\\itemize>\n<item>"; incr item_level;
+      reach_item_level n
+    end else if !item_level > n then begin
+      printf "\n</itemize>"; decr item_level;
+      reach_item_level n
+    end
+
+  let item n =
+    let old_level = !item_level in
+    reach_item_level n;
+    if n <= old_level then printf "\n\n<item>"
+
+  let stop_item () = reach_item_level 0
+
+  let start_doc () = in_doc := true; printf "(** texmacs: "
+
+  let end_doc () = stop_item (); in_doc := false; printf " *)"
+
+  let start_coq () = ()
+
+  let end_coq () = ()
+
+  let start_code () = in_doc := true; printf "<\\code>\n"
+  let end_code () = in_doc := false; printf "\n</code>"
+
+  let section_kind = function
+    | 1 -> "section"
+    | 2 -> "subsection"
+    | 3 -> "subsubsection"
+    | 4 -> "paragraph"
+    | _ -> assert false
+
+  let section lev f =
+    stop_item ();
+    printf "<"; output_string (section_kind lev); printf "|"; 
+    f (); printf ">\n\n"
+
+  let rule () =
+    printf "\n<hrule>\n"
+
+  let paragraph () = stop_item (); printf "\n\n"
+
+  let line_break_true () = printf "<format|line break>"
+
+  let line_break () = printf "\n"
+
+  let empty_line_of_code () = printf "\n"
+
+  let start_inline_coq () = printf "<verbatim|["
+
+  let end_inline_coq () = printf "]>"
+
+  let make_index () = ()
+
+  let make_toc () = ()
+
+end
+
+(*s Generic output *)
+
+let select f1 f2 f3 x = 
+  match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x
+
+let push_in_preamble = Latex.push_in_preamble
+
+let header = select Latex.header Html.header TeXmacs.header
+let trailer = select Latex.trailer Html.trailer TeXmacs.trailer
+
+let start_module = 
+  select Latex.start_module Html.start_module TeXmacs.start_module
+
+let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc
+let end_doc = select Latex.end_doc Html.end_doc TeXmacs.end_doc
+
+let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq
+let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq
+
+let start_code = select Latex.start_code Html.start_code TeXmacs.start_code
+let end_code = select Latex.end_code Html.end_code TeXmacs.end_code
+
+let start_inline_coq = 
+  select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq
+let end_inline_coq = 
+  select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq
+
+let indentation = select Latex.indentation Html.indentation TeXmacs.indentation
+let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph
+let line_break = select Latex.line_break Html.line_break TeXmacs.line_break
+let empty_line_of_code = select 
+  Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code
+
+let section = select Latex.section Html.section TeXmacs.section
+let item = select Latex.item Html.item TeXmacs.item
+let stop_item = select Latex.stop_item Html.stop_item TeXmacs.stop_item
+let rule = select Latex.rule Html.rule TeXmacs.rule
+
+let char = select Latex.char Html.char TeXmacs.char
+let ident = select Latex.ident Html.ident TeXmacs.ident
+let symbol = select Latex.symbol Html.symbol TeXmacs.symbol
+
+let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char
+let latex_string = 
+  select Latex.latex_string Html.latex_string TeXmacs.latex_string
+let html_char = select Latex.html_char Html.html_char TeXmacs.html_char
+let html_string = 
+  select Latex.html_string Html.html_string TeXmacs.html_string
+
+let start_latex_math = 
+  select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math
+let stop_latex_math = 
+  select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math
+
+let start_verbatim = 
+  select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim
+let stop_verbatim = 
+  select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim
+let verbatim_char = 
+  select output_char Html.char TeXmacs.char
+let hard_verbatim_char = output_char
+
+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
new file mode 100644
index 00000000..2195fa53
--- /dev/null
+++ b/tools/coqdoc/output.mli
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: output.mli,v 1.3.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+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
+
+val set_module : coq_module -> unit
+
+val header : unit -> unit
+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
+val end_doc : unit -> unit
+
+val start_coq : unit -> unit
+val end_coq : unit -> unit
+
+val start_code : unit -> unit
+val end_code : unit -> unit
+
+val start_inline_coq : unit -> unit
+val end_inline_coq : unit -> unit
+
+val indentation : int -> unit
+val line_break : unit -> unit
+val paragraph : unit -> unit
+val empty_line_of_code : unit -> unit
+
+val section : int -> (unit -> unit) -> unit
+
+val item : int -> unit
+
+val rule : unit -> unit
+
+val char : char -> unit
+val ident : string -> loc -> unit
+val symbol : string -> unit
+
+val latex_char : char -> unit
+val latex_string : string -> unit
+val html_char : char -> unit
+val html_string : string -> unit
+val verbatim_char : char -> unit
+val hard_verbatim_char : char -> unit
+
+val start_latex_math : unit -> unit
+val stop_latex_math : unit -> unit
+val start_verbatim : unit -> unit
+val stop_verbatim : unit -> unit
+
+val make_index : unit -> unit
+val make_toc : unit -> unit
diff --git a/tools/coqdoc/pretty.mli b/tools/coqdoc/pretty.mli
new file mode 100644
index 00000000..07808fe9
--- /dev/null
+++ b/tools/coqdoc/pretty.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: pretty.mli,v 1.1.2.1 2004/07/16 19:31:47 herbelin Exp $ 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
diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll
new file mode 100644
index 00000000..541939b5
--- /dev/null
+++ b/tools/coqdoc/pretty.mll
@@ -0,0 +1,586 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: pretty.mll,v 1.7.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*s Utility functions for the scanners *)
+
+{
+
+  open Printf
+  open Index
+  open Lexing 
+  open Output
+
+  (* count the number of spaces at the beginning of a string *)
+  let count_spaces s =
+    let n = String.length s in
+    let rec count c i = 
+      if i == n then c else match s.[i] with
+	| '\t' -> count (c + (8 - (c mod 8))) (i + 1)
+	| ' ' -> count (c + 1) (i + 1)
+	| _ -> c
+    in
+    count 0 0
+
+  let count_dashes s =
+    let c = ref 0 in
+    for i = 0 to String.length s - 1 do if s.[i] = '-' then incr c done;
+    !c
+
+  let cut_head_tail_spaces s =
+    let n = String.length s in
+    let rec look_up i = if i == n || s.[i] <> ' ' then i else look_up (i+1) in
+    let rec look_dn i = if i == -1 || s.[i] <> ' ' then i else look_dn (i-1) in
+    let l = look_up 0 in
+    let r = look_dn (n-1) in
+    if l <= r then String.sub s l (r-l+1) else s
+
+  let sec_title s =
+    let rec count lev i = 
+      if s.[i] = '*' then 
+	count (succ lev) (succ i) 
+      else 
+	let t = String.sub s i (String.length s - i) in
+	lev, cut_head_tail_spaces t
+    in
+    count 0 (String.index s '*')
+
+  let formatted = ref false
+  let brackets = ref 0
+
+  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 = {
+    st_gallina : bool;
+    st_light : bool
+  }
+
+  let state_stack = Stack.create ()
+
+  let save_state () = 
+    Stack.push { st_gallina = !gallina; st_light = !light } state_stack
+
+  let restore_state () =
+    let s = Stack.pop state_stack in
+    gallina := s.st_gallina;
+    light := s.st_light
+      
+  let without_ref r f x = save_state (); r := false; f x; restore_state ()
+
+  let without_gallina = without_ref gallina
+
+  let without_light = without_ref light
+
+  let show_all f = without_gallina (without_light f)
+
+  let begin_show () = save_state (); gallina := false; light := false
+  let end_show () = restore_state ()
+
+  (* Reset the globals *)
+
+  let reset () =
+    formatted := false;
+    brackets := 0;
+    gstate := AfterDot
+
+  (* erasing of Section/End *)
+
+  let section_re = Str.regexp "[ \t]*Section"
+  let end_re = Str.regexp "[ \t]*End"
+  let is_section s = Str.string_match section_re s 0
+  let is_end s = Str.string_match end_re s 0
+
+  let sections_to_close = ref 0
+
+  let section_or_end s =
+    if is_section s then begin
+      incr sections_to_close; true
+    end else if is_end s then begin
+      if !sections_to_close > 0 then begin 
+	decr sections_to_close; true 
+      end else 
+	false
+    end else
+      true
+
+  (* tokens pretty-print *)
+
+  let token_buffer = Buffer.create 1024
+
+  let token_re = 
+    Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)"
+  let printing_token_re =
+    Str.regexp
+      "[ \t]*\\(\\(%\\([^%]*\\)%\\)\\|\\(\\$[^$]*\\$\\)\\)?[ \t]*\\(#\\(\\([^#]\\|&#\\)*\\)#\\)?"
+
+  let add_printing_token toks pps =
+    try
+      if Str.string_match token_re toks 0 then
+	let tok = Str.matched_group 1 toks in
+	if Str.string_match printing_token_re pps 0 then
+	  let pp = 
+	    (try Some (Str.matched_group 3 pps) with _ -> 
+             try Some (Str.matched_group 4 pps) with _ -> None),
+	    (try Some (Str.matched_group 6 pps) with _ -> None)
+	  in
+	  Output.add_printing_token tok pp
+    with _ ->
+      ()
+
+  let remove_token_re = 
+    Str.regexp 
+      "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)"
+
+  let remove_printing_token toks =
+    try
+      if Str.string_match remove_token_re toks 0 then
+	let tok = Str.matched_group 1 toks in
+	Output.remove_printing_token tok
+    with _ ->
+      ()
+
+  let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:="
+  let extract_ident s =
+    assert (String.length s >= 3);
+    if Str.string_match extract_ident_re s 0 then
+      Str.matched_group 1 s
+    else
+      String.sub s 1 (String.length s - 3)
+
+}
+
+(*s Regular expressions *)
+
+let space = [' ' '\t']
+let space_nl = [' ' '\t' '\n' '\r']
+
+let firstchar = 
+  ['A'-'Z' 'a'-'z' '_' 
+  (* iso 8859-1 accents *) 
+  '\192'-'\214' '\216'-'\246' '\248'-'\255' ] |
+  (* utf-8 latin 1 supplement *) 
+  '\195' ['\128'-'\191'] |
+  (* utf-8 letterlike symbols *) 
+  '\226' ('\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
+let identchar = 
+  firstchar | ['\'' '0'-'9' '@']
+let identifier = firstchar identchar*
+
+let symbolchar_no_brackets =
+  ['!' '$' '%' '&' '*' '+' ',' '@' '^' '#'
+   '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~'
+   '{' '}' '(' ')'] |
+  (* utf-8 symbols *) 
+  '\226' ['\134'-'\143' '\152'-'\155' '\164'-'\165' '\168'-'\171'] _
+let symbolchar = symbolchar_no_brackets | '[' | ']'
+let token = symbolchar+ | '[' [^ '[' ']' ':']* ']'
+
+(* tokens with balanced brackets *)
+let token_brackets =
+  ( symbolchar_no_brackets+ ('[' symbolchar_no_brackets* ']')* 
+  | symbolchar_no_brackets* ('[' symbolchar_no_brackets* ']')+ )
+  symbolchar_no_brackets*
+
+let section = "*" | "**" | "***" | "****"
+
+let item_space = "    "
+
+let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* '\n'
+let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* '\n'
+let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* '\n'
+let end_show = "(*" space* "end" space+ "show" space* "*)" space* '\n'
+(*
+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'+
+      { 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 }
+  | space* "Comments" space_nl
+      { end_coq (); start_doc (); comments lexbuf; end_doc (); 
+	start_coq (); coq lexbuf }
+  | space* begin_hide
+      { skip_hide lexbuf; coq_bol lexbuf }
+  | space* begin_show
+      { begin_show (); coq_bol lexbuf }
+  | space* end_show
+      { end_show (); coq_bol lexbuf }
+  | space* coq_command_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 }
+  | 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 }
+  | 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* "*)"
+      { remove_printing_token (lexeme lexbuf);
+	coq_bol lexbuf }
+  | space* "(**" space+ "remove" space+ "printing" space+
+      { eprintf "warning: bad 'remove printing' command at character %d\n" 
+	  (lexeme_start lexbuf); flush stderr;
+	ignore (comment lexbuf);
+	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 }
+  | eof 
+      { () }
+  | _ 
+      { backtrack lexbuf; indentation 0; coq lexbuf }
+
+(*s Scanning Coq elsewhere *)
+
+and coq = parse
+  | "\n" 
+      { 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 }
+  | "(*"
+      { let eol = comment lexbuf in
+	if eol then coq_bol lexbuf else coq lexbuf }
+  | '\n'+ space* "]]"
+      { if not !formatted then begin symbol (lexeme lexbuf); coq lexbuf end }
+  | eof 
+      { () }
+  | token
+      { 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 }
+
+(*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*
+      { start_verbatim (); verbatim lexbuf; doc_bol lexbuf }
+  | eof 
+      { false }
+  | _ 
+      { backtrack lexbuf; doc lexbuf }
+
+(*s Scanning documentation elsewhere *)
+
+and doc = parse
+  | "\n"
+      { char '\n'; doc_bol lexbuf }
+  | "["
+      { brackets := 1; 
+	start_inline_coq (); escaped_coq lexbuf; end_inline_coq ();
+	doc lexbuf }
+  | "[[" '\n' space*
+      { formatted := true; start_code ();
+	indentation (count_spaces (lexeme lexbuf)); 
+	without_gallina coq lexbuf; 
+	end_code (); formatted := false;
+	doc lexbuf }
+  | '*'* "*)" space* '\n'
+      { true }
+  | '*'* "*)"
+      { false }
+  | "$"
+      { start_latex_math (); escaped_math_latex lexbuf; doc lexbuf }
+  | "$$"
+      { char '$'; doc lexbuf }
+  | "%"
+      { escaped_latex lexbuf; doc lexbuf }
+  | "%%"
+      { char '%'; doc lexbuf }
+  | "#"
+      { escaped_html lexbuf; doc lexbuf }
+  | "##"
+      { char '#'; doc lexbuf }
+  | eof 
+      { false }
+  | _ 
+      { char (lexeme_char lexbuf 0); doc lexbuf }
+
+(*s Various escapings *)
+
+and escaped_math_latex = parse
+  | "$" { stop_latex_math () }
+  | eof { stop_latex_math () }
+  | _   { latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf }
+
+and escaped_latex = parse
+  | "%" { () }
+  | eof { () }
+  | _   { latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf }
+
+and escaped_html = parse
+  | "#" { () }
+  | "&#"
+        { html_char '&'; html_char '#'; escaped_html lexbuf }
+  | "##"
+        { html_char '#'; escaped_html lexbuf }
+  | eof { () }
+  | _   { html_char (lexeme_char lexbuf 0); escaped_html lexbuf }
+
+and verbatim = parse
+  | "\n>>" { verbatim_char '\n'; stop_verbatim () }
+  | eof { stop_verbatim () }
+  | _ { verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf }
+
+(*s Coq, inside quotations *)
+
+and escaped_coq = parse
+  | "]"
+      { decr brackets; 
+	if !brackets > 0 then begin char ']'; escaped_coq lexbuf end }
+  | "["
+      { incr brackets; char '['; escaped_coq lexbuf }
+  | "(*"
+      { ignore (comment lexbuf); escaped_coq lexbuf }
+  | "*)"
+      { (* likely to be a syntax error: we escape *) backtrack lexbuf }
+  | eof
+      { () }
+  | token_brackets
+      { let s = lexeme lexbuf in
+	symbol s;
+	escaped_coq lexbuf }
+  | (identifier '.')* identifier
+      { ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf }
+  | _ 
+      { char (lexeme_char lexbuf 0); escaped_coq lexbuf }
+
+(*s Coq "Comments" command. *)
+
+and comments = parse
+  | space_nl+ 
+      { char ' '; comments lexbuf }
+  | '"' [^ '"']* '"' 
+      { let s = lexeme lexbuf in
+	let s = String.sub s 1 (String.length s - 2) in
+	ignore (doc (from_string s)); comments lexbuf }
+  | ([^ '.' '"'] | '.' [^ ' ' '\t' '\n'])+
+      { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf }
+  | "." (space_nl | eof)
+      { () }
+  | eof 
+      { () }
+  | _   
+      { char (lexeme_char lexbuf 0); comments lexbuf }
+
+(*s Skip comments *)
+
+and comment = parse
+  | "(*" { ignore (comment lexbuf); comment lexbuf }
+  | "*)" space* '\n'+ { true }
+  | "*)" { false }
+  | 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 }
+  | "(*" { ignore (comment lexbuf); skip_to_dot lexbuf }
+  | _ { skip_to_dot lexbuf }
+
+and skip_hide = parse
+  | eof | end_hide { () }
+  | _ { skip_hide lexbuf }
+
+(*s Reading token pretty-print *)
+
+and printing_token = parse
+  | "*)" | eof 
+	{ let s = Buffer.contents token_buffer in 
+	  Buffer.clear token_buffer;
+	  s }
+  | _   { Buffer.add_string token_buffer (lexeme lexbuf); 
+	  printing_token lexbuf }
+
+(*s Applying the scanners to files *)
+
+{
+
+  type file =
+    | Vernac_file of string * coq_module
+    | Latex_file of string
+
+  let coq_file f m =
+    reset ();
+    Index.scan_file f m;
+    start_module ();
+    let c = open_in f in
+    let lb = from_channel c in
+    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/coqdoc/style.css b/tools/coqdoc/style.css
new file mode 100644
index 00000000..5150bd75
--- /dev/null
+++ b/tools/coqdoc/style.css
@@ -0,0 +1,23 @@
+a:visited {color : #416DFF; text-decoration : none; }
+a:link {color : #416DFF; text-decoration : none; font-weight : bold}
+a:hover {color : Red; text-decoration : underline; }
+a:active {color : Red; text-decoration : underline; }
+.keyword { font-weight : bold ; color : Red }
+.keywordsign { color : #C04600 }
+.superscript { font-size : 4 }
+.subscript { font-size : 4 }
+.comment { color : Green }
+.constructor { color : Blue }
+.string { color : Maroon }
+.warning { color : Red ; font-weight : bold }
+.info { margin-left : 3em; margin-right : 3em }
+.title1 { font-size : 20pt ; background-color : #416DFF }
+.title2 { font-size : 20pt ; background-color : #418DFF }
+.title3 { font-size : 20pt ; background-color : #41ADFF }
+.title4 { font-size : 20pt ; background-color : #41CDFF }
+.title5 { font-size : 20pt ; background-color : #41EDFF }
+.title6 { font-size : 20pt ; background-color : #41FFFF }
+body { background-color : White }
+tr { background-color : White }
+# .doc { background-color :#aaeeff  }
+.doc { background-color :#66ff66  }
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
new file mode 100644
index 00000000..08bf2bcc
--- /dev/null
+++ b/tools/coqwc.mll
@@ -0,0 +1,293 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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*)
+
+(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. 
+    It assumes the files to be lexically well-formed. *)
+
+(*i*){ 
+open Printf
+open Lexing
+open Filename
+(*i*)
+
+(*s Command-line options. *)
+
+let spec_only = ref false
+let proof_only = ref false
+let percentage = ref false
+let skip_header = ref true
+
+(*s Counters. [clines] counts the number of code lines of the current
+    file, and [dlines] the number of comment lines. [tclines] and [tdlines]
+    are the corresponding totals. *)
+
+let slines = ref 0
+let plines = ref 0
+let dlines = ref 0
+
+let tslines = ref 0
+let tplines = ref 0
+let tdlines = ref 0
+
+let update_totals () =
+  tslines := !tslines + !slines; 
+  tplines := !tplines + !plines; 
+  tdlines := !tdlines + !dlines
+
+(*s The following booleans indicate whether we have seen spec, proof or
+    comment so far on the current line; when a newline is reached, [newline]
+    is called and updates the counters accordingly. *)
+
+let seen_spec = ref false
+let seen_proof = ref false
+let seen_comment = ref false
+
+let newline () =
+  if !seen_spec then incr slines; 
+  if !seen_proof then incr plines; 
+  if !seen_comment then incr dlines; 
+  seen_spec := false; seen_proof := false; seen_comment := false
+
+let reset_counters () = 
+  seen_spec := false; seen_proof := false; seen_comment := false;
+  slines := 0; plines := 0; dlines := 0
+
+(*s Print results. *)
+
+let print_line sl pl dl fo =
+  if not !proof_only then printf " %8d" sl;
+  if not !spec_only then printf " %8d" pl;
+  if not (!proof_only || !spec_only) then printf " %8d" dl;
+  (match fo with Some f -> printf " %s" f | _ -> ());
+  if !percentage then begin
+    let s = sl + pl + dl in
+    let p = if s > 0 then 100 * dl / s else 0 in
+    printf " (%d%%)" p
+  end;
+  print_newline ()
+
+let print_file fo = print_line !slines !plines !dlines fo
+
+let print_totals () = print_line !tslines !tplines !tdlines (Some "total")
+
+(*i*)}(*i*)
+
+(*s Shortcuts for regular expressions. The [rcs] regular expression
+    is used to skip the CVS infos possibly contained in some comments, 
+    in order not to consider it as documentation. *)
+
+let space = [' ' '\t' '\r']
+let character =
+  "'" ([^ '\\' '\''] |
+       '\\' (['\\' '\'' 'n' 't' 'b' 'r'] | ['0'-'9'] ['0'-'9'] ['0'-'9'])) "'"
+let rcs_keyword =
+  "Author" | "Date" | "Header" | "Id" | "Name" | "Locker" | "Log" |
+  "RCSfile" | "Revision" | "Source" | "State"
+let rcs = "\036" rcs_keyword [^ '$']* "\036"
+let stars = "(*" '*'* "*)"
+let dot = '.' (' ' | '\t' | '\n' | '\r' | eof)
+let proof_start =   
+  "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness"
+let proof_end =
+  ("Save" | "Qed" | "Defined" | "Abort") [^'.']* '.'
+
+(*s [spec] scans the specification. *)
+
+rule spec = parse
+  | "(*"   { comment lexbuf; spec lexbuf }
+  | '"'    { let n = string lexbuf in slines := !slines + n; 
+	     seen_spec := true; spec lexbuf }
+  | '\n'   { newline (); spec lexbuf }
+  | space+ | stars 
+           { spec lexbuf }
+  | proof_start space
+           { seen_spec := true; spec_to_dot lexbuf; proof lexbuf }
+  | proof_start '\n'
+           { seen_spec := true; newline (); spec_to_dot lexbuf; proof lexbuf }
+  | "Definition" space
+           { seen_spec := true; definition lexbuf }
+  | character | _ 
+	   { seen_spec := true; spec lexbuf }
+  | eof    { () }
+
+(*s [spec_to_dot] scans a spec until a dot is reached and returns. *)
+
+and spec_to_dot = parse
+  | "(*"   { comment lexbuf; spec_to_dot lexbuf }
+  | '"'    { let n = string lexbuf in slines := !slines + n; 
+	     seen_spec := true; spec_to_dot lexbuf }
+  | '\n'   { newline (); spec_to_dot lexbuf }
+  | dot    { () }
+  | space+ | stars 
+           { spec_to_dot lexbuf }
+  | character | _ 
+	   { seen_spec := true; spec_to_dot lexbuf }
+  | eof    { () }
+
+(*s [definition] scans a definition; passes to [proof] is the body is 
+    absent, and to [spec] otherwise *)
+
+and definition = parse
+  | "(*"   { comment lexbuf; definition lexbuf }
+  | '"'    { let n = string lexbuf in slines := !slines + n; 
+	     seen_spec := true; definition lexbuf }
+  | '\n'   { newline (); definition lexbuf }
+  | ":="   { seen_spec := true; spec lexbuf }
+  | dot    { proof lexbuf }
+  | space+ | stars 
+           { definition lexbuf }
+  | character | _ 
+	   { seen_spec := true; definition lexbuf }
+  | eof    { () }
+
+(*s Scans a proof, then returns to [spec]. *)
+
+and proof = parse
+  | "(*"   { comment lexbuf; proof lexbuf }
+  | '"'    { let n = string lexbuf in plines := !plines + n; 
+	     seen_proof := true; proof lexbuf }
+  | space+ | stars 
+           { proof lexbuf }
+  | '\n'   { newline (); proof lexbuf }
+  | "Proof" space* '.' 
+           { seen_proof := true; proof lexbuf }
+  | "Proof" space
+           { proof_term lexbuf }
+  | proof_end
+           { seen_proof := true; spec lexbuf }
+  | character | _ 
+	   { seen_proof := true; proof lexbuf }
+  | eof    { () }
+
+and proof_term = parse
+  | "(*"   { comment lexbuf; proof_term lexbuf }
+  | '"'    { let n = string lexbuf in plines := !plines + n; 
+	     seen_proof := true; proof_term lexbuf }
+  | space+ | stars 
+           { proof_term lexbuf }
+  | '\n'   { newline (); proof_term lexbuf }
+  | dot    { spec lexbuf }
+  | character | _ 
+	   { seen_proof := true; proof_term lexbuf }
+  | eof    { () }
+
+(*s Scans a comment. *)
+
+and comment = parse
+  | "(*"   { comment lexbuf; comment lexbuf }
+  | "*)"   { () }
+  | '"'    { let n = string lexbuf in dlines := !dlines + n; 
+	     seen_comment := true; comment lexbuf }
+  | '\n'   { newline (); comment lexbuf }
+  | space+ | stars
+	   { comment lexbuf }
+  | character | _ 
+	   { seen_comment := true; comment lexbuf }
+  | eof    { () }
+
+(*s The entry [string] reads a string until its end and returns the number
+    of newlines it contains. *)
+
+and string = parse
+  | '"'  { 0 }
+  | '\\' ('\\' | 'n' | '"') { string lexbuf }
+  | '\n' { succ (string lexbuf) }
+  | _    { string lexbuf }
+  | eof  { 0 }
+
+(*s The following entry [read_header] is used to skip the possible header at
+    the beggining of files (unless option \texttt{-e} is specified).
+    It stops whenever it encounters an empty line or any character outside
+    a comment. In this last case, it correctly resets the lexer position
+    on that character (decreasing [lex_curr_pos] by 1). *)
+ 
+and read_header = parse
+  | "(*"   { skip_comment lexbuf; skip_until_nl lexbuf; 
+	     read_header lexbuf }
+  | "\n"   { () }
+  | space+ { read_header lexbuf }
+  | _      { lexbuf.lex_curr_pos <- lexbuf.lex_curr_pos - 1 }
+  | eof    { () }
+
+and skip_comment = parse
+  | "*)" { () }
+  | "(*" { skip_comment lexbuf; skip_comment lexbuf }
+  | _    { skip_comment lexbuf }
+  | eof  { () }
+
+and skip_until_nl = parse
+  | '\n' { () }
+  | _    { skip_until_nl lexbuf }
+  | eof  { () }
+
+(*i*){(*i*)
+
+(*s Processing files and channels. *)
+
+let process_channel ch =
+  let lb = Lexing.from_channel ch in
+  reset_counters ();
+  if !skip_header then read_header lb;
+  spec lb
+
+let process_file f =
+  try
+    let ch = open_in f in
+    process_channel ch;
+    close_in ch;
+    print_file (Some f);
+    update_totals ()
+  with
+    | Sys_error "Is a directory" -> 
+	flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr
+    | Sys_error s -> 
+	flush stdout; eprintf "coqwc: %s\n" s; flush stderr
+
+(*s Parsing of the command line. *)
+
+let usage () =
+  prerr_endline "usage: coqwc [options] [files]";
+  prerr_endline "Options are:";
+  prerr_endline "  -p   print percentage of comments";
+  prerr_endline "  -s   print only the spec size";
+  prerr_endline "  -r   print only the proof size";
+  prerr_endline "  -e   (everything) do not skip headers";
+  exit 1
+
+let rec parse = function
+  | [] -> []
+  | ("-h" | "-?" | "-help" | "--help") :: _ -> usage ()
+  | ("-s" | "--spec-only") :: args -> 
+      proof_only := false; spec_only := true; parse args
+  | ("-r" | "--proof-only") :: args -> 
+      spec_only := false; proof_only := true; parse args
+  | ("-p" | "--percentage") :: args -> percentage := true; parse args
+  | ("-e" | "--header") :: args -> skip_header := false; parse args
+  | f :: args -> f :: (parse args)
+
+(*s Main program. *)
+
+let main () =
+  let files = parse (List.tl (Array.to_list Sys.argv)) in
+  if not (!spec_only || !proof_only) then 
+    printf "     spec    proof comments\n";
+  match files with
+    | [] -> process_channel stdin; print_file None
+    | [f] -> process_file f
+    | _ -> List.iter process_file files; print_totals ()
+
+let _ = Printexc.catch main ()
+
+(*i*)}(*i*)
+
+
diff --git a/tools/gallina.ml b/tools/gallina.ml
new file mode 100644
index 00000000..c997820c
--- /dev/null
+++ b/tools/gallina.ml
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gallina.ml,v 1.2.16.1 2004/07/16 19:31:46 herbelin Exp $ *)
+
+open Gallina_lexer
+
+let vfiles = ref ([] : string list)
+
+let option_moins = ref false
+
+let option_stdout = ref false
+
+let traite_fichier f = 
+  try 
+    let chan_in = open_in (f^".v") in 
+    let buf = Lexing.from_channel chan_in in
+    if not !option_stdout then chan_out := open_out (f ^ ".g");
+    try 
+      while true do Gallina_lexer.action buf done
+    with Fin_fichier -> begin 
+      flush !chan_out;
+      close_in chan_in;
+      if not !option_stdout then close_out !chan_out
+    end
+  with Sys_error _ -> 
+    () 
+
+let traite_stdin () =
+  try
+    let buf = Lexing.from_channel stdin in
+    try 
+      while true do Gallina_lexer.action buf done
+    with Fin_fichier -> 
+      flush !chan_out
+  with Sys_error _ -> 
+    ()
+
+let gallina () =
+  let lg_command = Array.length Sys.argv in
+  if lg_command < 2 then begin
+    output_string stderr "Usage: gallina [-] [-stdout] file1 file2 ...\n";
+    flush stderr;
+    exit 1
+  end;
+  let treat = function
+    | "-" -> option_moins := true
+    | "-stdout" -> option_stdout := true
+    | "-nocomments" -> comments := false
+    | f -> 
+	if Filename.check_suffix f ".v" then
+       	  vfiles := (Filename.chop_suffix f ".v") :: !vfiles
+  in
+  Array.iter treat Sys.argv;
+  if !option_moins then
+    traite_stdin ()
+  else
+    List.iter traite_fichier !vfiles
+
+let _ = Printexc.catch gallina ()
+
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
new file mode 100644
index 00000000..ce9fb950
--- /dev/null
+++ b/tools/gallina_lexer.mll
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: gallina_lexer.mll,v 1.5.6.1 2004/07/16 19:31:46 herbelin Exp $ *)
+
+{
+ open Lexing
+
+ let chan_out = ref stdout
+
+ let comment_depth = ref 0
+ let cRcpt = ref 0
+ let comments = ref true
+ let print s = output_string !chan_out s
+ 
+ exception Fin_fichier
+
+}
+
+let space = [' ' '\t' '\n' '\r']
+let enddot = '.' (' ' | '\t' | '\n' | '\r' | eof)
+
+rule action = parse
+  | "Theorem" space { print "Theorem "; body lexbuf; 
+  	              cRcpt := 1; action lexbuf }
+  | "Lemma" space   { print "Lemma ";   body lexbuf; 
+      	       	      cRcpt := 1; action lexbuf }
+  | "Fact" space    { print "Fact ";   body lexbuf; 
+      	       	      cRcpt := 1; action lexbuf }
+  | "Remark" space  { print "Remark ";  body lexbuf; 
+      	       	      cRcpt := 1; action lexbuf }
+  | "Goal" space    { print "Goal ";    body lexbuf; 
+      	       	      cRcpt := 1; action lexbuf }
+  | "Correctness" space { print "Correctness "; body_pgm lexbuf; 
+      	       	          cRcpt := 1; action lexbuf }
+  | "Definition" space  { print "Definition "; body_def lexbuf;
+			  cRcpt := 1; action lexbuf }
+  | "Hint" space        { skip_until_point lexbuf ; action lexbuf }
+  | "Hints" space        { skip_until_point lexbuf ; action lexbuf }
+  | "Transparent" space { skip_until_point lexbuf ; action lexbuf }
+  | "Immediate"	space   { skip_until_point lexbuf ; action lexbuf }
+  | "Syntax" space      { skip_until_point lexbuf ; action lexbuf }
+  | "(*"      { (if !comments then print "(*");
+		comment_depth := 1;
+      	        comment lexbuf;
+		cRcpt := 0; action lexbuf }
+  | [' ' '\t']* '\n'      { if !cRcpt < 2 then print "\n";
+      	       	       	    cRcpt := !cRcpt+1; action lexbuf}
+  | eof       { raise Fin_fichier}
+  | _         { print (Lexing.lexeme lexbuf); cRcpt := 0; action lexbuf }
+
+and comment = parse
+  | "(*"  { (if !comments then print "(*"); 
+      	    comment_depth := succ !comment_depth; comment lexbuf }
+  | "*)"  { (if !comments then print "*)");
+      	    comment_depth := pred !comment_depth;
+            if !comment_depth > 0 then comment lexbuf }
+  | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf));
+      			  comment_depth := pred !comment_depth;
+			  if !comment_depth > 0 then comment lexbuf }
+  | eof   { raise Fin_fichier } 
+  | _     { (if !comments then print (Lexing.lexeme lexbuf)); 
+	    comment lexbuf }
+
+and skip_comment = parse
+  | "(*"  { comment_depth := succ !comment_depth; skip_comment lexbuf }
+  | "*)"  { comment_depth := pred !comment_depth;
+            if !comment_depth > 0 then skip_comment lexbuf }
+  | eof   { raise Fin_fichier } 
+  | _     { skip_comment lexbuf }
+
+and body_def = parse
+  | [^'.']* ":=" { print (Lexing.lexeme lexbuf); () }
+  | _            { print (Lexing.lexeme lexbuf); body lexbuf }
+
+and body = parse
+  | enddot { print ".\n"; skip_proof lexbuf }
+  | ":="   { print ".\n"; skip_proof lexbuf }
+  | "(*"   { print "(*"; comment_depth := 1;
+      	     comment lexbuf; body lexbuf }
+  | eof    { raise Fin_fichier } 
+  | _      { print (Lexing.lexeme lexbuf); body lexbuf }
+
+and body_pgm = parse
+  | enddot { print ".\n"; skip_proof lexbuf }
+  | "(*"   { print "(*"; comment_depth := 1;
+      	     comment lexbuf; body_pgm lexbuf }
+  | eof    { raise Fin_fichier } 
+  | _      { print (Lexing.lexeme lexbuf); body_pgm lexbuf }
+
+and skip_until_point = parse
+  | '.' '\n' { () }
+  | enddot   { end_of_line lexbuf }
+  | "(*"     { comment_depth := 1;
+      	       skip_comment lexbuf; skip_until_point lexbuf }
+  | eof      { raise Fin_fichier } 
+  | _        { skip_until_point lexbuf }
+
+and end_of_line = parse
+  | [' ' '\t' ]*	{ end_of_line lexbuf }
+  | '\n'		{ () }
+  | eof   	     	{ raise Fin_fichier } 
+  | _	  		{ print (Lexing.lexeme lexbuf) }
+
+and skip_proof = parse
+  | "Save."	{ end_of_line lexbuf }
+  | "Save" space
+                { skip_until_point lexbuf }
+  | "Qed."  	{ end_of_line lexbuf }
+  | "Qed" space
+                { skip_until_point lexbuf }
+  | "Defined."  { end_of_line lexbuf }
+  | "Defined" space
+                { skip_until_point lexbuf }
+  | "Abort." 	{ end_of_line lexbuf }
+  | "Abort" space
+                { skip_until_point lexbuf }
+  | "Proof" space   { skip_until_point lexbuf }
+  | "Proof" [' ' '\t']* '.'  { skip_proof lexbuf }
+  | "(*"    { comment_depth := 1;
+      	      skip_comment lexbuf; skip_proof lexbuf }
+  | eof     { raise Fin_fichier } 
+  | _       { skip_proof lexbuf }
diff --git a/tools/restore-v7 b/tools/restore-v7
new file mode 100755
index 00000000..ab884587
--- /dev/null
+++ b/tools/restore-v7
@@ -0,0 +1,9 @@
+#!/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
new file mode 100755
index 00000000..7d71bea9
--- /dev/null
+++ b/tools/translate-v8
@@ -0,0 +1,41 @@
+#!/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
new file mode 100755
index 00000000..10e7f140
--- /dev/null
+++ b/tools/translate_V6-3-1_to_V7-0
@@ -0,0 +1,27 @@
+#! /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
new file mode 100755
index 00000000..36d0bf8c
--- /dev/null
+++ b/tools/upgrade-v8
@@ -0,0 +1,22 @@
+#!/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
new file mode 100644
index 00000000..21098a57
--- /dev/null
+++ b/toplevel/cerrors.ml
@@ -0,0 +1,134 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: cerrors.ml,v 1.12.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+
+open Pp
+open Util
+open Ast
+open Indtypes
+open Type_errors
+open Pretype_errors
+open Lexer
+
+let print_loc loc =
+  if loc = dummy_loc then 
+    (str"<unknown>")
+  else 
+    let loc = unloc loc in
+    (int (fst loc) ++ str"-" ++ int (snd loc))
+
+let guill s = "\""^s^"\""
+
+let where s =
+  if !Options.debug then  (str"in " ++ str s ++ str":" ++ spc ()) else (mt ())
+
+let report () = (str "." ++ spc () ++ str "Please report.")
+
+(* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *)
+
+let rec explain_exn_default = function
+  | Stream.Failure -> 
+      hov 0 (str "Anomaly: 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 ())
+  | 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 ())
+  | Match_failure(filename,pos1,pos2) ->
+      hov 1 (str "Anomaly: 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 ())
+  | Not_found -> 
+      hov 0 (str "Anomaly: uncaught exception Not_found" ++ report ())
+  | Failure s -> 
+      hov 0 (str "Anomaly: uncaught exception Failure " ++ str (guill s) ++ report ())
+  | Invalid_argument s -> 
+      hov 0 (str "Anomaly: uncaught exception Invalid_argument " ++ str (guill s) ++ report ())
+  | Sys.Break -> 
+      hov 0 (fnl () ++ str "User Interrupt.")
+  | Univ.UniverseInconsistency -> 
+      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)
+  | Cases.PatternMatchingError (env,e) -> 
+      hov 0
+	(str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e)
+  | Logic.RefinerError e -> 
+      hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e)
+  | Nametab.GlobalizationError q ->
+      hov 0 (str "Error:" ++ spc () ++
+	       str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
+	       spc () ++ str "was not found" ++ 
+	       spc () ++ str "in the current" ++ spc () ++ str "environment")
+  | Nametab.GlobalizationConstantError q ->
+      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 ++
+             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)
+  | Lexer.Error Illegal_character -> 
+      hov 0 (str "Syntax error: Illegal character.")
+  | Lexer.Error Unterminated_comment -> 
+      hov 0 (str "Syntax error: Unterminated comment.")
+  | Lexer.Error Unterminated_string -> 
+      hov 0 (str "Syntax error: Unterminated string.")
+  | Lexer.Error Undefined_token -> 
+      hov 0 (str "Syntax error: Undefined token.")
+  | 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 () ++
+	       (if s <> "" then 
+		 if Sys.ocaml_version = "3.06" then
+		   (str ("(file \"" ^ s ^ "\", characters ") ++ 
+		    int b ++ str "-" ++ int e ++ str ")")
+		 else
+		   (str ("(file \"" ^ s ^ "\", line ") ++ int b ++
+		    str ", characters " ++ int e ++ str "-" ++
+		    int (e+6) ++ str ")")
+	       else
+		 (mt ())) ++
+	       report ())
+  | reraise ->
+      hov 0 (str "Anomaly: Uncaught exception " ++ 
+	       str (Printexc.to_string reraise) ++ report ())
+
+let raise_if_debug e =
+  if !Options.debug then raise e
+
+let _ = Tactic_debug.explain_logic_error := explain_exn_default
+
+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
new file mode 100644
index 00000000..09d79cec
--- /dev/null
+++ b/toplevel/cerrors.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: cerrors.mli,v 1.2.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Util
+(*i*)
+
+(* Error report. *)
+
+val print_loc : loc -> std_ppcmds
+
+val explain_exn : exn -> std_ppcmds
+
+val explain_exn_function : (exn -> std_ppcmds) ref
+val explain_exn_default : exn -> std_ppcmds
+
+val raise_if_debug : exn -> unit
diff --git a/toplevel/class.ml b/toplevel/class.ml
new file mode 100644
index 00000000..429469b1
--- /dev/null
+++ b/toplevel/class.ml
@@ -0,0 +1,460 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: class.ml,v 1.44.2.2 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Util
+open Pp
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Declarations
+open Entries
+open Environ
+open Inductive
+open Lib
+open Classops
+open Declare
+open Libnames
+open Nametab
+open Decl_kinds
+open Safe_typing
+
+let strength_min4 stre1 stre2 stre3 stre4 =
+  strength_min ((strength_min (stre1,stre2)),(strength_min (stre3,stre4)))
+
+let id_of_varid c = match kind_of_term c with
+  | Var id -> id
+  | _ -> anomaly "class__id_of_varid"
+
+(* lf liste des variable dont depend la coercion f
+   lc liste des variable dont depend la classe source *)
+
+let rec stre_unif_cond = function
+  | ([],[]) -> Global
+  | (v::l,[]) -> variable_strength v
+  | ([],v::l) -> variable_strength v
+  | (v1::l1,v2::l2) ->
+      if v1=v2 then 
+	stre_unif_cond (l1,l2)
+      else
+	let stre1 = (variable_strength v1)
+	and stre2 = (variable_strength v2) in 
+	strength_min (stre1,stre2)
+
+(* Errors *)
+
+type coercion_error_kind =
+  | AlreadyExists
+  | NotAFunction
+  | NoSource of cl_typ option
+  | ForbiddenSourceClass of cl_typ
+  | NotUniform
+  | NoTarget
+  | WrongTarget of cl_typ * cl_typ
+  | NotAClass of global_reference
+  | NotEnoughClassArgs of cl_typ
+
+exception CoercionError of coercion_error_kind
+
+let explain_coercion_error g = function
+  | AlreadyExists ->
+      (Printer.pr_global g ++ str" is already a coercion")
+  | NotAFunction ->
+      (Printer.pr_global g ++ str" is not a function")
+  | NoSource (Some cl) ->
+      (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " 
+       ++ Printer.pr_global g)
+  | NoSource None ->
+      (str ": cannot find the source class of " ++ Printer.pr_global g)
+  | ForbiddenSourceClass cl ->
+      pr_class cl ++ str " cannot be a source class"
+  | NotUniform ->
+      (Printer.pr_global g ++
+         str" does not respect the inheritance uniform condition");
+  | NoTarget ->
+      (str"Cannot find the target class")
+  | WrongTarget (clt,cl) ->
+      (str"Found target class " ++ pr_class cl ++
+       str " instead of " ++ pr_class clt)
+  | NotAClass ref ->
+      (str "Type of " ++ Printer.pr_global ref ++
+         str " does not end with a sort")
+  | NotEnoughClassArgs cl ->
+      (str"Wrong number of parameters for " ++ pr_class cl)
+
+(* Verifications pour l'ajout d'une classe *)
+
+let rec arity_sort a = match kind_of_term a with
+  | Sort (Prop _ | Type _) -> 0
+  | Prod (_,_,c) -> (arity_sort c) +1
+  | LetIn (_,_,_,c) -> arity_sort c    (* Utile ?? *)
+  | Cast (c,_) -> arity_sort c
+  | _ -> raise Not_found
+
+let check_reference_arity ref =
+  try arity_sort (Global.type_of_global ref)
+  with Not_found -> raise (CoercionError (NotAClass ref))
+
+let check_arity = function
+  | CL_FUN | CL_SORT -> 0
+  | 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 *)
+let check_target clt = function
+  | Some cl when cl <> clt -> raise (CoercionError (WrongTarget(clt,cl)))
+  | _ -> ()
+
+(* condition d'heritage uniforme *)
+
+let uniform_cond nargs lt = 
+  let rec aux = function
+    | (0,[]) -> true
+    | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l))
+    | _ -> false
+  in 
+  aux (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_IND ind ->
+      let (_,mip) = Global.lookup_inductive ind in
+      mip.mind_typename
+  | CL_SECVAR id -> id
+
+let class_of_ref = function
+  | ConstRef sp -> CL_CONST sp
+  | IndRef sp -> CL_IND sp
+  | VarRef id -> CL_SECVAR id
+  | ConstructRef _ as c -> 
+      errorlabstrm "class_of_ref"
+	(str "Constructors, such as " ++ Printer.pr_global c ++ 
+	   str " cannot be used as class")
+
+(* 
+lp est la liste (inverse'e) des arguments de la coercion
+ids est le nom de la classe source
+sps_opt est le sp de la classe source dans le cas des structures
+retourne:
+la classe source
+nbre d'arguments de la classe
+le constr de la class
+la liste des variables dont depend la classe source
+l'indice de la classe source dans la liste lp
+*)
+
+let get_source lp source =
+  match source with
+    | None ->
+	let (cl1,lv1) =
+          match lp with
+	    | [] -> raise Not_found
+            | t1::_ -> find_class_type t1
+        in 
+	(cl1,lv1,1)
+    | Some cl ->
+	let rec aux = function
+	  | [] -> raise Not_found
+	  | t1::lt ->
+	      try 
+		let cl1,lv1 = find_class_type t1 in
+		if cl = cl1 then cl1,lv1,(List.length lt+1)
+		else raise Not_found
+              with Not_found -> aux lt
+	in aux (List.rev lp)
+
+let get_target t ind =
+  if (ind > 1) then 
+    CL_FUN
+  else 
+    fst (find_class_type t)
+
+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
+    | _ -> (d,acc)
+  in 
+  aux [] t
+
+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 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
+ *)
+  let streunif = Global in
+  let stre' = strength_min4 stres stret stref streunif in
+  strength_min (stre,stre')
+
+(* coercion identité *)
+
+let error_not_transparent source =
+  errorlabstrm "build_id_coercion"
+    (pr_class source ++ str " must be a transparent constant")
+
+let build_id_coercion idf_opt source =
+  let env = Global.env () in
+  let vs = match source with
+    | CL_CONST sp -> mkConst sp
+    | _ -> error_not_transparent source in
+  let c = match constant_opt_value env (destConst vs) with
+    | Some c -> c
+    | None -> error_not_transparent source in
+  let lams,t = Sign.decompose_lam_assum c in
+  let val_f =
+    it_mkLambda_or_LetIn
+      (mkLambda (Name (id_of_string "x"),
+		 applistc vs (extended_rel_list 0 lams),
+		 mkRel 1))
+       lams
+  in
+  let typ_f =
+    it_mkProd_wo_LetIn
+      (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t))
+      lams
+  in
+  (* juste pour verification *)
+  let _ = 
+    if not
+      (Reductionops.is_conv_leq env Evd.empty
+	(Typing.type_of env Evd.empty val_f) typ_f)
+    then
+      error ("cannot be defined as coercion - "^
+             "maybe a bad number of arguments") 
+  in
+  let idf =
+    match idf_opt with
+      | Some idf -> idf
+      | None ->
+	  id_of_string ("Id_"^(string_of_class source)^"_"^
+                        (string_of_class (fst (find_class_type t)))) 
+  in
+  let constr_entry = (* Cast is necessary to express [val_f] is identity *)
+    DefinitionEntry
+      { const_entry_body = mkCast (val_f, typ_f);
+	const_entry_type = Some typ_f;
+        const_entry_opaque = false } in
+  let (_,kn) = declare_constant idf (constr_entry,Decl_kinds.IsDefinition) in
+  ConstRef kn
+
+let check_source = function
+| Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s))
+| _ -> ()
+
+(* 
+nom de la fonction coercion
+strength de f
+nom de la classe source (optionnel)
+sp de la classe source (dans le cas des structures)
+nom de la classe target (optionnel)
+booleen "coercion identite'?"
+
+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
+  if coercion_exists coef then raise (CoercionError AlreadyExists);
+  let tg,lp = prods_of (vj.uj_type) in
+  let llp = List.length lp in
+  if llp = 0 then raise (CoercionError NotAFunction);
+  let (cls,lvs,ind) =
+    try 
+      get_source lp source
+    with Not_found ->
+      raise (CoercionError (NoSource source))
+  in
+  check_source (Some cls);
+  if not (uniform_cond (llp-ind) lvs) then
+    raise (CoercionError NotUniform);
+  let clt =
+    try
+      get_target tg ind 
+    with Not_found ->
+      raise (CoercionError NoTarget)
+  in
+  check_target clt target;
+  try_add_class cls None false;
+  try_add_class clt None false;
+  let stre' = get_strength stre coef cls clt in
+  declare_coercion coef vj 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
+  with CoercionError e ->
+      errorlabstrm "try_add_new_coercion_core" (explain_coercion_error ref e)
+
+let try_add_new_coercion ref stre =
+  try_add_new_coercion_core ref stre None None false
+
+let try_add_new_coercion_subclass cl stre =
+  let coe_ref = build_id_coercion None cl in
+  try_add_new_coercion_core coe_ref stre (Some cl) None true
+
+let try_add_new_coercion_with_target ref stre ~source ~target =
+  try_add_new_coercion_core ref stre (Some source) (Some target) false
+
+let try_add_new_identity_coercion id stre ~source ~target =
+  let ref = build_id_coercion (Some id) source in
+  try_add_new_coercion_core ref stre (Some source) (Some target) true
+
+let try_add_new_coercion_with_source ref stre ~source =
+  try_add_new_coercion_core ref stre (Some source) None false
+
+let add_coercion_hook stre ref = 
+  try_add_new_coercion ref stre;
+  Options.if_verbose message
+    (string_of_qualid (shortest_qualid_of_global Idset.empty ref)
+    ^ " is now a coercion")
+
+let add_subclass_hook stre ref =
+  let cl = class_of_ref 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
new file mode 100644
index 00000000..b0350985
--- /dev/null
+++ b/toplevel/class.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: class.mli,v 1.17.6.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Classops
+open Declare
+open Libnames
+open Decl_kinds
+open Nametab
+(*i*)
+
+(* Classes and coercions. *)
+
+(* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
+   from [src] to [tg] *)
+val try_add_new_coercion_with_target : global_reference -> strength -> 
+  source:cl_typ -> target:cl_typ ->  unit
+
+(* [try_add_new_coercion ref s] declares [ref], assumed to be of type
+   [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
+val try_add_new_coercion : global_reference -> strength -> unit
+
+(* [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
+   transparent constant which unfolds to some class [tg]; it declares
+   an identity coercion from [cst] to [tg], named something like
+   ["Id_cst_tg"] *)
+val try_add_new_coercion_subclass : cl_typ -> strength -> unit
+
+(* [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
+   from [src] to [tg] where the target is inferred from the type of [ref] *)
+val try_add_new_coercion_with_source : global_reference -> strength ->
+  source:cl_typ -> unit
+
+(* [try_add_new_identity_coercion id s src tg] enriches the
+   environment with a new definition of name [id] declared as an
+   identity coercion from [src] to [tg] *)
+val try_add_new_identity_coercion : identifier -> strength ->
+  source:cl_typ -> target:cl_typ -> unit
+
+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
diff --git a/toplevel/command.ml b/toplevel/command.ml
new file mode 100644
index 00000000..b9a47781
--- /dev/null
+++ b/toplevel/command.ml
@@ -0,0 +1,701 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: command.ml,v 1.116.2.1 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Term
+open Termops
+open Declarations
+open Entries
+open Inductive
+open Environ
+open Reduction
+open Tacred
+open Declare
+open Nametab
+open Names
+open Libnames
+open Nameops
+open Topconstr
+open Library
+open Libobject
+open Constrintern
+open Proof_type
+open Tacmach
+open Safe_typing
+open Nametab
+open Typeops
+open Indtypes
+open Vernacexpr
+open Decl_kinds
+open Pretyping
+open Symbols
+
+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
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl
+        (abstract_rawconstr c bl)
+
+let rec prod_rawconstr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
+        (prod_rawconstr c bl)
+
+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)
+  | _ -> 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)
+  | CHole loc ->
+      let (nar,name,params) = a in
+      if nar <> 0 then
+	user_err_loc (loc,"",
+	  str "Cannot infer the non constant arguments of the conclusion of "
+	  ++ pr_id cs);
+      let args = List.map (fun id -> CRef(Ident(loc,id))) params in
+      CAppExpl (loc,(None,Ident(loc,name)),List.rev args)
+  | c -> c
+
+(* Commands of the interface *)
+
+(* 1| Constant definitions *)
+
+let definition_message id =
+  if_verbose message ((string_of_id id) ^ " is defined")
+
+let constant_entry_of_com (bl,com,comtypopt,opacity) =
+  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
+	{ const_entry_body = j.uj_val;
+	  const_entry_type = Some (Evarutil.refresh_universes j.uj_type);
+          const_entry_opaque = opacity }
+    | 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 (body,typ) = destSubCast (interp_constr sigma env b) in
+	{ const_entry_body = body;
+	  const_entry_type = Some typ;
+          const_entry_opaque = opacity }
+
+let red_constant_entry ce = function
+  | None -> ce
+  | Some red ->
+      let body = ce.const_entry_body in
+      { ce with const_entry_body = 
+	  reduction_of_redexp red (Global.env()) Evd.empty body }
+
+let declare_global_definition ident ce local =
+  let (_,kn) = declare_constant ident (DefinitionEntry ce,IsDefinition) in
+  if local = Local 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
+  if bl<>[] && red_option <> None then 
+    error "Evaluation under a local context not supported";
+  let ce' = red_constant_entry 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
+        definition_message ident;
+        if Pfedit.refining () then 
+          msgerrnl (str"Warning: Local definition " ++ pr_id ident ++ 
+          str" is not visible from current goals");
+        VarRef ident
+    | (Global|Local) ->
+        declare_global_definition ident ce' local in
+  hook local r
+
+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 *)
+
+let assumption_message id =
+  if_verbose message ((string_of_id id) ^ " is assumed")
+
+let declare_one_assumption is_coe (local,kind) c (_,ident) =
+  let r = match local with
+    | Local when Lib.sections_are_opened () ->
+        let r = 
+          declare_variable ident 
+            (Lib.cwd(), SectionLocalAssum c, IsAssumption kind) in
+        assumption_message ident;
+        if is_verbose () & Pfedit.refining () then 
+          msgerrnl (str"Warning: Variable " ++ pr_id ident ++ 
+          str" is not visible from current goals");
+        VarRef ident
+    | (Global|Local) ->
+        let (_,kn) =
+          declare_constant ident (ParameterEntry c, IsAssumption kind) in
+        assumption_message ident;
+        if local=Local & Options.is_verbose () then
+          msg_warning (pr_id ident ++ str" is declared as a parameter" ++
+          str" because it is at a global level");
+        ConstRef kn in
+  if is_coe then Class.try_add_new_coercion r local
+
+let declare_assumption idl is_coe k bl c =
+  let c = prod_rawconstr c bl in
+  let c = interp_type Evd.empty (Global.env()) c in
+  List.iter (declare_one_assumption is_coe k c) idl
+
+(* 3a| Elimination schemes for mutual inductive definitions *)
+
+open Indrec
+
+let non_type_eliminations = 
+  [ (InProp,elimination_suffix InProp);
+    (InSet,elimination_suffix InSet) ]
+
+let declare_one_elimination ind =
+  let (mib,mip) = Global.lookup_inductive ind in 
+  let mindstr = string_of_id mip.mind_typename in
+  let declare s c t =
+    let id = id_of_string s in
+    let kn = Declare.declare_internal_constant id
+      (DefinitionEntry
+        { const_entry_body = c;
+          const_entry_type = t;
+          const_entry_opaque = false }, 
+       Decl_kinds.IsDefinition) 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 *)
+  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
+    List.iter (fun (sort,suff) -> 
+      let (t',c') = 
+	Indrec.instanciate_type_indrec_scheme (new_sort_in_family sort)
+	  npars c t in
+      let _ = declare (mindstr^suff) c' (Some t') in ())
+      non_type_eliminations
+   else (* Impredicative or logical inductive definition *)
+     List.iter
+    (fun (sort,suff) -> 
+       if List.mem sort kelim then
+	 let elim = make_elim (new_sort_in_family sort) in
+	 let _ = declare (mindstr^suff) elim None in ())
+       non_type_eliminations
+
+let declare_eliminations sp =
+  let mib = Global.lookup_mind sp in
+  if mib.mind_finite then
+    for i = 0 to Array.length mib.mind_packets - 1 do
+      declare_one_elimination (sp,i)
+    done
+
+(* 3b| Mutual Inductive definitions *)
+
+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 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_finite = finite; mind_entry_inds = mispecvec }
+  with e -> States.unfreeze fs; raise e
+
+let declare_mutual_with_eliminations isrecord mie =
+  let lrecnames =
+    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);
+  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 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 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 = prod_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 [] 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 (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
+
+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 = prod_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 = prod_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 
+  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 ()
+
+let build_scheme lnamedepindsort = 
+  let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
+  and sigma = Evd.empty
+  and env0 = Global.env() in
+  let lrecspec =
+    List.map
+      (fun (_,dep,indid,sort) ->
+        let ind = Nametab.global_inductive indid in
+        let (mib,mip) = Global.lookup_inductive ind in
+         (ind,mib,mip,dep,interp_elimination_sort sort)) 
+      lnamedepindsort
+  in
+  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 ce = { const_entry_body = decl;
+               const_entry_type = Some decltype;
+               const_entry_opaque = false } in
+    let _,kn = declare_constant fi (DefinitionEntry ce, IsDefinition) in
+    ConstRef kn :: lrecref
+  in 
+  let lrecref = List.fold_right2 declare listdecl lrecnames [] in
+  if_verbose ppnl (recursive_message (Array.of_list lrecref))
+
+let rec generalize_rawconstr c = function
+  | [] -> c
+  | LocalRawDef (id,b)::bl -> mkLetInC(id,b,generalize_rawconstr c bl)
+  | LocalRawAssum (idl,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],t,b)) idl
+        (generalize_rawconstr c bl)
+
+let start_proof id kind c hook =
+  let sign = Global.named_context () in
+  let sign = clear_proofs sign in
+  Pfedit.start_proof id kind sign c hook
+
+let start_proof_com 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 env = Global.env () in
+  let c = interp_type Evd.empty env (generalize_rawconstr t bl) in
+  let _ = Typeops.infer_type env c in
+  start_proof id kind c hook
+
+let save id const 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 c = SectionLocalDef (pft, tpo, opacity) in
+	let _ = declare_variable id (Lib.cwd(), c, IsDefinition) in
+	(Local, VarRef id)
+    | IsLocal ->
+        let k = IsDefinition 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, ConstRef kn) in
+  hook l r;
+  Pfedit.delete_current_proof ();
+  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 (IsGlobal (Proof kind)) hook
+
+let admit () =
+  let (id,k,typ,hook) = Pfedit.current_proof_statement () in
+(* Contraire aux besoins d'interactivité...
+  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);
+  Pfedit.delete_current_proof ();
+  assumption_message id
+
+let get_current_context () =
+  try Pfedit.get_current_goal_context ()
+  with e when Logic.catchable_exception e -> 
+    (Evd.empty, Global.env())
diff --git a/toplevel/command.mli b/toplevel/command.mli
new file mode 100644
index 00000000..7997288c
--- /dev/null
+++ b/toplevel/command.mli
@@ -0,0 +1,85 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: command.mli,v 1.38.2.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Nametab
+open Declare
+open Library
+open Libnames
+open Nametab
+open Tacexpr
+open Vernacexpr
+open Rawterm
+open Topconstr
+open Decl_kinds
+(*i*)
+
+(*s Declaration functions. The following functions take ASTs,
+   transform them into [constr] and then call the corresponding
+   functions of [Declare]; they return an absolute reference to the
+   defined object *)
+
+val declare_definition : identifier -> definition_kind ->
+  local_binder list -> Tacred.red_expr option -> constr_expr ->
+    constr_expr option -> declaration_hook -> unit
+
+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 declare_mutual_with_eliminations :
+  bool -> Entries.mutual_inductive_entry -> mutual_inductive
+
+val build_recursive : (fixpoint_expr * decl_notation) list -> unit
+
+val build_corecursive : cofixpoint_expr list -> unit
+
+val build_scheme : (identifier located * bool * reference * rawsort) list -> unit
+
+val generalize_rawconstr : constr_expr -> local_binder list -> constr_expr
+
+val start_proof : identifier -> goal_kind -> constr ->
+  declaration_hook -> unit
+
+val start_proof_com : identifier option -> goal_kind -> 
+  (local_binder list * constr_expr) -> declaration_hook -> unit
+
+(*s [save_named b] saves the current completed proof under the name it
+was started; boolean [b] tells if the theorem is declared opaque; it
+fails if the proof is not completed *)
+
+val save_named : bool -> unit
+
+(* [save_anonymous b name] behaves as [save_named] but declares the theorem
+under the name [name] and respects the strength of the declaration *)
+
+val save_anonymous : bool -> identifier -> unit
+
+(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but
+   declares the theorem under the name [name] and gives it the
+   strength [strength] *)
+
+val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit
+
+(* [admit ()] aborts the current goal and save it as an assmumption *)
+
+val admit : unit -> unit
+
+(* [get_current_context ()] returns the evar context and env of the
+   current open proof if any, otherwise returns the empty evar context
+   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
new file mode 100644
index 00000000..4a4f7828
--- /dev/null
+++ b/toplevel/coqinit.ml
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqinit.ml,v 1.30.2.1 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open System
+open Toplevel
+
+let (/) = Filename.concat
+
+let set_debug () = Options.debug := true
+
+(* Loading of the ressource file.
+   rcfile is either $HOME/.coqrc.VERSION, or $HOME/.coqrc if the first one
+  does not exist. *)
+
+let rcfile = ref (home/".coqrc")
+let rcfile_specified = ref false
+let set_rcfile s = rcfile := s; rcfile_specified := true
+let set_rcuser s = rcfile := ("~"^s)/".coqrc"
+
+let load_rc = ref true
+let no_load_rc () = load_rc := false
+
+let load_rcfile() =
+  if !load_rc then
+    try
+      if !rcfile_specified then
+        if file_readable_p !rcfile then 
+          Vernac.load_vernac false !rcfile
+        else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
+      else if file_readable_p (!rcfile^"."^Coq_config.version) then
+        Vernac.load_vernac false (!rcfile^"."^Coq_config.version)
+      else if file_readable_p !rcfile then
+        Vernac.load_vernac false !rcfile
+      else ()
+	(*
+	Options.if_verbose
+	  mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^
+			 " found. Skipping rcfile loading."))
+	*)
+    with e ->
+      (msgnl (str"Load of rcfile failed.");
+       raise e)
+  else 
+    Options.if_verbose msgnl (str"Skipping rcfile loading.")
+
+let add_ml_include s =
+  Mltop.add_ml_dir s
+
+(* Puts dir in the path of ML and in the LoadPath *)
+let coq_add_path s = Mltop.add_path s (Names.make_dirpath [Nameops.coq_root])
+let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root])
+
+(* By the option -include -I or -R of the command line *)
+let includes = ref []
+let push_include (s, alias) = includes := (s,alias,false) :: !includes
+let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
+
+(* Because find puts "./" and the loadpath is not nicely pretty-printed *)
+let hm2 s = 
+  let n = String.length s in
+  if n > 1 && s.[0] = '.' && s.[1] = '/' then String.sub s 2 (n-2) else s
+
+let getenv_else s dft = try Sys.getenv s with Not_found -> dft
+
+(* Initializes the LoadPath according to COQLIB and Coq_config *)
+let init_load_path () =
+  (* developper specific directories to open *)
+  let dev = if Coq_config.local then [ "dev" ] else [] in
+  let coqlib =
+    if Coq_config.local || !Options.boot then Coq_config.coqtop
+      (* variable COQLIB overrides the default library *)
+    else getenv_else "COQLIB" 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;
+  (* 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
+  List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
+  let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in
+  add_ml_include camlp4;
+  (* then current directory *)
+  Mltop.add_path "." Nameops.default_root_prefix;
+  (* additional loadpath, given with -I -include -R options *)
+  List.iter 
+    (fun (s,alias,reci) ->
+       if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias)
+    (List.rev !includes)
+let init_library_roots () =
+  includes := []
+
+(* Initialises the Ocaml toplevel before launching it, so that it can
+   find the "include" file in the *source* directory *)
+(* We only assume that the variable COQTOP is set *)
+let init_ocaml_path () =
+  let coqtop = getenv_else "COQTOP" Coq_config.coqtop in
+  let add_subdir dl = 
+    Mltop.add_ml_dir (List.fold_left (/) coqtop dl) 
+  in
+  List.iter add_subdir
+    [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; 
+      [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
+      [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ]
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
new file mode 100644
index 00000000..e029d8ac
--- /dev/null
+++ b/toplevel/coqinit.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: coqinit.mli,v 1.7.16.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(* Initialization. *)
+
+val set_debug : unit -> unit
+
+val set_rcfile : string -> unit
+val set_rcuser : string -> unit
+
+val no_load_rc : unit -> unit
+val load_rcfile : unit -> unit
+
+val push_include : string * Names.dir_path -> unit
+val push_rec_include : string * Names.dir_path -> unit
+
+val init_load_path : unit -> unit
+val init_library_roots : unit -> unit
+
+val init_ocaml_path : unit -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
new file mode 100644
index 00000000..aa765b16
--- /dev/null
+++ b/toplevel/coqtop.ml
@@ -0,0 +1,325 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqtop.ml,v 1.72.2.3 2004/07/16 19:31:47 herbelin Exp $ *)
+
+open Pp
+open Util
+open System
+open Options
+open Names
+open Libnames
+open Nameops
+open States
+open Toplevel
+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 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 memory_stat = ref false
+
+let print_memory_stat () = 
+  if !memory_stat then
+    Format.printf "total heap size = %d kbytes\n" (heap_size_kb ())
+
+let _ = at_exit print_memory_stat
+
+let engagement = ref None
+let set_engagement c = engagement := Some c
+let engage () =
+  match !engagement with Some c -> Global.set_engagement c | None -> ()
+  
+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 remove_top_ml () = Mltop.remove ()
+
+let inputstate = ref None
+let set_inputstate s = inputstate:= Some s
+let inputstate () =
+  match !inputstate with
+    | Some "" -> ()
+    | Some s -> intern_state s
+    | None -> intern_state "initial.coq"
+
+let outputstate = ref ""
+let set_outputstate s = outputstate:=s
+let outputstate () = if !outputstate <> "" then extern_state !outputstate
+
+let check_coq_overwriting p = 
+  if string_of_id (List.hd (repr_dirpath p)) = "Coq" then
+    error "The \"Coq\" logical root directory is reserved for the Coq library"
+
+let set_include d p = push_include (d,p)
+let set_rec_include d p = check_coq_overwriting p; push_rec_include (d,p)
+let set_default_include d = set_include d Nameops.default_root_prefix
+let set_default_rec_include d = set_rec_include d Nameops.default_root_prefix
+ 
+let load_vernacular_list = ref ([] : (string * bool) list)
+let add_load_vernacular verb s =
+  load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list
+let load_vernacular () =
+  List.iter
+    (fun (s,b) -> 
+      if Options.do_translate () then
+	with_option translate_file (Vernac.load_vernac b) s
+      else
+	Vernac.load_vernac b s)
+    (List.rev !load_vernacular_list)
+
+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)
+
+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.rev !require_list)
+
+let compile_list = ref ([] : (bool * string) list)
+let add_compile verbose s =
+  set_batch_mode ();
+  Options.make_silent true; 
+  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 re_exec_version = ref ""
+let set_byte () = re_exec_version := "byte"
+let set_opt () = re_exec_version := "opt"
+
+(* Re-exec Coq in bytecode or native code if necessary. [s] is either
+   ["byte"] or ["opt"]. Notice that this is possible since the nature of
+   the toplevel has already been set in [Mltop] by the main file created
+   by coqmktop (see scripts/coqmktop.ml). *)
+
+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
+    let newprog = 
+      let dir = Filename.dirname prog in
+      let coqtop = if is_ide then "coqide." else "coqtop." in
+      let com = coqtop ^ s ^ Coq_config.exec_extension in
+      if dir <> "." then Filename.concat dir com else com 
+    in
+    Sys.argv.(0) <- newprog;
+    Unix.handle_unix_error (Unix.execvp newprog) Sys.argv
+  end
+
+(*s Parsing of the command line.
+    We no longer use [Arg.parse], in order to use share [Usage.print_usage]
+    between coqtop and coqc. *)
+
+let usage () =
+  if !batch_mode then
+    Usage.print_usage_coqc ()
+  else
+    Usage.print_usage_coqtop () ;
+  flush stderr ;
+  exit 1
+
+let warning s = msg_warning (str s)
+
+let ide_args = ref []
+let parse_args is_ide =
+  let rec parse = function
+    | [] -> ()
+
+    | "-impredicative-set" :: rem -> 
+        set_engagement Environ.ImpredicativeSet; parse rem
+
+    | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem
+    | ("-I"|"-include") :: []       -> usage ()
+
+    | "-R" :: d :: p :: rem ->set_rec_include d (dirpath_of_string p);parse rem
+    | "-R" :: ([] | [_]) -> usage ()
+
+    | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem
+    | "-top" :: [] -> usage ()
+
+    | "-q" :: rem -> no_load_rc (); parse rem
+
+    | "-opt" :: rem -> set_opt(); parse rem
+    | "-byte" :: rem -> set_byte(); parse rem
+    | "-full" :: rem -> warning "option -full deprecated\n"; parse rem
+
+    | "-batch" :: rem -> set_batch_mode (); parse rem
+    | "-boot" :: rem -> boot := true; no_load_rc (); parse rem	     
+    | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem
+    | "-outputstate" :: s :: rem -> set_outputstate s; parse rem
+    | "-outputstate" :: []       -> usage ()
+
+    | "-nois" :: rem -> set_inputstate ""; parse rem
+	     
+    | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem
+    | ("-inputstate"|"-is") :: []       -> usage ()
+
+    | "-load-ml-object" :: f :: rem -> Mltop.dir_ml_load f; parse rem
+    | "-load-ml-object" :: []       -> usage ()
+
+    | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem
+    | "-load-ml-source" :: []       -> usage ()
+
+    | ("-load-vernac-source"|"-l") :: f :: rem -> 
+	add_load_vernacular false f; parse rem
+    | ("-load-vernac-source"|"-l") :: []       -> usage ()
+
+    | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> 
+	add_load_vernacular true f; parse rem
+    | ("-load-vernac-source-verbose"|"-lv") :: []       -> usage ()
+
+    | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem
+    | "-load-vernac-object" :: []       -> usage ()
+
+    | "-dump-glob" :: f :: rem -> dump_into_file f; parse rem
+    | "-dump-glob" :: []       -> usage ()
+
+    | "-require" :: f :: rem -> add_require f; parse rem
+    | "-require" :: []       -> usage ()
+
+    | "-compile" :: f :: rem -> add_compile false f; parse rem
+    | "-compile" :: []       -> usage ()
+
+    | "-compile-verbose" :: f :: rem -> add_compile true f; parse rem
+    | "-compile-verbose" :: []       -> usage ()
+
+    | "-dont-load-proofs" :: rem -> Options.dont_load_proofs := true; parse rem
+
+    | "-translate" :: rem -> make_translate true; parse rem
+
+    | "-unsafe" :: f :: rem -> add_unsafe f; parse rem
+    | "-unsafe" :: []       -> usage ()
+
+    | "-debug" :: rem -> set_debug (); parse rem
+
+    | "-emacs" :: rem -> Options.print_emacs := true; parse rem
+	  
+    | "-where" :: _ -> print_endline Coq_config.coqlib; exit 0
+
+    | ("-quiet"|"-silent") :: rem -> Options.make_silent true; parse rem
+
+    | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
+
+    | ("-v"|"--version") :: _ -> Usage.version ()
+
+    | "-init-file" :: f :: rem -> set_rcfile f; parse rem
+    | "-init-file" :: []       -> usage ()
+
+    | "-user" :: u :: rem -> set_rcuser u; parse rem
+    | "-user" :: []       -> usage ()
+
+    | "-notactics" :: rem -> remove_top_ml (); parse rem
+
+    | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem
+
+    | ("-m" | "--memory") :: rem -> memory_stat := true; parse rem
+
+    | "-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
+
+    (* Translator options *)
+    | "-strict-implicit" :: rem -> 
+	Options.translate_strict_impargs := false; parse rem
+
+    | s :: rem -> 
+	if is_ide then begin
+	  ide_args := s :: !ide_args;
+	  parse rem
+	end else begin
+	  prerr_endline ("Don't know what to do with " ^ s); usage ()
+	end
+  in
+  try
+    parse (List.tl (Array.to_list Sys.argv))
+  with 
+    | UserError(_,s) as e -> begin
+	try
+	  Stream.empty s; exit 1
+	with Stream.Failure ->
+	  msgnl (Cerrors.explain_exn e); exit 1
+      end
+    | e -> begin msgnl (Cerrors.explain_exn e); exit 1 end
+
+
+(* To prevent from doing the initialization twice *)
+let initialized = ref false
+
+let init is_ide =
+  if not !initialized then begin
+    initialized := true;
+    Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
+    Lib.init();
+    try
+      parse_args is_ide;
+      re_exec is_ide;
+      if_verbose print_header ();
+      init_load_path ();
+      inputstate ();
+      engage ();
+      if not !batch_mode then Declaremods.start_library !toplevel_name;
+      init_library_roots ();
+      load_vernac_obj ();
+      require ();
+      load_rcfile();
+      load_vernacular ();
+      compile_files ();
+      outputstate ();
+    with e ->
+      flush_all();
+      if not !batch_mode then message "Error during initialization :";
+      msgnl (Toplevel.print_toplevel_error e);
+      exit 1
+  end;
+  if !batch_mode then (flush_all(); Profile.print_profile (); exit 0);
+  Lib.declare_initial_state ()
+
+let init_ide () = init true; List.rev !ide_args
+
+let start () =
+  init false;
+  Toplevel.loop();
+  (* Initialise and launch the Ocaml toplevel *)
+  Coqinit.init_ocaml_path();
+  Mltop.ocaml_toploop();
+  exit 1
+
+(* [Coqtop.start] will be called by the code produced by coqmktop *)
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
new file mode 100644
index 00000000..ef8b4b37
--- /dev/null
+++ b/toplevel/coqtop.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: coqtop.mli,v 1.5.4.1 2004/07/16 19:31:47 herbelin Exp $ i*)
+
+(* The Coq main module. The following function [start] will parse the
+   command line, print the banner, initialize the load path, load the input 
+   state, load the files given on the command line, load the ressource file,
+   produce the output state if any, and finally will launch [Toplevel.loop]. *)
+
+val start : unit -> unit
+
+(* [init_ide] is to be used by the Coq IDE. 
+   It does everything [start] does, except launching the toplevel loop. 
+   It returns the list of Coq files given on the command line. *)
+
+val init_ide : unit -> string list
+
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
new file mode 100644
index 00000000..688885b1
--- /dev/null
+++ b/toplevel/discharge.ml
@@ -0,0 +1,328 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: discharge.ml,v 1.81.2.1 2004/07/16 19:31:48 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Declarations
+open Entries
+open Inductive
+open Instantiate
+open Reduction
+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
+
+let recalc_kn dir kn = 
+  let (mp,_,l) = Names.repr_kn kn in
+    Names.make_kn mp dir l
+
+let rec find_var id = function
+  | [] -> false
+  | (x,b,_)::l -> if x = id then b=None else find_var id l
+
+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
+
+(* Discharge of inductives is done here (while discharge of constants 
+   is done by the kernel for efficiency). *)
+
+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)
+
+let process_inductive sec_sp osecsp nsecsp oldenv (ids_to_discard,modlist) mib =
+  assert (Array.length mib.mind_packets > 0);
+  let finite = mib.mind_finite 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,
+	  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_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)
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
new file mode 100644
index 00000000..c80b93ce
--- /dev/null
+++ b/toplevel/discharge.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: discharge.mli,v 1.6.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+
+open Names
+
+(* 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
diff --git a/toplevel/doc.tex b/toplevel/doc.tex
new file mode 100644
index 00000000..f2550fda
--- /dev/null
+++ b/toplevel/doc.tex
@@ -0,0 +1,10 @@
+
+\newpage
+\section*{The Coq toplevel}
+
+\ocwsection \label{toplevel}
+This chapter describes the highest modules of the \Coq\ system.
+They are organized as follows:
+
+\bigskip
+\begin{center}\epsfig{file=toplevel.dep.ps,width=\linewidth}\end{center}
diff --git a/toplevel/fhimsg.ml b/toplevel/fhimsg.ml
new file mode 100644
index 00000000..b5185cd3
--- /dev/null
+++ b/toplevel/fhimsg.ml
@@ -0,0 +1,362 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: fhimsg.ml,v 1.19.2.1 2004/07/16 19:31:48 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Type_errors
+open Reduction
+open G_minicoq
+
+module type Printer = sig
+  val pr_term : path_kind -> env -> constr -> std_ppcmds
+end
+
+module Make = functor (P : Printer) -> struct
+
+  let print_decl k env (s,typ) =
+    let ptyp = P.pr_term k env typ in 
+    (spc () ++ pr_id s ++ str" : " ++ ptyp)
+  
+  let print_binding k env = function
+    | Anonymous,ty -> 
+	(spc () ++ str"_" ++ str" : " ++ P.pr_term k env ty)
+    | Name id,ty -> 
+	(spc () ++ pr_id id ++ str" : " ++ P.pr_term k env ty)
+
+(****
+  let sign_it_with f sign e =
+    snd (fold_named_context
+	   (fun (id,v,t) (sign,e) -> (add_named_decl (id,v,t) sign, f id t sign e))
+           sign (empty_named_context,e))
+
+  let dbenv_it_with f env e =
+    snd (dbenv_it 
+	   (fun na t (env,e) -> (add_rel_decl (na,t) env, f na t env e))
+           env (gLOB(get_globals env),e))
+****)
+      
+  let pr_env k env =
+    let sign_env =
+      fold_named_context
+	(fun env (id,_,t) pps ->
+           let pidt =  print_decl k env (id,t) in (pps ++ fnl () ++ pidt))
+	env (mt ()) 
+    in
+    let db_env =
+      fold_rel_context
+	(fun env (na,_,t) pps ->
+           let pnat = print_binding k env (na,t) in (pps ++ fnl () ++ pnat))
+	env (mt ())
+    in 
+    (sign_env ++ db_env)
+    
+  let pr_ne_ctx header k env =
+    if rel_context env = [] && named_context env = [] then
+      (mt ())
+    else
+      (header ++ pr_env k env)
+
+
+let explain_unbound_rel k ctx n =
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  (str"Unbound reference: " ++ pe ++ fnl () ++
+     str"The reference " ++ int n ++ str" is free")
+
+let explain_not_type k ctx c =
+  let pe = pr_ne_ctx (str"In environment") k ctx in
+  let pc = P.pr_term k ctx c in
+  (pe ++ cut () ++ str "the term" ++ brk(1,1) ++ pc ++ spc () ++
+     str"should be typed by Set, Prop or Type.");;
+
+let explain_bad_assumption k ctx c =
+  let pc = P.pr_term k ctx c in
+  (str "Cannot declare a variable or hypothesis over the term" ++
+     brk(1,1) ++ pc ++ spc () ++ str "because this term is not a type.");;
+
+let explain_reference_variables id =
+  (str "the constant" ++ spc () ++ pr_id id ++ spc () ++ 
+     str "refers to variables which are not in the context")
+
+let msg_bad_elimination ctx k = function
+  | Some(ki,kp,explanation) ->
+      let pki = P.pr_term k ctx ki in
+      let pkp = P.pr_term k ctx kp 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))
+  | None -> 
+      (mt ())
+
+let explain_elim_arity k ctx ind aritylst c pj okinds = 
+  let pi = P.pr_term k ctx ind in
+  let ppar = prlist_with_sep pr_coma (P.pr_term k ctx) aritylst in
+  let pc = P.pr_term k ctx c in
+  let pp = P.pr_term k ctx pj.uj_val in
+  let ppt = P.pr_term k ctx pj.uj_type in
+  (str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++
+     str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++
+     str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++
+     str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++
+     str "It should be one of :" ++ brk(1,1) ++ hov 0 ppar ++ fnl () ++
+     msg_bad_elimination ctx k okinds)
+
+let explain_case_not_inductive k ctx cj =
+  let pc = P.pr_term k ctx cj.uj_val in
+  let pct = P.pr_term k ctx cj.uj_type in
+  (str "In Cases expression" ++ brk(1,1) ++ pc ++ spc () ++ 
+     str "has type" ++ brk(1,1) ++ pct ++ spc () ++ 
+     str "which is not an inductive definition")
+  
+let explain_number_branches k ctx cj expn =
+  let pc = P.pr_term k ctx cj.uj_val in
+  let pct = P.pr_term k ctx cj.uj_val in
+  (str "Cases on term" ++ brk(1,1) ++ pc ++ spc () ++
+     str "of type" ++ brk(1,1) ++ pct ++ spc () ++
+     str "expects " ++  int expn ++ str " branches")
+
+let explain_ill_formed_branch k ctx c i actty expty =
+  let pc = P.pr_term k ctx c in
+  let pa = P.pr_term k ctx actty in
+  let pe = P.pr_term k ctx expty in
+  (str "In Cases expression on term" ++ brk(1,1) ++ pc ++
+     spc () ++ str "the branch " ++ int (i+1) ++
+     str " has type" ++ brk(1,1) ++ pa ++ spc () ++ 
+     str "which should be:" ++ brk(1,1) ++ pe)
+
+let explain_generalization k ctx (name,var) c =
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pv = P.pr_term k ctx var in
+  let pc = P.pr_term k (push_rel (name,None,var) ctx) c in
+  (str"Illegal generalization: " ++ pe ++ fnl () ++
+     str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
+     str"over" ++ brk(1,1) ++ pc ++ spc () ++
+     str"which should be typed by Set, Prop or Type.")
+
+let explain_actual_type k ctx c ct pt =
+  let pe = pr_ne_ctx (str"In environment") k ctx in
+  let pc = P.pr_term k ctx c in
+  let pct = P.pr_term k ctx ct in
+  let pt = P.pr_term k ctx pt in
+  (pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pc ++ spc () ++
+     str"does not have type" ++ brk(1,1) ++ pt ++ fnl () ++
+     str"Actually, it has type" ++ brk(1,1) ++ pct)
+
+let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl =
+  let ctx = make_all_name_different ctx in
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pr = pr_term k ctx rator.uj_val in
+  let prt = pr_term k ctx rator.uj_type in
+  let term_string = if List.length randl > 1 then "terms" else "term" in
+  let many = match n mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc = pr_term k ctx c.uj_val in
+		  let pct = pr_term k ctx c.uj_type in
+		  hov 2 (pc ++ spc () ++ str": " ++ pct)) randl
+  in
+  (str"Illegal application (Type Error): " ++ pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+     str"of type" ++ brk(1,1) ++ prt ++ spc () ++
+     str("cannot be applied to the "^term_string) ++ fnl () ++ 
+     str" " ++ v 0 appl ++ fnl () ++
+     str"The " ++int n ++ str (many^" term of type ") ++
+     pr_term k ctx actualtyp ++
+     str" should be of type " ++ pr_term k ctx exptyp)
+
+let explain_cant_apply_not_functional k ctx rator randl =
+  let ctx = make_all_name_different ctx in
+  let pe = pr_ne_ctx (str"in environment") k ctx in
+  let pr = pr_term k ctx rator.uj_val in
+  let prt = pr_term k 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 = pr_term k ctx c.uj_val in
+		  let pct = pr_term k ctx c.uj_type in
+		  hov 2 (pc ++ spc () ++ str": " ++ pct)) randl
+  in
+  (str"Illegal application (Non-functional construction): " ++ pe ++ fnl () ++
+     str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+     str"of type" ++ brk(1,1) ++ prt ++ spc () ++
+     str("cannot be applied to the "^term_string) ++ fnl () ++ 
+     str" " ++ v 0 appl ++ fnl ())
+
+(* (co)fixpoints *)
+let explain_ill_formed_rec_body k ctx err names i vdefs =
+  let str = match err with
+
+  (* Fixpoint guard errors *)
+  | NotEnoughAbstractionInFixBody ->
+      (str "Not enough abstractions in the definition")
+  | RecursionNotOnInductiveType ->
+      (str "Recursive definition on a non inductive type")
+  | RecursionOnIllegalTerm ->
+      (str "Recursive call applied to an illegal term")
+  | NotEnoughArgumentsForFixCall ->
+      (str "Not enough arguments for the recursive call")
+
+  (* CoFixpoint guard errors *)
+  (* TODO : récupérer le contexte des termes pour pouvoir les afficher *)
+  | CodomainNotInductiveType c ->
+      (str "The codomain is" ++ spc () ++ P.pr_term k ctx c ++ spc () ++
+	 str "which should be a coinductive type")
+  | NestedRecursiveOccurrences ->
+      (str "Nested recursive occurrences")
+  | UnguardedRecursiveCall c ->
+      (str "Unguarded recursive call")
+  | RecCallInTypeOfAbstraction c ->
+      (str "Not allowed recursive call in the domain of an abstraction")
+  | RecCallInNonRecArgOfConstructor c ->
+      (str "Not allowed recursive call in a non-recursive argument of constructor")
+  | RecCallInTypeOfDef c ->
+      (str "Not allowed recursive call in the type of a recursive definition")
+  | RecCallInCaseFun c ->
+      (str "Not allowed recursive call in a branch of cases")
+  | RecCallInCaseArg c -> 
+      (str "Not allowed recursive call in the argument of cases")
+  | RecCallInCasePred c ->
+      (str "Not allowed recursive call in the type of cases in")
+  | NotGuardedForm c ->
+      str "Sub-expression " ++ prterm_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
+  let s =
+    match names.(i) with Name id -> string_of_id id | Anonymous -> "_" in
+  (str ++ fnl () ++ str"The " ++
+     if Array.length vdefs = 1 then (mt ()) else (int (i+1) ++ str "-th ") ++
+     str"recursive definition" ++ spc () ++ str s ++
+	 spc () ++ str":=" ++ spc () ++ pvd ++ spc () ++
+     str "is not well-formed")
+    
+let explain_ill_typed_rec_body k ctx i lna vdefj vargs =
+  let pvd = P.pr_term k ctx (vdefj.(i)).uj_val in
+  let pvdt = P.pr_term k ctx (vdefj.(i)).uj_type in
+  let pv = P.pr_term k 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 () ++
+     str "has type" ++ spc () ++ pvdt ++spc () ++ str "it should be" ++ spc () ++ pv)
+
+let explain_not_inductive k ctx c =
+  let pc = P.pr_term k ctx c in
+  (str"The term" ++ brk(1,1) ++ pc ++ spc () ++
+     str "is not an inductive definition")
+
+let explain_ml_case k ctx mes c ct br brt =
+  let pc = P.pr_term k ctx c in
+  let pct = P.pr_term k ctx ct in
+  let expln =
+    match mes with
+      | "Inductive" -> (pct ++ str "is not an inductive definition")
+      | "Predicate" -> (str "ML case not allowed on a predicate")
+      | "Absurd" -> (str "Ill-formed case expression on an empty type")
+      | "Decomp" ->
+          let plf = P.pr_term k ctx br in
+          let pft = P.pr_term k ctx brt in
+          (str "The branch " ++ plf ++ ws 1 ++ cut () ++ str "has type " ++ pft ++
+             ws 1 ++ cut () ++
+             str "does not correspond to the inductive definition")
+      | "Dependent" ->
+          (str "ML case not allowed for a dependent case elimination")
+      | _ -> (mt ())
+  in
+  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
+  | NotAType c -> 
+      explain_not_type k ctx c.uj_val
+  | BadAssumption c -> 
+      explain_bad_assumption k ctx c
+  | ReferenceVariables id -> 
+      explain_reference_variables id
+  | ElimArity (ind, aritylst, c, pj, okinds) ->
+      explain_elim_arity k ctx (mkMutInd ind) aritylst c pj okinds 
+  | CaseNotInductive cj -> 
+      explain_case_not_inductive k ctx cj
+  | NumberBranches (cj, n) -> 
+      explain_number_branches k ctx cj n
+  | IllFormedBranch (c, i, actty, expty) -> 
+      explain_ill_formed_branch k ctx c i actty expty 
+  | Generalization (nvar, c) ->
+      explain_generalization k ctx nvar c.uj_val
+  | ActualType (c, ct, pt) -> 
+      explain_actual_type k ctx c ct pt
+  | CantApplyBadType (s, rator, randl) ->
+      explain_cant_apply_bad_type k ctx s rator randl
+  | CantApplyNonFunctional (rator, randl) ->
+      explain_cant_apply_not_functional k ctx rator randl
+  | IllFormedRecBody (i, lna, vdefj, vargs) ->
+      explain_ill_formed_rec_body k ctx i lna vdefj vargs
+  | IllTypedRecBody (i, lna, vdefj, vargs) ->
+      explain_ill_typed_rec_body k ctx i lna vdefj vargs
+(*
+  | NotInductive c ->
+      explain_not_inductive k ctx c
+  | MLCase (mes,c,ct,br,brt) ->
+      explain_ml_case k ctx mes c ct br brt
+*)
+  | _ -> 
+      (str "Unknown type error (TODO)")
+
+let explain_refiner_bad_type k ctx arg ty conclty =
+  errorlabstrm "Logic.conv_leq_goal"
+    (str"refiner was given an argument" ++ brk(1,1) ++ 
+       P.pr_term k ctx arg ++ spc () ++
+       str"of type" ++ brk(1,1) ++ P.pr_term k ctx ty ++ spc () ++
+       str"instead of" ++ brk(1,1) ++ P.pr_term k ctx conclty)
+
+let explain_refiner_occur_meta k ctx t =
+  errorlabstrm "Logic.mk_refgoals"
+    (str"cannot refine with term" ++ brk(1,1) ++ P.pr_term k ctx t ++
+       spc () ++ str"because there are metavariables, and it is" ++
+       spc () ++ str"neither an application nor a Case")
+
+let explain_refiner_cannot_applt k ctx t harg =
+  errorlabstrm "Logic.mkARGGOALS"
+    (str"in refiner, a term of type " ++ brk(1,1) ++
+       P.pr_term k ctx t ++ spc () ++ str"could not be applied to" ++ brk(1,1) ++
+       P.pr_term k ctx harg)
+
+let explain_occur_check k ctx ev rhs =
+  let id = "?" ^ string_of_int ev in
+  let pt = P.pr_term k ctx rhs in
+  errorlabstrm "Trad.occur_check"
+    (str"Occur check failed: tried to define " ++ str id ++
+      str" with term" ++ brk(1,1) ++ pt)
+
+let explain_not_clean k ctx sp t =
+  let c = mkRel (Intset.choose (free_rels t)) in
+  let id = string_of_id (Names.basename sp) in
+  let var = P.pr_term k ctx c in
+  errorlabstrm "Trad.not_clean"
+    (str"Tried to define " ++ str id ++
+       str" with a term using variable " ++ var ++ spc () ++
+       str"which is not in its scope.")
+
+end
diff --git a/toplevel/fhimsg.mli b/toplevel/fhimsg.mli
new file mode 100644
index 00000000..10175e2a
--- /dev/null
+++ b/toplevel/fhimsg.mli
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: fhimsg.mli,v 1.8.16.1 2004/07/16 19:31:48 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Term
+open Sign
+open Environ
+open Type_errors
+(*i*)
+
+(* This module provides functions to explain the various typing errors.
+   It is parameterized by a function to pretty-print a term in a given
+   context. *)
+
+module type Printer = sig
+  val pr_term : path_kind -> env -> constr -> std_ppcmds
+end
+
+(*s The result is a module which provides a function [explain_type_error]
+  to explain a type error for a given kind in a given env, which are 
+  usually the three arguments carried by the exception [TypeError] 
+  (see \refsec{typeerrors}). *)
+
+module Make (P : Printer) : sig
+
+val explain_type_error : path_kind -> env -> type_error -> std_ppcmds
+
+val pr_ne_ctx : std_ppcmds -> path_kind -> env -> std_ppcmds
+
+val explain_unbound_rel : path_kind -> env -> int -> std_ppcmds
+
+val explain_not_type : path_kind -> env -> constr -> std_ppcmds
+
+val explain_bad_assumption : path_kind -> env -> constr -> std_ppcmds
+ 
+val explain_reference_variables : identifier -> std_ppcmds
+
+val explain_elim_arity : 
+  path_kind -> env -> constr -> constr list -> constr 
+    -> unsafe_judgment -> (constr * constr * string) option -> std_ppcmds
+
+val explain_case_not_inductive : 
+  path_kind -> env -> unsafe_judgment -> std_ppcmds
+
+val explain_number_branches : 
+  path_kind -> env -> unsafe_judgment -> int -> std_ppcmds
+
+val explain_ill_formed_branch :
+  path_kind -> env -> constr -> int -> constr -> constr -> std_ppcmds
+
+val explain_generalization :
+  path_kind -> env -> name * types -> constr -> std_ppcmds
+
+val explain_actual_type :
+  path_kind -> env -> constr -> constr -> constr -> std_ppcmds
+
+val explain_ill_formed_rec_body :
+  path_kind -> env -> guard_error -> 
+    name array -> int -> constr array -> std_ppcmds
+
+val explain_ill_typed_rec_body  :
+  path_kind -> env -> int -> name list -> unsafe_judgment array 
+    -> types array -> std_ppcmds
+
+end
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
new file mode 100644
index 00000000..de341bd9
--- /dev/null
+++ b/toplevel/himsg.ml
@@ -0,0 +1,665 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: himsg.ml,v 1.86.2.2 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Names
+open Nameops
+open Term
+open Termops
+open Inductive
+open Indtypes
+open Sign
+open Environ
+open Pretype_errors
+open Type_errors
+open Reduction
+open Cases
+open Logic
+open Printer
+open Ast
+open Rawterm
+
+let quote s = if !Options.v7 then s else 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 nth i =
+  let many = match i mod 10 with 1 -> "st" | 2 -> "nd" | _ -> "th" in
+  int i ++ str many
+
+let pr_db ctx i =
+  try
+    match lookup_rel i ctx with
+        Name id, _, _ -> pr_id id
+      | Anonymous, _, _ -> str"<>"
+  with Not_found -> str"UNBOUND_REL_"++int i
+
+let explain_unbound_rel ctx n =
+  let pe = pr_ne_context_of (str "In environment") ctx in
+  str"Unbound reference: " ++ pe ++
+  str"The reference " ++ int n ++ str " is free"
+
+let explain_unbound_var ctx v =
+  let var = pr_id v in
+  str"No such section variable or assumption : " ++ var
+
+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
+  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
+  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
+  str "the constant" ++ spc () ++ pc ++ spc () ++ 
+  str "refers to variables which are not in the context"
+
+let explain_elim_arity ctx ind aritylst c pj okinds = 
+  let ctx = make_all_name_different ctx in
+  let pi = pr_inductive ctx ind in
+  let ppar = prlist_with_sep pr_coma (prterm_env ctx) aritylst in
+  let pc = prterm_env ctx c in
+  let pp = prterm_env ctx pj.uj_val in
+  let ppt = prterm_env ctx pj.uj_type 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 explanation =	match explanation with
+	| NonInformativeToInformative ->
+	  "non-informative objects may not construct informative ones."
+	| StrongEliminationOnNonSmallType ->
+          "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))
+  | None -> 
+      mt ()
+  in
+  str "Incorrect elimination of" ++ brk(1,1) ++ pc ++ spc () ++
+  str "in the inductive type" ++ brk(1,1) ++ pi ++ fnl () ++
+  str "The elimination predicate" ++ brk(1,1) ++ pp ++ spc () ++
+  str "has type" ++ brk(1,1) ++ ppt ++ fnl () ++
+  str "It should be one of :" ++ brk(1,1)  ++ hov 0 ppar ++ 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
+    match kind_of_term cj.uj_type with
+      | Evar _ -> 
+	  str "Cannot infer a type for this expression"
+      | _ ->
+	  str "The term" ++ brk(1,1) ++ pc ++ spc () ++ 
+	  str "has type" ++ brk(1,1) ++ pct ++ spc () ++ 
+	  str "which is not a (co-)inductive type"
+
+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
+  str "Matching on term" ++ brk(1,1) ++ pc ++ spc ()  ++
+  str "of type" ++ brk(1,1) ++ pct ++ spc () ++
+  str "expects " ++  int expn ++ str " branches"
+
+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
+  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 () ++ 
+  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
+  str"Illegal generalization: " ++ pe ++
+  str"Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
+  str"over" ++ brk(1,1) ++ pc ++ str"," ++ spc () ++ 
+  str"it has type" ++ spc () ++ pt ++ 
+  spc () ++ str"which should be Set, Prop or Type."
+
+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
+  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 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 term_string1,term_string2 =
+    if List.length randl > 1 then
+      str "terms", (str"The "++nth n++str" term")
+    else
+      str "term", str "This term" in
+  let appl = prlist_with_sep pr_fnl 
+	       (fun c ->
+		  let pc,pct = prjudge_env ctx c in
+		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
+  in
+  str"Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++
+  str"The term" ++ brk(1,1) ++ pr ++ spc () ++
+  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
+
+let explain_cant_apply_not_functional ctx rator randl =
+  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 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
+		  hov 2 (pc ++ spc () ++ str": "  ++ pct)) randl
+  in
+  str"Illegal application (Non-functional construction): " ++ 
+  (* pe ++ *) fnl () ++
+  str"The expression" ++ brk(1,1) ++ pr ++ spc () ++
+  str"of type" ++ brk(1,1) ++ prt ++ spc ()  ++
+  str("cannot be applied to the "^term_string) ++ fnl () ++ 
+  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
+  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
+  str"The type of this term is a product," ++ spc () ++
+  str"but it is casted with type" ++
+  brk(1,1) ++ pr
+
+(* TODO: use the names *)
+(* (co)fixpoints *)
+let explain_ill_formed_rec_body ctx err names i =
+  let prt_name i =
+    match names.(i) with
+        Name id -> str "Recursive definition of " ++ pr_id id
+      | Anonymous -> str"The " ++ nth i ++ str" definition" in
+
+  let st = match err with
+
+  (* Fixpoint guard errors *)
+  | NotEnoughAbstractionInFixBody ->
+      str "Not enough abstractions in the definition"
+  | RecursionNotOnInductiveType ->
+      str "Recursive definition on a non inductive type"
+  | RecursionOnIllegalTerm(j,arg,le,lt) ->
+      let called =
+        match names.(j) with
+            Name id -> pr_id id
+          | Anonymous -> str"the " ++ nth i ++ str" definition" in
+      let vars =
+        match (lt,le) with
+            ([],[]) -> mt()
+          | ([],[x]) ->
+              str "a subterm of " ++ pr_db ctx x
+          | ([],_) ->
+              str "a subterm of the following variables: " ++
+              prlist_with_sep pr_spc (pr_db ctx) le
+          | ([x],_) -> pr_db ctx x
+          | _ ->
+              str "one of the following variables: " ++
+              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
+
+  | NotEnoughArgumentsForFixCall j ->
+      let called =
+        match names.(j) with
+            Name id -> pr_id id
+          | Anonymous -> str"the " ++ nth i ++ str" definition" in
+     str "Recursive call to " ++ called ++ str " had not enough arguments"
+
+  (* CoFixpoint guard errors *)
+  | CodomainNotInductiveType c ->
+      str "the codomain is" ++ spc () ++ prterm_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
+  | RecCallInTypeOfAbstraction c ->
+      str "recursive call forbidden in the domain of an abstraction:" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInNonRecArgOfConstructor c ->
+      str "recursive call on a non-recursive argument of constructor" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInTypeOfDef c ->
+      str "recursive call forbidden in the type of a recursive definition" ++
+      spc() ++ prterm_env ctx c
+  | RecCallInCaseFun c ->
+      str "recursive call in a branch of" ++ spc() ++ prterm_env ctx c
+  | RecCallInCaseArg c -> 
+      str "recursive call in the argument of cases in" ++ spc() ++
+      prterm_env ctx c
+  | RecCallInCasePred c ->
+      str "recursive call in the type of cases in" ++  spc() ++
+      prterm_env ctx c
+  | NotGuardedForm c ->
+      str "sub-expression " ++ prterm_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
+  prt_name i ++ str" is ill-formed." ++ fnl() ++
+  pr_ne_context_of (str "In environment") ctx ++
+  st
+
+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
+  str"The "  ++
+  (if Array.length vdefj = 1 then mt () else int (i+1) ++ str "-th") ++
+  str"recursive definition"  ++ spc () ++ pvd ++ spc () ++
+  str "has type" ++ spc () ++ pvdt ++spc () ++ 
+  str "it should be" ++ spc () ++ pv 
+(*
+let explain_not_inductive ctx c =
+  let ctx = make_all_name_different ctx in
+  let pc = prterm_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
+  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
+  str"Occur check failed: tried to define " ++ str id ++
+  str" with term" ++ brk(1,1) ++ pt
+
+let explain_hole_kind env = function
+  | QuestionMark -> str "a term for this placeholder"
+  | CasesType ->
+      str "the type of this pattern-matching problem"
+  | BinderType (Name id) ->
+      str "a type for " ++ Nameops.pr_id id
+  | BinderType Anonymous ->
+      str "a type for this anonymous binder"
+  | ImplicitArg (c,n) ->
+      if !Options.v7 then
+	str "the " ++ pr_ord n ++
+	str " implicit argument of " ++ Nametab.pr_global_env Idset.empty c
+      else
+	let imps = Impargs.implicits_of_global c in
+	let id = Impargs.name_of_implicit (List.nth imps (n-1)) 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) ->
+      str "the " ++ pr_ord n ++
+      str " argument of the inductive type (" ++ pr_inductive env tyi ++
+      str ") of this term"
+
+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
+  str"Tried to define " ++ explain_hole_kind ctx k ++
+  str" (" ++ str id ++ str ")" ++ spc() ++
+  str"with a term using variable " ++ var ++ spc () ++
+  str"which is not in its scope."
+
+let explain_unsolvable_implicit env k =
+  str "Cannot infer " ++ explain_hole_kind env k
+
+
+let explain_var_not_found ctx id = 
+  str "The variable" ++ spc () ++ str (string_of_id id) ++
+  spc ()  ++ str "was not found" ++ 
+  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
+  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
+    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_type_error ctx err =
+  let ctx = make_all_name_different ctx in
+  match err with
+  | UnboundRel n -> 
+      explain_unbound_rel ctx n
+  | UnboundVar v -> 
+      explain_unbound_var ctx v
+  | NotAType j -> 
+      explain_not_type ctx j
+  | BadAssumption c -> 
+      explain_bad_assumption ctx c
+  | ReferenceVariables id -> 
+      explain_reference_variables id
+  | ElimArity (ind, aritylst, c, pj, okinds) ->
+      explain_elim_arity ctx ind aritylst c pj okinds 
+  | CaseNotInductive cj -> 
+      explain_case_not_inductive ctx cj
+  | NumberBranches (cj, n) -> 
+      explain_number_branches ctx cj n
+  | IllFormedBranch (c, i, actty, expty) -> 
+      explain_ill_formed_branch ctx c i actty expty 
+  | Generalization (nvar, c) ->
+      explain_generalization ctx nvar c
+  | ActualType (j, pt) -> 
+      explain_actual_type ctx j pt
+  | CantApplyBadType (t, rator, randl) ->
+      explain_cant_apply_bad_type ctx t rator randl
+  | CantApplyNonFunctional (rator, randl) ->
+      explain_cant_apply_not_functional ctx rator randl
+  | IllFormedRecBody (err, lna, i) ->
+      explain_ill_formed_rec_body ctx err lna i
+  | IllTypedRecBody (i, lna, vdefj, vargs) -> 
+     explain_ill_typed_rec_body ctx i lna vdefj vargs
+  | WrongCaseInfo (ind,ci) ->
+      explain_wrong_case_info ctx ind ci
+(*
+  | NotInductive c ->
+      explain_not_inductive ctx c
+*)
+let explain_pretype_error ctx err =
+  let ctx = make_all_name_different ctx in
+  match err with
+  | CantFindCaseType c ->
+      explain_cant_find_case_type ctx c
+  | OccurCheck (n,c) ->
+      explain_occur_check ctx n c
+  | NotClean (n,c,k) ->
+      explain_not_clean ctx n c k
+  | UnsolvableImplicit k ->
+      explain_unsolvable_implicit ctx k
+  | VarNotFound id ->
+      explain_var_not_found ctx id
+  | UnexpectedType (actual,expected) ->
+      explain_unexpected_type ctx actual expected
+  | NotProduct c ->
+      explain_not_product ctx c
+
+(* 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
+
+let explain_refiner_occur_meta t =
+  str"cannot refine with term" ++ brk(1,1) ++ prterm 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 ++
+  spc () ++ str"has metavariables in it"
+
+let explain_refiner_cannot_applt 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
+
+let explain_refiner_not_well_typed c =
+  str"The term "  ++ prterm 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" ++ 
+  spc () ++ pr_id hyp
+
+let explain_non_linear_proof c =
+  str "cannot refine with term" ++ brk(1,1) ++ prterm 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
+  | 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
+  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
+  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
+  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
+
+let str_of_nth n =
+  (string_of_int n)^
+  (match n mod 10 with
+     | 1 -> "st"
+     | 2 -> "nd"
+     | 3 -> "rd"
+     | _ -> "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
+  str ("The "^(str_of_nth n)^" argument of ") ++ pv2 ++ brk(1,1) ++
+  str "must be " ++ pv1 ++ str " in" ++ brk(1,1) ++ pc
+
+let error_same_names_types id =
+  str "The name" ++ spc () ++ pr_id id ++ spc () ++ 
+  str "is used twice is the inductive types definition."
+
+let error_same_names_constructors id cid =
+  str "The constructor name" ++ spc () ++ pr_id cid ++ spc () ++ 
+  str "is used twice is the definition of type" ++ spc () ++
+  pr_id id
+
+let error_same_names_overlap idl = 
+  str "The following names" ++ spc () ++ 
+  str "are used both as type names and constructor names:" ++ spc () ++
+  prlist_with_sep pr_coma pr_id idl
+
+let error_not_an_arity id =
+  str "The type of" ++ spc () ++ pr_id id ++ spc () ++ str "is not an arity."
+
+let error_bad_entry () =
+  str "Bad inductive definition."
+
+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 "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 "is not allowed"
+
+let error_not_mutual_in_scheme () =
+ str "Induction schemes is concerned only with mutually inductive types"
+
+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
+  | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2
+  | SameNamesTypes id -> error_same_names_types id
+  | SameNamesConstructors (id,cid) -> error_same_names_constructors id cid
+  | SameNamesOverlap idl -> error_same_names_overlap idl
+  | NotAnArity id -> error_not_an_arity id
+  | BadEntry -> error_bad_entry ()
+  (* These are errors related to recursors *)
+  | NotAllowedCaseAnalysis (dep,k,i) ->
+      error_not_allowed_case_analysis dep k i
+  | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind
+  | NotMutualInScheme -> error_not_mutual_in_scheme ()
+
+(* Pattern-matching errors *)
+
+let explain_bad_pattern ctx cstr ty = 
+  let ctx = make_all_name_different ctx in
+  let pt = prterm_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) ++ 
+  str "which is not an inductive type"
+
+let explain_bad_constructor ctx cstr ind =
+  let pi = pr_inductive ctx ind in
+(*  let pc = pr_constructor ctx cstr in*)
+  let pt = pr_inductive ctx (inductive_of_constructor cstr) in
+  str "Found a constructor of inductive type " ++ pt ++ brk(1,1)  ++
+  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 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
+  str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++
+  str "should be of arity"  ++ spc () ++
+  prterm_env ctx nondep_arity  ++ spc () ++ 
+  str "(for non dependent case) or"  ++
+  spc () ++ prterm_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
+  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
+  (str ("Unused clause with pattern"^s) ++ spc () ++
+    hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")")
+*)
+  str "This clause is redundant"
+
+let explain_non_exhaustive env pats =
+  let s = if List.length pats > 1 then "s" else "" in
+  str ("Non exhaustive pattern-matching: no clause found for pattern"^s) ++
+  spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats)
+
+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
+  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))
+
+let explain_pattern_matching_error env = function
+  | BadPattern (c,t) -> 
+      explain_bad_pattern env c t
+  | BadConstructor (c,ind) ->
+      explain_bad_constructor env c ind
+  | WrongNumargConstructor (c,n) ->
+      explain_wrong_numarg_of_constructor env c n
+  | WrongPredicateArity (pred,n,dep) ->
+      explain_wrong_predicate_arity env pred n dep
+  | NeedsInversion (x,t) ->
+      explain_needs_inversion env x t
+  | UnusedClause tms ->
+      explain_unused_clause env tms
+  | NonExhaustive tms ->
+      explain_non_exhaustive env tms
+  | CannotInferPredicate typs ->
+      explain_cannot_infer_predicate env typs
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
new file mode 100644
index 00000000..3e7ba575
--- /dev/null
+++ b/toplevel/himsg.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: himsg.mli,v 1.13.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Names
+open Indtypes
+open Environ
+open Type_errors
+open Pretype_errors
+open Cases
+open Logic
+(*i*)
+
+(* This module provides functions to explain the type errors. *)
+
+val explain_type_error : env -> type_error -> std_ppcmds
+
+val explain_pretype_error : env -> pretype_error -> std_ppcmds
+
+val explain_inductive_error : inductive_error -> std_ppcmds
+
+val explain_refiner_error : refiner_error -> std_ppcmds
+
+val explain_pattern_matching_error :
+  env -> pattern_matching_error -> std_ppcmds
diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml
new file mode 100644
index 00000000..81221196
--- /dev/null
+++ b/toplevel/line_oriented_parser.ml
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: line_oriented_parser.ml,v 1.2.16.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+let line_oriented_channel_to_option stop_string input_channel =
+  let count = ref 0 in
+  let buff = ref "" in
+  let current_length = ref 0 in
+  fun i -> 
+    if (i - !count) >= !current_length then begin
+      count := !count + !current_length + 1;
+      buff := input_line input_channel;
+      if !buff = stop_string then
+        None
+      else begin
+        current_length := String.length !buff;
+        Some '\n'
+      end
+    end else
+      Some (String.get !buff (i - !count))
+
+let flush_until_end_of_stream char_stream =
+  Stream.iter (function _ -> ()) char_stream
diff --git a/toplevel/line_oriented_parser.mli b/toplevel/line_oriented_parser.mli
new file mode 100644
index 00000000..13af0e06
--- /dev/null
+++ b/toplevel/line_oriented_parser.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: line_oriented_parser.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+val line_oriented_channel_to_option: string -> in_channel -> int -> char option
+
+val flush_until_end_of_stream : 'a Stream.t -> unit
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
new file mode 100644
index 00000000..84bda0af
--- /dev/null
+++ b/toplevel/metasyntax.ml
@@ -0,0 +1,1428 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: metasyntax.ml,v 1.105.2.2 2004/07/16 19:31:49 herbelin Exp $ *)
+
+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
+
+(**********************************************************************)
+(* 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 *)
+
+let cache_token (_,s) = Pcoq.lexer.Token.using ("", s)
+
+let (inToken, outToken) =
+  declare_object {(default_object "TOKEN") with
+       open_function = (fun i o -> if i=1 then cache_token o);
+       cache_function = cache_token;
+       subst_function = Libobject.ident_subst_function;
+       classify_function = (fun (_,o) -> Substitute o);
+       export_function = (fun x -> Some x)}
+
+let add_token_obj s = Lib.add_anonymous_leaf (inToken s)
+
+(**********************************************************************)
+(* Grammars (especially 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
+  | 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 declare_pprule = function
+  (* Pretty-printing rules only for Grammar (Tactic Notation) *)
+  | Egrammar.TacticGrammar gl ->
+      let f (s,(s',l),tac) =
+        let pp = (make_tags l, (s',List.map make_terminal_status l)) in
+        Pptactic.declare_extra_tactic_pprule true s pp;
+        Pptactic.declare_extra_tactic_pprule false s pp in
+      List.iter f gl
+  | _ -> ()
+
+let cache_grammar (_,a) =
+  Egrammar.extend_grammar a;
+  declare_pprule a
+
+let subst_grammar (_,subst,a) =
+  Egrammar.subst_all_grammar_command subst a
+
+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;
+       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 locate_tactic_body dir (s,p,e) = (s,p,(dir,e))
+
+let add_tactic_grammar g =
+  let dir = Lib.cwd () in
+  let g = List.map (locate_tactic_body dir) g in
+  Lib.add_anonymous_leaf (inGrammar (Egrammar.TacticGrammar g))
+
+(* Printing grammar entries *)
+
+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"
+
+(* Parse a format (every terminal starting with a letter or a single
+   quote (except a single quote alone) must be quoted) *)
+
+let parse_format (loc,str) =
+  let str = " "^str in
+  let l = String.length str in
+  let push_token a = function
+    | cur::l -> (a::cur)::l
+    | [] -> [[a]] in
+  let push_white n l =
+    if n = 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
+  let close_box i b = function
+    | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
+    | _ -> error "Non terminated box in format" in
+  let close_quotation i =
+    if i < String.length str & str.[i] = '\'' & (i+1 = l or str.[i+1] = ' ')
+    then i+1
+    else error "Incorrectly terminated quoted expression" in
+  let rec spaces n i =
+    if i < String.length str & str.[i] = ' ' then spaces (n+1) (i+1)
+    else n in
+  let rec nonspaces quoted n i =
+    if i < String.length str & str.[i] <> ' ' then
+      if str.[i] = '\'' & quoted &
+        (i+1 >= String.length str or str.[i+1] = ' ')
+      then if n=0 then error "Empty quoted token" else n
+      else nonspaces quoted (n+1) (i+1)
+    else
+      if quoted then error "Spaces are not allowed in (quoted) symbols"
+      else n in
+  let rec parse_non_format i =
+    let n = nonspaces false 0 i in
+    push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n))
+  and parse_quoted n i =
+    if i < String.length str then match str.[i] with
+      (* Parse " // " *)
+      | '/' when i <= String.length str & str.[i+1] = '/' ->
+          (* We forget the useless n spaces... *)
+	  push_token (UnpCut PpFnl) 
+            (parse_token (close_quotation (i+2)))
+      (* Parse " .. / .. " *)
+      | '/' when i <= String.length str ->
+	  let p = spaces 0 (i+1) in
+	  push_token (UnpCut (PpBrk (n,p)))
+            (parse_token (close_quotation (i+p+1)))
+      | c ->
+      (* The spaces are real spaces *)
+      push_white n (match c with
+      | '[' ->
+	  if i <= String.length str then match str.[i+1] with
+	    (* Parse " [h .. ",  *)
+	    | 'h' when i+1 <= String.length str & str.[i+2] = 'v' ->
+		  (parse_box (fun n -> PpHVB n) (i+3))
+		(* Parse " [v .. ",  *)
+	    | 'v' ->
+		    parse_box (fun n -> PpVB n) (i+2)
+		(* Parse " [ .. ",  *)
+	    | ' ' | '\'' ->
+		parse_box (fun n -> PpHOVB n) (i+1)
+	    | _ -> error "\"v\", \"hv\", \" \" expected after \"[\" in format"
+	  else error "\"v\", \"hv\" or \" \" expected after \"[\" in format"
+      (* Parse "]"  *)
+      | ']' ->
+	  ([] :: parse_token (close_quotation (i+1)))
+      (* Parse a non formatting token *)
+      | c ->
+	  let n = nonspaces true 0 i in
+	  push_token (UnpTerminal (String.sub str (i-1) (n+2)))
+	    (parse_token (close_quotation (i+n))))
+    else
+      if n = 0 then []
+      else error "Ending spaces non part of a format annotation"
+  and parse_box box i =
+    let n = spaces 0 i in
+    close_box i (box n) (parse_token (close_quotation (i+n)))
+  and parse_token i =
+    let n = spaces 0 i in
+    let i = i+n in
+    if i < l then match str.[i] with
+      (* Parse a ' *)
+      |	'\'' when i+1 >= String.length str or str.[i+1] = ' ' ->
+	  push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1)))
+      (* Parse the beginning of a quoted expression *)
+      |	'\'' ->
+          parse_quoted (n-1) (i+1)
+      (* Otherwise *)
+      | _ ->
+          push_white (n-1) (parse_non_format i)
+    else push_white n [[]]
+  in
+  try
+    if str <> "" then match parse_token 0 with
+      | [l] -> l
+      | _ -> error "Box closed without being opened in format"
+    else
+      error "Empty format"
+  with e ->
+    Stdpp.raise_with_loc loc e
+
+(***********************)
+(* Analysing notations *)
+
+open Symbols
+
+type symbol_token = WhiteSpace of int | String of string
+
+let split_notation_string str =
+  let push_token beg i l =
+    if beg = i then l else
+      let s = String.sub str beg (i - beg) in
+      String s :: l 
+  in
+  let push_whitespace beg i l =
+    if beg = i then l else WhiteSpace (i-beg) :: l 
+  in
+  let rec loop beg i =
+    if i < String.length str then
+      if str.[i] = ' ' then
+	push_token beg i (loop_on_whitespace (i+1) (i+1))
+      else
+	loop beg (i+1)
+    else
+      push_token beg i []
+  and loop_on_whitespace beg i =
+    if i < String.length str then
+      if str.[i] <> ' ' then
+	push_whitespace beg i (loop i (i+1))
+      else
+	loop_on_whitespace beg (i+1)
+    else
+      push_whitespace beg i []
+  in
+  loop 0 0
+
+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
+
+let is_normal_token str =
+  try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false
+
+(* To protect alphabetic tokens and quotes from being seen as variables *)
+let quote_notation_token x =
+  let n = String.length x in
+  let norm = is_normal_token x in
+  if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'"
+  else x
+
+let rec raw_analyse_notation_tokens = function
+  | []    -> [], []
+  | String ".." :: sl ->
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      (list_add_set ldots_var vars, NonTerminal ldots_var :: l)
+  | String x :: sl when is_normal_token x ->
+      Lexer.check_ident x;
+      let id = Names.id_of_string x in
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      if List.mem id vars then
+	error ("Variable "^x^" occurs more than once");
+      (id::vars, NonTerminal id :: l)
+  | String s :: sl ->
+      Lexer.check_keyword s;
+      let (vars,l) = raw_analyse_notation_tokens sl in
+      (vars, Terminal (unquote_notation_token s) :: l)
+  | WhiteSpace n :: sl ->
+      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 analyse_notation_tokens l =
+  let vars,l = raw_analyse_notation_tokens l in
+  let recvars,l = interp_list_parser [] l in
+  ((if recvars = [] then [] else ldots_var::recvars), vars, l)
+
+let remove_vars = List.fold_right List.remove_assoc
+ 
+(* Build the syntax and grammar rules *)
+
+type printing_precedence = int * parenRelation
+type parsing_precedence = int option
+
+let prec_assoc = function
+  | Gramext.RightA -> (L,E)
+  | 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,InternalProd) -> n, Prec n
+  | ETConstr (NextLevel,_) -> from, L
+  | ETOther ("constr","annot") -> 10, Prec 10
+  | _ -> 0, E (* ?? *)
+
+(* Some breaking examples *)
+(* "x = y" : "x /1 = y" (breaks before any symbol) *)
+(* "x =S y" : "x /1 =S /1 y" (protect from confusion; each side for symmetry)*)
+(* "+ {" : "+ {" may breaks reversibility without space but oth. not elegant *)
+(* "x y" : "x spc y" *)
+(* "{ x } + { y }" : "{ x } / + { y }" *)
+(* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *)
+
+let is_left_bracket s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = '{' or s.[0] = '[' or s.[0] = '(')
+
+let is_right_bracket s =
+  let l = String.length s in l <> 0 &
+  (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')')
+
+let is_left_bracket_on_left s =
+  let l = String.length s in l <> 0 & s.[l-1] = '>'
+
+let is_right_bracket_on_right s =
+  let l = String.length s in l <> 0 & s.[0] = '<'
+
+let is_comma s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = ',' or s.[0] = ';')
+
+let is_operator s =
+  let l = String.length s in l <> 0 &
+  (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or
+   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 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"
+
+    | [] -> []
+
+  in make NoBreak symbols
+
+let add_break n l = UnpCut (PpBrk(n,0)) :: l
+
+let make_hunks etyps symbols from =
+  let vars,typs = List.split etyps in
+  let rec make ws = function
+    | NonTerminal m :: prods ->
+	let i = list_index m vars in
+	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+	let u = UnpMetaVar (i ,prec) 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 ->
+        if is_comma s then
+	  UnpTerminal s :: add_break 1 (make NoBreak prods)
+	else if is_right_bracket s then
+	  UnpTerminal s :: add_break 0 (make NoBreak prods)
+	else if is_left_bracket s then
+          if ws = CanBreak then
+	    add_break 1 (UnpTerminal s :: make CanBreak prods)
+	  else
+	    UnpTerminal s :: make CanBreak prods
+	else if is_operator s then
+	  if ws = CanBreak then
+	    UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods)
+	  else 
+	    UnpTerminal s :: add_break 1 (make NoBreak prods)
+	else if is_ident_tail s.[String.length s - 1] then
+	  if ws = CanBreak then
+	    add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
+	  else
+	    UnpTerminal (s^" ") :: make CanBreak prods
+	else if ws = CanBreak then
+	  add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
+	else
+	  UnpTerminal s :: make CanBreak prods
+
+    | Terminal s :: prods ->
+	if is_right_bracket s then
+	  UnpTerminal s ::make NoBreak prods
+        else if ws = CanBreak then
+	  add_break 1 (UnpTerminal s :: make NoBreak prods)
+        else
+          UnpTerminal s :: make NoBreak prods
+
+    | Break n :: prods ->
+	add_break n (make NoBreak prods)
+
+    | SProdList (m,sl) :: prods ->
+	let i = list_index m vars in
+	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+        (* We add NonTerminal for simulation but remove it afterwards *)
+        let _,sl' = list_sep_last (make NoBreak (sl@[NonTerminal m])) in
+	UnpListMetaVar (i,prec,sl') :: make CanBreak prods
+
+    | [] -> []
+
+  in make NoBreak symbols
+
+let hunks_of_format (from,(vars,typs) as vt) 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
+      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' ->
+      let i = list_index s vars in
+      let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+      let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
+  | symbs, UnpBox (a,b) :: fmt -> 
+      let symbs', b' = aux (symbs,b) in
+      let symbs', l = aux (symbs',fmt) in
+      symbs', UnpBox (a,b') :: l
+  | symbs, (UnpCut _ as u) :: fmt ->
+      let symbs, l = aux (symbs,fmt) in symbs, u :: l
+  | symbs, [] -> symbs, []
+  | _, _ -> error "The format does not match the notation"
+  in
+  match aux symfmt with
+  | [], l -> l
+  | _ -> error "The format does not match the notation"
+
+let string_of_prec (n,p) =
+  (string_of_int n)^(match p with E -> "E" | L -> "L" | _ -> "")
+
+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
+    NonTerm(_,Some(_,e)) as n1 :: Term("IDENT",k) :: l
+     when not !Options.v7 && 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
+  | [] -> []
+
+let define_keywords = function
+    Term("IDENT",k)::l when not !Options.v7 ->
+      prerr_endline ("Defining '"^k^"' as keyword");
+      Lexer.add_token("",k);
+      Term("",k) :: define_keywords l
+  | l -> define_keywords l
+
+let make_production etyps symbols =
+  let prod =
+    List.fold_right
+      (fun t l -> match t with
+        | NonTerminal m ->
+	    let typ = List.assoc m etyps in
+	    NonTerm (typ, Some (m,typ)) :: l
+        | Terminal s ->
+	    Term (Extend.terminal s) :: l
+        | Break _ ->
+            l
+        | SProdList (x,sl) ->
+            let sl = List.flatten
+              (List.map (function Terminal s -> [Extend.terminal s] 
+                | Break _ -> []
+                | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
+	    let y = match List.assoc x etyps with
+              | ETConstr x -> x
+              | _ ->
+                  error "Component of recursive patterns in notation must be constr" in
+            let typ = ETConstrList (y,sl) in
+            NonTerm (typ, Some (x,typ)) :: l)
+      symbols [] in
+  define_keywords prod
+
+let rec find_symbols c_current c_next c_last = function
+  | [] -> []
+  | NonTerminal id :: sl ->
+      let prec = if sl <> [] then c_current else c_last in
+      (id, prec) :: (find_symbols c_next c_next c_last sl)
+  | Terminal s :: sl -> find_symbols c_next c_next c_last sl
+  | Break n :: sl -> find_symbols c_current c_next c_last sl
+  | SProdList (x,_) :: sl' -> 
+      (x,c_next)::(find_symbols c_next c_next c_last sl')
+
+let border = function
+  | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a
+  | _ -> None
+
+let recompute_assoc typs =
+  match border typs, border (List.rev typs) with
+    | Some Gramext.LeftA, Some Gramext.RightA -> assert false
+    | Some Gramext.LeftA, _ -> Some Gramext.LeftA
+    | _, Some Gramext.RightA -> Some Gramext.RightA
+    | _ -> None
+
+let rec expand_squash = function
+  | Term ("","{") :: NonTerm (ETConstr _, n) :: Term ("","}") :: l ->
+      NonTerm (ETConstr (NextLevel,InternalProd),n)
+      :: expand_squash l
+  | a :: l -> a :: expand_squash l
+  | [] -> []
+
+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 *)
+
+let pr_arg_level from = function
+  | (n,L) when n=from -> str "at next level"
+  | (n,E) -> str "at level " ++ int n
+  | (n,L) -> str "at level below " ++ int n
+  | (n,Prec m) when m=n -> str "at level " ++ int n
+  | (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
+
+let cache_syntax_extension (_,(_,(prec,prec8),ntn,gr,se)) =
+  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 gr))
+    end
+  with Not_found ->
+    (* Reserve the notation level *)
+    Symbols.declare_notation_level ntn (prec,prec8);
+    (* Declare the parsing rule *)
+    option_iter (fun gr -> Egrammar.extend_grammar (Egrammar.Notation gr)) gr;
+    (* Declare the printing rule *)
+    Symbols.declare_notation_printing_rule ntn (se,fst prec8)
+
+let subst_notation_grammar 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 classify_syntax_definition (_,(local,_,_,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_syntax_definition (local,_,_,_,_ as o) =
+  if local then None else Some o
+
+let (inSyntaxExtension, outSyntaxExtension) =
+  declare_object {(default_object "SYNTAX-EXTENSION") with
+       open_function = (fun i o -> if i=1 then cache_syntax_extension o);
+       cache_function = cache_syntax_extension;
+       subst_function = subst_syntax_extension;
+       classify_function = classify_syntax_definition;
+       export_function = export_syntax_definition}
+
+let interp_modifiers =
+  let onlyparsing = ref false in
+  let rec interp assoc level etyps format = function
+    | [] ->
+	(assoc,level,etyps,!onlyparsing,format)
+    | 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
+    | 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)
+    | SetLevel n :: l ->
+	if level <> None then error "A level is given more than once"
+	else 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
+    | SetOnlyParsing :: l ->
+	onlyparsing := true;
+	interp assoc level etyps format l
+    | SetFormat s :: l ->
+	if format <> None then error "A format is given more than once"
+	onlyparsing := true;
+	interp assoc level etyps (Some s) l
+  in interp None None [] None
+
+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
+  if t <> [] then
+    error "explicit entry level or type unexpected in infix notation";
+  (assoc,level,b,fmt)
+
+(* 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
+
+let set_entry_type etyps (x,typ) =
+  let typ = try 
+    match List.assoc x etyps, typ with
+      | ETConstr (n,()), (_,BorderProd (left,_)) ->
+          ETConstr (n,BorderProd (left,None))
+      | ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
+      | (ETPattern | ETIdent | ETBigint | ETOther _ | ETReference as t), _ -> t
+      | (ETConstrList _, _) -> assert false
+    with Not_found -> ETConstr typ
+  in (x,typ)
+
+let check_rule_reversibility l = 
+  if List.for_all (function NonTerminal _ -> true | _ -> false) l then
+    error "A notation must include at least one symbol"
+
+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 :: _ ->
+      (try match List.assoc x etyps with
+	| ETConstr _ ->
+	    error "The level of the leftmost non-terminal cannot be changed"
+	| ETIdent | ETBigint | ETReference -> 
+	    if lev = None then 
+	      Options.if_verbose msgnl (str "Setting notation at level 0")
+	    else
+	    if lev <> Some 0 then
+	      error "A notation starting with an atomic expression must be at level 0";
+	    0
+	| ETPattern | ETOther _ -> (* Give a default ? *)
+	    if lev = None then
+	      error "Need an explicit level"
+	    else out_some lev
+        | ETConstrList _ -> assert false (* internally used in grammar only *)
+      with Not_found -> 
+	if lev = None then
+	  error "A left-recursive notation must have an explicit level"
+	else out_some lev)
+  | Terminal _ ::l when
+      (match list_last symbols with Terminal _ -> true |_ -> false)
+      -> 
+      if lev = None then
+	(Options.if_verbose msgnl (str "Setting notation at level 0"); 0)
+      else out_some lev
+  | _ ->
+      if lev = None then error "Cannot determine the level";
+      out_some lev
+
+let check_curly_brackets_notation_exists () =
+  try let _ = Symbols.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"
+
+(* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *)
+let remove_curly_brackets l = 
+  let rec next = function
+    | Break _ :: l -> next l
+    | l -> l in
+  let rec aux deb = function
+  | [] -> []
+  | Terminal "{" as t1 :: l -> 
+      (match next l with
+        | NonTerminal _ as x :: l' as l0 ->
+            (match next l' with
+              | Terminal "}" as t2 :: l'' as l1 ->
+                  if l <> l0 or l' <> l1 then
+                    warning "Skipping spaces inside curly brackets";
+                  if deb & l'' = [] then [t1;x;t2] else begin
+                    check_curly_brackets_notation_exists ();
+                    x :: aux false l''
+                  end
+              | l1 -> t1 :: x :: aux false l1)
+        | l0 -> t1 :: aux false l0)
+  | x :: l -> x :: aux false l
+  in aux true l
+
+let compute_syntax_data forv7 (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 typs =
+    find_symbols
+      (NumLevel n,BorderProd(true,assoc))
+      (innerlevel,InternalProd)
+      (NumLevel n,BorderProd(false,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))
+
+let add_syntax_extension local mv mv8 =
+  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
+  | 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
+    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))
+	
+(**********************************************************************)
+(* 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};
+    (* 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
+  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 classify_notation (_,(local,_,_,_,_,_,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_notation (local,_,_,_,_,_,_,_ as o) =
+  if local then None else Some o
+
+let (inNotation, outNotation) =
+  declare_object {(default_object "NOTATION") with
+       open_function = open_notation;
+       cache_function = cache_notation;
+       subst_function = subst_notation;
+       load_function = load_notation;
+       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 [])
+
+let contract_notation ntn =
+  if ntn = "{ _ }" then ntn else
+  let rec aux ntn i =
+    if i <= String.length ntn - 5 then
+      let ntn' =
+        if String.sub ntn i 5 = "{ _ }" then
+          String.sub ntn 0 i ^ "_" ^ 
+          String.sub ntn (i+5) (String.length ntn -i-5)
+        else ntn in
+      aux ntn' (i+1) 
+    else ntn in
+  aux ntn 0
+
+let add_notation_in_scope local df c mods omodv8 scope toks =
+  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 <> [] 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 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
+
+let check_notation_existence notation =
+  try
+    let a,_ = Symbols.level_of_notation (contract_notation notation) in
+    if a = None then raise Not_found
+  with Not_found ->
+    error "Parsing rule for this notation has to be previously declared"
+
+let exists_notation_syntax ntn =
+  try fst (Symbols.level_of_notation (contract_notation ntn)) <> None
+  with Not_found -> false
+
+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 =
+  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
+  Lib.add_anonymous_leaf
+    (inNotation(local,old_pp_rule,notation,scope,a,onlyparse,onlypp,
+     (Lib.library_dp(),df)))
+
+let add_notation_interpretation df names c sc =
+  let (recs,vars,symbs) = analyse_notation_tokens (split_notation_string df) in
+  check_notation_existence (make_notation_key symbs);
+  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
+  add_notation_interpretation_core false symbs for_oldpp df a sc false false
+
+let add_notation_in_scope_v8only local df c mv8 scope toks =
+  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 onlyparse = false in
+  let (acvars,ac) = interp_aconstr [] vars c in
+  let a = (remove_vars recs acvars,ac) (* For recursive parts *) in
+  Lib.add_anonymous_leaf
+    (inNotation(local,None,intnot,scope,a,onlyparse,true,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 toks
+    | _ ->
+	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 onlyparse = modifiers = [SetOnlyParsing] in
+                let (acvars,ac) = interp_aconstr [] vars c in
+                let a = (remove_vars recs acvars,ac) in
+		add_notation_interpretation_core local symbs None df a sc 
+		  onlyparse true
+	  | 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 toks
+
+let is_quoted_ident x =
+  let x' = unquote_notation_token x in
+  x <> x' & try Lexer.check_ident x'; true with _ -> false
+
+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 toks
+    | _ ->
+	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
+                if exists_notation_syntax (make_notation_key symbs) then
+		  let onlyparse = modifiers = [SetOnlyParsing] in
+                  let (acvars,ac) = interp_aconstr [] vars c in
+                  let a = (remove_vars recs acvars,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
+                else
+                  add_notation_in_scope local df c modifiers mv8 sc toks
+	  | 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 toks
+
+(* TODO add boxes information in the expression *)
+
+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
+    (split_notation_string df)
+
+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
+    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 toks
+  else begin
+  let (assoc,n,onlyparse,fmt) = interp_infix_modifiers modl in
+  (* 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 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
+    if exists_notation_syntax (make_notation_key symbs) 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
+    else
+      let mv,mv8 = make_infix_data n assoc modl mv8 in
+      add_notation_in_scope local df a mv mv8 sc toks
+  else
+    let mv,mv8 = make_infix_data n assoc modl mv8 in
+    add_notation_in_scope local df a mv mv8 sc toks
+  end
+
+let standardise_locatable_notation ntn =
+  let unquote = function
+    | String s -> [unquote_notation_token s]
+    | _ -> [] in
+  if String.contains ntn ' ' then
+    String.concat " " 
+      (List.flatten (List.map unquote (split_notation_string ntn)))
+  else
+    unquote_notation_token ntn
+
+(* 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
+
+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
+
+let cache_scope_command o =
+  load_scope_command 1 o;
+  open_scope_command 1 o
+
+let subst_scope_command (_,subst,(scope,o as x)) = match o with
+  | ScopeClasses cl -> 
+      let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else
+      scope, ScopeClasses cl'
+  | _ -> x
+
+let (inScopeCommand,outScopeCommand) = 
+  declare_object {(default_object "DELIMITERS") with
+      cache_function = cache_scope_command;
+      open_function = open_scope_command;
+      load_function = load_scope_command;
+      subst_function = subst_scope_command;
+      classify_function = (fun (_,obj) -> Substitute obj);
+      export_function = (fun x -> Some x) }
+
+let add_delimiters scope key =
+  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key))
+
+let add_class_scope scope cl = 
+  Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl))
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
new file mode 100644
index 00000000..be90cd7a
--- /dev/null
+++ b/toplevel/metasyntax.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: metasyntax.mli,v 1.26.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Libnames
+open Ppextend
+open Extend
+open Tacexpr
+open Vernacexpr
+open Symbols
+open Topconstr
+(*i*)
+
+(* Adding grammar and pretty-printing objects in the environment *)
+
+val add_syntax_obj : string -> raw_syntax_entry list -> unit
+
+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_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
+
+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
+
+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
+
+val print_grammar : string -> string -> unit
+
+val merge_modifiers : Gramext.g_assoc option -> int option -> 
+  syntax_modifier list -> syntax_modifier list
+
+val interp_infix_modifiers : syntax_modifier list ->
+  Gramext.g_assoc option * precedence option * bool * string located option
+
+val standardise_locatable_notation : string -> string
diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml
new file mode 100644
index 00000000..dcf3e307
--- /dev/null
+++ b/toplevel/minicoq.ml
@@ -0,0 +1,149 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: minicoq.ml,v 1.28.14.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Sign
+open Declarations
+open Inductive
+open Type_errors
+open Safe_typing
+open G_minicoq
+
+let (env : safe_environment ref) = ref empty_environment
+
+let locals () =
+  List.map (fun (id,b,t) -> (id, make_path [] id CCI))
+    (named_context !env)
+
+let lookup_named id =
+  let rec look n = function
+    | [] -> mkVar id
+    | (Name id')::_ when id = id' -> mkRel n
+    | _::r -> look (succ n) r
+  in
+  look 1
+
+let args sign = Array.of_list (instance_from_section_context sign)
+
+let rec globalize bv c = match kind_of_term c with
+  | Var id -> lookup_named id bv
+  | Const (sp, _) ->
+      let cb = lookup_constant sp !env in mkConst (sp, args cb.const_hyps)
+  | Ind (sp,_ as spi, _) ->
+      let mib = lookup_mind sp !env in mkMutInd (spi, args mib.mind_hyps)
+  | Construct ((sp,_),_ as spc, _) ->
+      let mib = lookup_mind sp !env in mkMutConstruct (spc, args mib.mind_hyps)
+  | _ -> map_constr_with_named_binders (fun na l -> na::l) globalize bv c
+
+let check c = 
+  let c = globalize [] c in
+  let (j,u) = safe_infer !env c in
+  let ty = j_type j in
+  let pty = pr_term CCI (env_of_safe_env !env) ty in
+  mSGNL (hov 0 (str"  :" ++ spc () ++ hov 0 pty ++ fnl ()))
+
+let definition id ty c =
+  let c = globalize [] c in
+  let ty = option_app (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;
+  mSGNL (hov 0 (pr_id id ++ spc () ++ str"is defined" ++ fnl ()))
+
+let parameter id t =
+  let t = globalize [] t in
+  let sp = make_path [] id CCI in
+  env := add_parameter sp t (locals()) !env;
+  mSGNL (hov 0 (str"parameter" ++ spc () ++ pr_id id ++ 
+		  spc () ++ str"is declared" ++ fnl ()))
+
+let variable id t =
+  let t = globalize [] t in
+  env := push_named_assum (id,t) !env;
+  mSGNL (hov 0 (str"variable" ++ spc () ++ pr_id id ++ 
+		  spc () ++ str"is declared" ++ fnl ()))
+
+let inductive par inds =
+  let nparams = List.length par in
+  let bvpar = List.rev (List.map (fun (id,_) -> Name id) par) in
+  let name_inds = List.map (fun (id,_,_) -> Name id) inds in
+  let bv = bvpar @  List.rev name_inds in
+  let npar = List.map (fun (id,c) -> (Name id, globalize [] c)) par in
+  let one_inductive (id,ar,cl) =
+    let cv = List.map (fun (_,c) -> prod_it (globalize bv c) npar) cl in
+    { mind_entry_nparams = nparams;
+      mind_entry_params = List.map (fun (id,c) -> (id, LocalAssum c)) par;
+      mind_entry_typename = id;
+      mind_entry_arity = prod_it (globalize bvpar ar) npar;
+      mind_entry_consnames = List.map fst cl;
+      mind_entry_lc = cv }
+  in
+  let inds = List.map one_inductive inds in
+  let mie = { 
+    mind_entry_finite = true;
+    mind_entry_inds = inds }
+  in
+  let sp =
+    let mi1 = List.hd inds in
+    make_path [] mi1.mind_entry_typename CCI in
+  env := add_mind sp mie (locals()) !env;
+  mSGNL (hov 0 (str"inductive type(s) are declared" ++ fnl ()))
+
+
+let execute = function
+  | Check c -> check c
+  | Definition (id, ty, c) -> definition id ty c
+  | Parameter (id, t) -> parameter id t
+  | Variable (id, t) -> variable id t
+  | Inductive (par,inds) -> inductive par inds
+
+let parse_file f =
+  let c = open_in f in
+  let cs = Stream.of_channel c in
+  try
+    while true do
+      let c = Grammar.Entry.parse command cs in execute c
+    done
+  with 
+    | End_of_file | Stdpp.Exc_located (_, End_of_file) -> close_in c; exit 0
+    | exn -> close_in c; raise exn
+
+module Explain = Fhimsg.Make(struct let pr_term = pr_term end)
+
+let rec explain_exn = function
+  | TypeError (k,ctx,te) -> 
+      mSGNL (hov 0 (str "type error:" ++ spc () ++ 
+		      Explain.explain_type_error k ctx te ++ fnl ()))
+  | Stdpp.Exc_located (_,exn) -> 
+      explain_exn exn
+  | exn -> 
+      mSGNL (hov 0 (str"error: " ++ str (Printexc.to_string exn) ++ fnl ()))
+
+let top () =
+  let cs = Stream.of_channel stdin in
+  while true do
+    try
+      let c = Grammar.Entry.parse command cs in execute c
+    with 
+      | End_of_file | Stdpp.Exc_located (_, End_of_file) -> exit 0
+      | exn -> explain_exn exn
+  done
+
+let main () =
+  if Array.length Sys.argv = 1 then
+    parse_file "test"
+  else
+    if Sys.argv.(1) = "-top" then top () else parse_file (Sys.argv.(1))
+
+let _ = Printexc.print main ()
+
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
new file mode 100644
index 00000000..4da23d42
--- /dev/null
+++ b/toplevel/mltop.ml4
@@ -0,0 +1,296 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: mltop.ml4,v 1.29.2.3 2004/07/17 13:00:15 herbelin Exp $ *)
+
+open Util
+open Pp
+open Options
+open System
+open Libobject
+open Library
+open System
+open Vernacinterp
+
+(* Code to hook Coq into the ML toplevel -- depends on having the
+   objective-caml compiler mostly visible. The functions implemented here are:
+   \begin{itemize}
+   \item [dir_ml_load name]: Loads the ML module fname from the current ML 
+     path. 
+   \item [dir_ml_use]: Directive #use of Ocaml toplevel
+   \item [add_ml_dir]: Directive #directory of Ocaml toplevel
+   \end{itemize}
+ 
+   How to build an ML module interface with these functions.
+   The idea is that the ML directory path is like the Coq directory
+   path.  So we can maintain the two in parallel.
+   In the same way, we can use the "ml_env" as a kind of ML
+   environment, which we freeze, unfreeze, and add things to just like
+   to the other environments.
+   Finally, we can create an object which is an ML module, and require
+   that the "caching" of the ML module cause the loading of the
+   associated ML file, if that file has not been yet loaded.  Of
+   course, the problem is how to record dependencies between ML
+   modules.
+   (I do not know of a solution to this problem, other than to
+   put all the needed names into the ML Module object.) *)
+
+(* 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
+
+(* If there is a toplevel under Coq *)
+type toplevel = { 
+  load_obj : string -> unit;
+  use_file : string -> unit;
+  add_dir  : string -> unit;
+  ml_loop  : unit -> unit }
+
+(* Determines the behaviour of Coq with respect to ML files (compiled 
+   or not) *)
+type kind_load =
+  | WithTop of toplevel
+  | WithoutTop
+  | Native
+
+(* Must be always initialized *)
+let load = ref Native
+
+(* Sets and initializes the kind of loading *)
+let set kload = load := kload
+let get () = !load
+
+(* Resets load *)
+let remove ()= load := Native
+
+(* Tests if an Ocaml toplevel runs under Coq *)
+let is_ocaml_top () =
+  match !load with
+    | WithTop _ -> true
+    |_ -> false
+
+(* Tests if we can load ML files *)
+let enable_load () =
+  match !load with
+    | WithTop _ | WithoutTop -> true
+    |_ -> false
+
+(* Runs the toplevel loop of Ocaml *)
+let ocaml_toploop () =
+  match !load with
+    | WithTop t -> Printexc.catch t.ml_loop ()
+    | _ -> ()
+
+(* Dynamic loading of .cmo/.cma *)
+let dir_ml_load s = 
+  match !load with
+    | WithTop t ->
+      (try t.load_obj s
+       with
+       | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u
+       | _ -> errorlabstrm "Mltop.load_object" [< str"Cannot link ml-object ";
+                str s; str" to Coq code." >])
+(* TO DO: .cma loading without toplevel *)
+    | WithoutTop ->
+      ifdef Byte then
+        let _,gname = where_in_path !coq_mlpath_copy s in
+        try
+          Dynlink.loadfile gname;
+	  Dynlink.add_interfaces 
+	    [(String.capitalize (Filename.chop_suffix
+				(Filename.basename gname) ".cmo"))] 
+	    [Filename.dirname gname]
+	with | Dynlink.Error a ->
+          errorlabstrm "Mltop.load_object" [< str (Dynlink.error_message a) >]
+      else () 
+    | Native ->
+	errorlabstrm "Mltop.no_load_object"
+          [< str"Loading of ML object file forbidden in a native Coq" >]
+
+(* Dynamic interpretation of .ml *)
+let dir_ml_use s =
+  match !load with
+    | WithTop t -> t.use_file s
+    | _ -> warning "Cannot access the ML compiler"
+
+(* Adds a path to the ML paths *)
+let add_ml_dir s =
+  match !load with
+    | WithTop t -> t.add_dir s; keep_copy_mlpath s
+    | WithoutTop -> keep_copy_mlpath s
+    | _ -> ()
+
+(* For Rec Add ML Path *)
+let add_rec_ml_dir dir = 
+  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir)
+
+(* Adding files to Coq and ML loadpath *)
+
+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)
+    end
+  else
+    msg_warning [< str ("Cannot open " ^ dir) >]
+
+let convert_string d =
+  try Names.id_of_string d
+  with _ -> 
+    if_verbose warning 
+      ("Directory "^d^" cannot be used as a Coq identifier (skipped)");
+    flush_all ();
+    failwith "caught"
+
+let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath =
+  let dirs = all_subdirs dir in
+  let prefix = Names.repr_dirpath coq_dirpath in
+  if dirs <> [] then
+    let convert_dirs (lp,cp) =
+      (lp,Names.make_dirpath
+            ((List.map convert_string (List.rev cp))@prefix)) in
+    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
+    end
+  else
+    msg_warning [< str ("Cannot open " ^ dir) >]
+
+(* convertit un nom quelconque en nom de fichier ou de module *) 
+let mod_of_name name =
+  let base =
+    if Filename.check_suffix name ".cmo" then
+      Filename.chop_suffix name ".cmo"
+    else 
+      name
+  in 
+  String.capitalize base
+
+let file_of_name name =
+  let bname = String.uncapitalize name in
+  let fname = make_suffix bname ".cmo" in
+  if (is_in_path !coq_mlpath_copy fname) then fname
+  else let fname=make_suffix bname ".cma" in
+  if (is_in_path !coq_mlpath_copy fname) then fname
+  else
+    errorlabstrm "Mltop.load_object"
+      [< str"File not found on loadpath : "; str (bname^".cm[oa]") >]
+
+(* TODO: supprimer ce hack, si possible *)
+(* Initialisation of ML modules that need the state (ex: tactics like
+ * natural, omega ...)
+ * Each module may add some inits (function of type unit -> unit).
+ * These inits are executed right after the initial state loading if the
+ * module is statically linked, or after the loading if it is required. *)
+
+let init_list = ref ([] : (unit -> unit) list)
+
+let add_init_with_state init_fun =
+  init_list := init_fun :: !init_list
+
+let init_with_state () =
+  List.iter (fun f -> f()) (List.rev !init_list); init_list := []
+
+
+(* [known_loaded_module] contains the names of the loaded ML modules
+ * (linked or loaded with load_object). It is used not to load a 
+ * module twice. It is NOT the list of ML modules Coq knows. *)
+
+type ml_module_object = { mnames : string list }
+
+let known_loaded_modules = ref Stringset.empty
+
+let add_known_module mname =
+  known_loaded_modules := Stringset.add mname !known_loaded_modules
+
+let module_is_known mname = Stringset.mem mname !known_loaded_modules
+
+let load_object mname fname=
+  dir_ml_load fname;
+  init_with_state();
+  add_known_module mname
+
+(* Summary of declared ML Modules *)
+
+(* List and not Stringset because order is important *)
+let loaded_modules = ref []
+let get_loaded_modules () = !loaded_modules
+let add_loaded_module md = loaded_modules := md :: !loaded_modules
+
+let orig_loaded_modules = ref !loaded_modules
+let init_ml_modules () = loaded_modules := !orig_loaded_modules
+
+let unfreeze_ml_modules x =
+  loaded_modules := [];
+  List.iter
+    (fun name ->
+       let mname = mod_of_name name in
+       if not (module_is_known mname) then
+         if enable_load() then
+           let fname = file_of_name mname in
+           load_object mname fname
+         else 
+	   errorlabstrm "Mltop.unfreeze_ml_modules"
+             [< str"Loading of ML object file forbidden in a native Coq" >];
+       add_loaded_module mname)
+    x
+
+let _ = 
+  Summary.declare_summary "ML-MODULES"
+    { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules()));
+      Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x);
+      Summary.init_function = (fun () -> init_ml_modules ());
+      Summary.survive_module = false;
+      Summary.survive_section = true }
+
+(* Same as restore_ml_modules, but verbosely *)
+
+let cache_ml_module_object (_,{mnames=mnames}) =
+  List.iter
+    (fun name ->
+       let mname = mod_of_name name in
+       if not (module_is_known mname) then
+         let fname = file_of_name mname in
+         begin 
+	   try 
+	     if_verbose 
+	       msg [< str"[Loading ML file "; str fname; str" ..." >];
+             load_object mname fname;
+             if_verbose msgnl [< str"done]" >]
+           with e -> 
+	     if_verbose msgnl [< str"failed]" >]; 
+	     raise e
+	 end;
+         add_loaded_module mname)
+    mnames
+
+let export_ml_module_object x = Some x
+					 
+let (inMLModule,outMLModule) =
+  declare_object {(default_object "ML-MODULE") with
+                    load_function = (fun _ -> cache_ml_module_object);
+                    cache_function = cache_ml_module_object;
+                    export_function = export_ml_module_object }
+
+let declare_ml_modules l =
+  Lib.add_anonymous_leaf (inMLModule {mnames=l})
+    
+let print_ml_path () =
+  let l = !coq_mlpath_copy in
+  ppnl [< str"ML Load Path:"; fnl (); str"  ";
+          hv 0 (prlist_with_sep pr_fnl pr_str l) >]
+
+	  (* Printing of loaded ML modules *)
+	  
+let print_ml_modules () =
+  let l = get_loaded_modules () in
+  pp [< str"Loaded ML Modules: " ; pr_vertical_list pr_str l >]
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
new file mode 100644
index 00000000..6ba8cd76
--- /dev/null
+++ b/toplevel/mltop.mli
@@ -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: mltop.mli,v 1.8.14.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(* If there is a toplevel under Coq, it is described by the following 
+   record. *)
+type toplevel = { 
+  load_obj : string -> unit;
+  use_file : string -> unit;
+  add_dir  : string -> unit;
+  ml_loop  : unit -> unit }
+
+(* Determines the behaviour of Coq with respect to ML files (compiled 
+   or not) *) 
+type kind_load=
+  | WithTop of toplevel
+  | WithoutTop
+  | Native
+
+(* Sets and initializes the kind of loading *)
+val set : kind_load -> unit
+val get : unit -> kind_load
+
+(* Resets the kind of loading *)
+val remove : unit -> unit
+
+(* Tests if an Ocaml toplevel runs under Coq *)
+val is_ocaml_top : unit -> bool
+
+(* Tests if we can load ML files *)
+val enable_load : unit -> bool
+
+(* Starts the Ocaml toplevel loop *)
+val ocaml_toploop : unit -> unit
+
+(* Dynamic loading of .cmo *)
+val dir_ml_load : string -> unit
+
+(* Dynamic interpretation of .ml *)
+val dir_ml_use : string -> unit
+
+(* Adds a path to the ML paths *)
+val add_ml_dir : string -> unit
+val add_rec_ml_dir : string -> unit
+
+(* Adds a path to the Coq and ML paths *)
+val add_path : unix_path:string -> coq_root:Names.dir_path -> unit
+val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit
+
+val add_init_with_state : (unit -> unit) -> unit
+val init_with_state : unit -> unit
+
+(* List of modules linked to the toplevel *)
+val add_known_module : string -> unit
+val module_is_known : string -> bool
+val load_object : string -> string -> unit
+
+(* Summary of Declared ML Modules *)
+val get_loaded_modules : unit -> string list
+val add_loaded_module : string -> unit
+val init_ml_modules : unit -> unit
+val unfreeze_ml_modules : string list -> unit
+
+type ml_module_object = { mnames: string list }
+val inMLModule : ml_module_object -> Libobject.obj
+val outMLModule : Libobject.obj -> ml_module_object
+
+val declare_ml_modules : string list -> unit
+val print_ml_path : unit -> unit
+
+val print_ml_modules : unit -> unit
diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml
new file mode 100644
index 00000000..c748a12d
--- /dev/null
+++ b/toplevel/protectedtoplevel.ml
@@ -0,0 +1,173 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: protectedtoplevel.ml,v 1.9.10.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Line_oriented_parser
+open Vernac
+
+(* The toplevel parsing loop we propose here is more robust to printing
+   errors.  The philosophy is that all commands should be individually wrapped
+   in predefined markers.  If there is a parsing error, everything down to
+   the closing marker will be discarded.  Also there is always an aknowledge
+   message associated to a wrapped command. *)
+
+
+(* It is also possible to have break signals sent by other programs.  However,
+   there are some operations that should not be interrupted, especially, those
+   operations that are outputing data.
+*)
+
+let break_happened = ref false
+
+(* Before outputing any data, output_results makes sure that no interrupt 
+   is going to disturb the process. *)
+let output_results_nl stream =
+    let _ = Sys.signal Sys.sigint
+       (Sys.Signal_handle(fun i -> break_happened := true;()))
+  in
+  msgnl stream
+
+let rearm_break () =
+  let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in 
+    ()
+
+let check_break () =
+  if !break_happened then begin
+    break_happened := false;
+    raise Sys.Break
+  end
+
+(* All commands are acknowledged. *)
+
+let global_request_id = ref 013
+
+let acknowledge_command_ref =
+   ref(fun request_id command_count opt_exn
+      -> (fnl () ++ str "acknowledge command number " ++
+           int request_id ++ fnl () ++ 
+         str "successfully executed " ++ int command_count ++ fnl () ++
+           str "error message" ++ fnl () ++
+         (match opt_exn with
+           Some e -> Cerrors.explain_exn e
+         | None -> (mt ())) ++ fnl () ++
+         str "E-n-d---M-e-s-s-a-g-e" ++ fnl ()))
+
+let set_acknowledge_command f =
+  acknowledge_command_ref := f
+
+let acknowledge_command request_id = !acknowledge_command_ref request_id
+
+(* The markers are chosen to be likely to be different from any existing text. *)
+
+let start_marker = ref "protected_loop_start_command"
+let end_marker = ref "protected_loop_end_command"
+let start_length = ref (String.length !start_marker)
+let start_marker_buffer = ref (String.make !start_length ' ')
+
+let set_start_marker s =
+  start_marker := s;
+  start_length := String.length s;
+  start_marker_buffer := String.make !start_length ' '
+    
+let set_end_marker s =
+  end_marker := s
+
+exception E_with_rank of int * exn
+
+let rec parse_one_command_group input_channel =
+  let count = ref 0 in
+  let this_line = input_line input_channel in
+  if (String.length this_line) >= !start_length then begin
+    String.blit this_line 0 !start_marker_buffer 0 !start_length;
+    if !start_marker_buffer = !start_marker then
+      let req_id_line = input_line input_channel in
+      	begin 
+	  (try
+            global_request_id := int_of_string req_id_line
+	  with
+            | e -> failwith ("could not parse the request identifier |"^
+                             req_id_line ^ "|")) ;
+	  let count_line = input_line input_channel in
+	    begin
+	      (try
+		count := int_of_string count_line
+	      with
+		| e -> failwith("could not parse the count|" ^ count_line
+				^ "|"));
+	      let stream_tail =
+	      	Stream.from
+		  (line_oriented_channel_to_option
+		     !end_marker input_channel) in
+	      	begin
+		  check_break();
+		  rearm_break();
+		  let rec execute_n_commands rank =
+		    if rank = !count then
+		      None
+		    else
+		      let first_cmd_status =
+                      	try 
+			  raw_do_vernac
+			    (Pcoq.Gram.parsable stream_tail);
+		      	None
+		      	with e -> Some(rank,e) in
+		      	match first_cmd_status with
+			    None ->
+			      execute_n_commands (rank + 1)
+			  | v -> v in
+		  let r = execute_n_commands 0 in
+		    (match r with
+			 None ->
+			   output_results_nl 
+			     (acknowledge_command
+			      	!global_request_id !count None)
+		       | Some(rank, e) ->
+			   (match e with 
+                    	      	DuringCommandInterp(a,e1) ->
+				  output_results_nl
+				    (acknowledge_command
+				       !global_request_id rank (Some e1))
+			      | e -> 
+				  output_results_nl
+				    (acknowledge_command
+				       !global_request_id rank (Some e))));
+		    rearm_break();
+		    flush_until_end_of_stream stream_tail
+	      	end
+	    end
+	end
+    else
+      parse_one_command_group input_channel
+  end else
+    parse_one_command_group input_channel
+
+let protected_loop input_chan =
+  let rec explain_and_restart e =
+    begin
+      output_results_nl(Cerrors.explain_exn e);
+      rearm_break();
+      looprec input_chan;
+    end
+  and looprec input_chan =
+    try 
+      while true do parse_one_command_group input_chan done
+    with
+      | Vernacexpr.Drop -> raise Vernacexpr.Drop
+      | Vernacexpr.Quit -> exit 0
+      | End_of_file -> exit 0
+      | DuringCommandInterp(loc, Vernacexpr.Quit) -> raise Vernacexpr.Quit
+      | DuringCommandInterp(loc, Vernacexpr.Drop) -> raise Vernacexpr.Drop
+      | DuringCommandInterp(loc, e) ->
+	  explain_and_restart e
+      | e -> explain_and_restart e in
+    begin
+      msgnl (str "Starting Centaur Specialized loop");
+      looprec input_chan
+    end
diff --git a/toplevel/protectedtoplevel.mli b/toplevel/protectedtoplevel.mli
new file mode 100644
index 00000000..b31afbf6
--- /dev/null
+++ b/toplevel/protectedtoplevel.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: protectedtoplevel.mli,v 1.5.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+(*i*)
+
+(* A protected toplevel (used in Pcoq). *)
+
+val break_happened : bool ref
+val global_request_id : int ref
+val output_results_nl : std_ppcmds -> unit
+val rearm_break : unit -> unit
+val check_break : unit -> unit
+val set_acknowledge_command : (int -> int -> exn option -> std_ppcmds) -> unit
+val set_start_marker : string -> unit
+val set_end_marker : string -> unit
+val parse_one_command_group : in_channel -> unit
+val protected_loop : in_channel -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
new file mode 100644
index 00000000..f703c067
--- /dev/null
+++ b/toplevel/record.ml
@@ -0,0 +1,236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: record.ml,v 1.52.2.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Libnames
+open Nameops
+open Term
+open Termops
+open Environ
+open Declarations
+open Entries
+open Declare
+open Nametab
+open Coqast
+open Constrintern
+open Command
+open Inductive
+open Safe_typing
+open Decl_kinds
+open Indtypes
+open Type_errors
+open Topconstr
+
+(********** definition d'un record (structure) **************)
+
+let interp_decl sigma env = function
+  | Vernacexpr.AssumExpr((_,id),t) -> (id,None,interp_type Evd.empty env t)
+  | Vernacexpr.DefExpr((_,id),c,t) ->
+      let c = match t with
+	| None -> c
+	| Some t -> mkCastC (c,t)
+      in
+      let j = judgment_of_rawconstr 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 env2,newfs =
+    List.fold_left
+      (fun (env,newfs) d ->
+         let decl = interp_decl Evd.empty env d in
+         (push_rel decl env, decl::newfs))
+      (env1,[]) fs
+  in
+  newps, newfs
+
+let degenerate_decl (na,b,t) =
+  let id = match na with
+    | Name id -> id
+    | Anonymous -> anomaly "Unnamed record variable" in 
+  match b with
+    | None -> (id, Entries.LocalAssum t)
+    | Some b -> (id, Entries.LocalDef b)
+
+type record_error =
+  | MissingProj of identifier * identifier list
+  | BadTypedProj of identifier * env * Type_errors.type_error
+
+let warning_or_error coe indsp err =
+  let st = match err with
+    | MissingProj (fi,projs) ->
+	let s,have = if List.length projs > 1 then "s","have" else "","has" in
+        (str(string_of_id fi) ++
+	   str" cannot be defined because the projection" ++ str s ++ spc () ++
+           prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ str "n't.")
+    | BadTypedProj (fi,ctx,te) ->
+	match te with
+	  | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) ->
+              (str (string_of_id fi) ++ 
+		str" cannot be defined because it is informative and " ++
+		Printer.pr_inductive (Global.env()) indsp ++
+		str " is not.")   
+	  | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) ->
+	      (str (string_of_id fi) ++ 
+		str" cannot be defined because it is large and " ++
+		Printer.pr_inductive (Global.env()) indsp ++
+		str " is not.")
+	  | _ -> 
+	      (str " cannot be defined because it is not typable")
+  in
+  if coe then errorlabstrm "structure" st;
+  Options.if_verbose ppnl (hov 0 (str"Warning: " ++ st))
+
+type field_status =
+  | NoProjection of name
+  | Projection of constr
+
+exception NotDefinable of record_error
+
+(* This replaces previous projection bodies in current projection *)
+(* Undefined projs are collected and, at least one undefined proj occurs *)
+(* in the body of current projection then the latter can not be defined *)
+(* [c] is defined in ctxt [[params;fields]] and [l] is an instance of *)
+(* [[fields]] defined in ctxt [[params;x:ind]] *)
+let subst_projection fid l c =
+  let lv = List.length l in
+  let bad_projs = ref [] in
+  let rec substrec depth c = match kind_of_term c with
+    | Rel k ->
+	(* We are in context [[params;fields;x:ind;...depth...]] *)
+        if k <= depth+1 then 
+	  c
+        else if k-depth-1 <= lv then
+	  match List.nth l (k-depth-2) with
+	    | Projection t -> lift depth t
+	    | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
+	    | NoProjection Anonymous -> assert false
+        else 
+	  mkRel (k-lv)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in
+  let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
+  let c'' = substrec 0 c' in
+  if !bad_projs <> [] then 
+    raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
+  c''
+
+(* We build projections *)
+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 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,_) =
+    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 ->
+            try
+              let ccl = subst_projection fid subst ti in
+	      let body = match optci with
+              | Some ci -> subst_projection fid subst ci
+              | None ->
+	        (* [ccl] is defined in context [params;x:rp] *)
+		(* [ccl'] is defined in context [params;x:rp;x:rp] *)
+		let ccl' = liftn 1 2 ccl in
+		let p = mkLambda (x, lift 1 rp, ccl') in
+		let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
+		let ci = Inductiveops.make_case_info env indsp
+		  LetStyle [| RegularPat |] in
+		mkCase (ci, p, mkRel 1, [|branch|]) in
+	      let proj =
+	        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) =
+	        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
+		  Options.if_verbose message (string_of_id fid ^" is defined");
+		  sp
+                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
+	        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)
+            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
+
+(* [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
+    | _ -> acc in
+  let allnames =  idstruc::(List.fold_left extract_name [] fs) in
+  if not (list_distinct allnames) then error "Two objects have the same name";
+  (* Now, younger decl in params and fields is on top *)
+  let params,fields = typecheck_params_and_fields ps fs in
+  let args = extended_rel_list (List.length fields) params in
+  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_arity = mkSort s;
+      mind_entry_consnames = [idbuild];
+      mind_entry_lc = [type_constructor] } in
+  let mie =
+    { 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 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)
diff --git a/toplevel/record.mli b/toplevel/record.mli
new file mode 100644
index 00000000..8eff2ed5
--- /dev/null
+++ b/toplevel/record.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: record.mli,v 1.16.2.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Vernacexpr
+open Topconstr
+(*i*)
+
+(* [declare_projections ref coers params fields] declare projections of
+   record [ref] (if allowed), and put them as coercions accordingly to
+   [coers]; it returns the absolute names of projections *)
+
+val declare_projections :
+  inductive -> bool list -> rel_context -> constant option list
+
+val definition_structure :
+  lident with_coercion * local_binder list *
+  (local_decl_expr with_coercion) list * identifier * sorts -> unit
diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml
new file mode 100755
index 00000000..d2a1e36e
--- /dev/null
+++ b/toplevel/recordobj.ml
@@ -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        *)
+(************************************************************************)
+
+(* $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
new file mode 100755
index 00000000..8ea39767
--- /dev/null
+++ b/toplevel/recordobj.mli
@@ -0,0 +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        *)
+(************************************************************************)
+
+(* $Id: recordobj.mli,v 1.7.6.1 2004/07/16 19:31:49 herbelin Exp $ *)
+
+val objdef_declare : Libnames.global_reference -> unit
+val add_object_hook : Tacexpr.declaration_hook
diff --git a/toplevel/searchisos.mli b/toplevel/searchisos.mli
new file mode 100644
index 00000000..f1ad7d5a
--- /dev/null
+++ b/toplevel/searchisos.mli
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: searchisos.mli,v 1.3.16.1 2004/07/16 19:31:49 herbelin Exp $ i*)
+
+val search_in_lib : bool ref
+val type_search : Term.constr -> unit
+val require_module2 : bool option -> string -> string option -> bool -> unit
+val upd_tbl_ind_one : unit -> unit
+val seetime : bool ref
+val load_leaf_entry : string -> Names.section_path * Libobject.obj -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
new file mode 100644
index 00000000..7fa80bcb
--- /dev/null
+++ b/toplevel/toplevel.ml
@@ -0,0 +1,326 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: toplevel.ml,v 1.22.2.2 2004/07/16 20:48:17 herbelin Exp $ *)
+
+open Pp
+open Util
+open Options
+open Cerrors
+open Vernac
+open Pcoq
+open Protectedtoplevel
+
+(* A buffer for the character read from a channel. We store the command
+ * entered to be able to report errors without pretty-printing. *)
+
+type input_buffer = { 
+  mutable prompt : unit -> string;
+  mutable str : string; (* buffer of already read characters *)
+  mutable len : int;    (* number of chars in the buffer *)
+  mutable bols : int list; (* offsets in str of begining of lines *)
+  mutable tokens : Gram.parsable; (* stream of tokens *)
+  mutable start : int } (* stream count of the first char of the buffer *)
+
+(* Double the size of the buffer. *)
+
+let resize_buffer ibuf =
+  let nstr = String.create (2 * String.length ibuf.str + 1) in
+  String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
+  ibuf.str <- nstr
+
+(* Delete all irrelevent lines of the input buffer. Keep the last line
+   in the buffer (useful when there are several commands on the same line. *)
+
+let resynch_buffer ibuf =
+  match ibuf.bols with
+    | ll::_ ->
+        let new_len = ibuf.len - ll in
+        String.blit ibuf.str ll ibuf.str 0 new_len;
+        ibuf.len <- new_len;
+        ibuf.bols <- [];
+        ibuf.start <- ibuf.start + ll
+    | _ -> ()
+
+(* 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
+    | [] -> ibuf.len == 0
+  in
+  if bol && not !print_emacs then msgerr (str (ibuf.prompt()));
+  try
+    let c = input_char ic in
+    if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols;
+    if ibuf.len == String.length ibuf.str then resize_buffer ibuf;
+    ibuf.str.[ibuf.len] <- c;
+    ibuf.len <- ibuf.len + 1;
+    Some c
+  with End_of_file -> 
+    None
+
+(* Reinitialize the char stream (after a Drop) *)
+
+let reset_input_buffer ic ibuf =
+  ibuf.str <- "";
+  ibuf.len <- 0;
+  ibuf.bols <- [];
+  ibuf.tokens <- Gram.parsable (Stream.from (prompt_char ic ibuf));
+  ibuf.start <- 0
+
+(* Functions to print underlined locations from an input buffer. *)
+
+(* Given a location, returns the list of locations of each line. The last
+   line is returned separately. It also checks the location bounds. *)
+
+let get_bols_of_loc ibuf (bp,ep) =
+  let add_line (b,e) lines =
+    if b < 0 or e < b then anomaly "Bad location";
+    match lines with
+      | ([],None) -> ([], Some (b,e))
+      | (fl,oe) -> ((b,e)::fl, oe) 
+  in
+  let rec lines_rec ba after = function
+    | []                  -> add_line (0,ba) after
+    | ll::_ when ll <= bp -> add_line (ll,ba) after
+    | ll::fl              ->
+        let nafter = if ll < ep then add_line (ll,ba) after else after in
+        lines_rec ll nafter fl 
+  in
+  let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in
+  (fl,out_some ll)
+
+let dotted_location (b,e) =
+  if e-b < 3 then 
+    ("", String.make (e-b) ' ')
+  else 
+    (String.make (e-b-1) '.', " ")
+
+let print_highlight_location ib loc =
+  let (bp,ep) = unloc loc in
+  let bp = bp - ib.start 
+  and ep = ep - ib.start in
+  let highlight_lines =
+    match get_bols_of_loc ib (bp,ep) with
+      | ([],(bl,el)) ->  
+	  (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++
+             str"> " ++ str(String.make (bp-bl) ' ') ++
+             str(String.make (ep-bp) '^'))
+      | ((b1,e1)::ml,(bn,en)) ->
+          let (d1,s1) = dotted_location (b1,bp) in
+          let (dn,sn) = dotted_location (ep,en) in
+          let l1 = (str"> " ++ str d1 ++ str s1 ++
+                      str(String.sub ib.str bp (e1-bp))) in
+          let li =
+            prlist (fun (bi,ei) ->
+                      (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in
+          let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++
+                      str sn ++ str dn) in 
+	  (l1 ++ li ++ ln)
+  in 
+  (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ fnl () ++
+     highlight_lines ++ fnl ())
+
+(* Functions to report located errors in a file. *)
+
+let print_location_in_file s inlibrary fname (bp,ep) =
+  let errstrm = (str"Error while reading " ++ str s ++ str" :" ++ fnl ()) in
+  if (bp,ep) = dummy_loc then 
+    (errstrm ++ str", unknown location." ++ fnl ())
+  else
+    if inlibrary then
+      (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++
+       str" characters " ++ Cerrors.print_loc (bp,ep) ++ fnl ())
+    else
+    let (bp,ep) = unloc (bp,ep) in
+    let ic = open_in fname in
+    let rec line_of_pos lin bol cnt =
+      if cnt < bp then
+        if input_char ic == '\n'
+        then line_of_pos (lin + 1) (cnt +1) (cnt+1)
+        else line_of_pos lin bol (cnt+1)
+      else (lin, bol)
+    in
+    try
+      let (line, bol) = line_of_pos 1 0 0 in
+      close_in ic;
+      (errstrm  ++ str"File " ++ str ("\""^fname^"\"") ++
+         str", line " ++ int line ++
+         str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol)) ++ fnl ())
+    with e -> (close_in ic; (errstrm ++ str", invalid location." ++ fnl ()))
+	
+let print_command_location ib dloc =
+  match dloc with
+    | Some (bp,ep) ->
+        (str"Error during interpretation of command:" ++ fnl () ++
+           str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ())
+    | None -> (mt ())
+
+let valid_loc dloc (b,e) =
+  (b,e) <> dummy_loc
+  & match dloc with
+    | Some (bd,ed) -> bd<=b & e<=ed
+    | _ -> true
+	  
+let valid_buffer_loc ib dloc (b,e) =
+  valid_loc dloc (b,e) & 
+  let (b,e) = unloc (b,e) in b-ib.start >= 0 & e-ib.start < ib.len & b<=e 
+
+(*s The Coq prompt is the name of the focused proof, if any, and "Coq"
+    otherwise. We trap all exceptions to prevent the error message printing
+    from cycling. *)
+let make_prompt () =
+  try
+    (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < "
+  with _ -> 
+    "Coq < "
+
+(* 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)))
+  in
+  { prompt = pr;
+    str = "";
+    len = 0;
+    bols = [];
+    tokens = Gram.parsable (Stream.of_list []);
+    start = 0 }
+
+let set_prompt prompt =
+  top_buffer.prompt
+  <- (fun () -> (prompt ()) ^ (emacs_str (String.make 1 (Char.chr 249))))
+
+(* Removes and prints the location of the error. The following exceptions
+   need not be located. *)
+let rec is_pervasive_exn = function
+  | Out_of_memory | Stack_overflow | Sys.Break -> true
+  | Error_in_file (_,_,e) -> is_pervasive_exn e
+  | Stdpp.Exc_located (_,e) -> is_pervasive_exn e
+  | DuringCommandInterp (_,e) -> is_pervasive_exn e
+  | _ -> false
+
+(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
+   May raise only the following exceptions: Drop and End_of_input,
+   meaning we get out of the Coq loop *)
+let print_toplevel_error exc =
+  let (dloc,exc) =
+    match exc with
+      | DuringCommandInterp (loc,ie) ->
+          if loc = dummy_loc then (None,ie) else (Some loc, ie)
+      | _ -> (None, exc) 
+  in
+  let (locstrm,exc) =
+    match exc with
+      | Stdpp.Exc_located (loc, ie) ->
+          if valid_buffer_loc top_buffer dloc loc then
+            (print_highlight_location top_buffer loc, ie)
+          else 
+	    ((mt ()) (* print_command_location top_buffer dloc *), ie)
+      | Error_in_file (s, (inlibrary, fname, loc), ie) ->
+          (print_location_in_file s inlibrary fname loc, ie)
+      | _ -> 
+	  ((mt ()) (* print_command_location top_buffer dloc *), exc)
+  in
+  match exc with
+    | End_of_input -> 
+	msgerrnl (mt ()); pp_flush(); exit 0
+    | Vernacexpr.Drop ->  (* Last chance *)
+        if Mltop.is_ocaml_top() then raise Vernacexpr.Drop;
+        (str"Error: There is no ML toplevel." ++ fnl ())
+    | Vernacexpr.ProtectedLoop ->
+	raise Vernacexpr.ProtectedLoop
+    | Vernacexpr.Quit -> 
+	raise Vernacexpr.Quit
+    | _ -> 
+	(if is_pervasive_exn exc then (mt ()) else locstrm) ++
+        Cerrors.explain_exn exc
+
+(* Read the input stream until a dot is encountered *)
+let parse_to_dot =
+  let rec dot st = match Stream.next st with
+    | ("", ".") -> ()
+    | ("EOI", "") -> raise End_of_input
+    | _ -> dot st
+  in 
+  Gram.Entry.of_parser "Coqtoplevel.dot" dot
+    
+(* We assume that when a lexer error occurs, at least one char was eaten *)
+let rec discard_to_dot () =
+  try 
+    Gram.Entry.parse parse_to_dot top_buffer.tokens
+  with Stdpp.Exc_located(_,Token.Error _) -> 
+    discard_to_dot()
+
+
+(* If the error occured while parsing, we read the input until a dot token
+ * in encountered. *)
+
+let process_error = function
+  | DuringCommandInterp _ as e -> e
+  | e ->
+      if is_pervasive_exn e then 
+	e
+      else 
+        try 
+	  discard_to_dot (); e 
+	with
+          | End_of_input -> End_of_input
+          | de -> if is_pervasive_exn de then de else e
+
+(* do_vernac reads and executes a toplevel phrase, and print error
+   messages when an exception is raised, except for the following:
+     Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
+           Otherwise, exit.
+     End_of_input: Ctrl-D was typed in, we will quit *)
+let do_vernac () =
+  msgerrnl (mt ());
+  if !print_emacs then msgerr (str (top_buffer.prompt()));
+  resynch_buffer top_buffer;
+  begin 
+    try 
+      raw_do_vernac top_buffer.tokens
+    with e -> 
+      msgnl (print_toplevel_error (process_error e)) 
+  end;
+  flush_all()
+
+(* coq and go read vernacular expressions until Drop is entered.
+ * Ctrl-C will raise the exception Break instead of aborting Coq.
+ * Here we catch the exceptions terminating the Coq loop, and decide
+ * if we really must quit.
+ * The boolean value is used to choose between a protected loop, which
+ * we think is more suited for communication with other programs, or
+ * plain communication. *)
+
+let rec coq_switch b =
+  Sys.catch_break true;
+  (* ensure we have a command separator object (DOT) so that the first
+     command can be reseted. *)
+  Lib.mark_end_of_command();
+  try
+    if b then begin
+      reset_input_buffer stdin top_buffer;
+      while true do do_vernac() done
+    end else
+      protected_loop stdin
+  with
+    | Vernacexpr.Drop -> ()
+    | Vernacexpr.ProtectedLoop -> 
+	Lib.declare_initial_state();
+	coq_switch false
+    | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0
+    | Vernacexpr.Quit -> exit 0
+    | e ->
+	msgerrnl (str"Anomaly. Please report.");
+	coq_switch b
+
+let loop () = coq_switch true
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
new file mode 100644
index 00000000..1b6b48d4
--- /dev/null
+++ b/toplevel/toplevel.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: toplevel.mli,v 1.6.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Pp
+open Pcoq
+(*i*)
+
+(* The Coq toplevel loop. *)
+
+(* A buffer for the character read from a channel. We store the command
+ * entered to be able to report errors without pretty-printing. *)
+
+type input_buffer = { 
+  mutable prompt : unit -> string;
+  mutable str : string; (* buffer of already read characters *)
+  mutable len : int;    (* number of chars in the buffer *)
+  mutable bols : int list; (* offsets in str of begining of lines *)
+  mutable tokens : Pcoq.Gram.parsable; (* stream of tokens *)
+  mutable start : int } (* stream count of the first char of the buffer *)
+
+(* The input buffer of stdin. *)
+
+val top_buffer : input_buffer
+val set_prompt : (unit -> string) -> unit
+
+(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
+  May raise only the following exceptions: [Drop] and [End_of_input],
+  meaning we get out of the Coq loop. *)
+
+val print_toplevel_error : exn -> std_ppcmds
+
+(* Parse and execute a vernac command. *)
+
+val do_vernac : unit -> unit
+
+(* Main entry point of Coq: read and execute vernac commands. *)
+
+val loop : unit -> unit
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
new file mode 100644
index 00000000..9fe8b280
--- /dev/null
+++ b/toplevel/usage.ml
@@ -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        *)
+(************************************************************************)
+
+(* $Id: usage.ml,v 1.15.2.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+let version () =
+  Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
+    Coq_config.version Coq_config.date;
+  Printf.printf "compiled on %s\n" Coq_config.compile_date;
+  exit 0
+
+(* print the usage of coqtop (or coqc) on channel co *)
+
+let print_usage_channel co command =
+  output_string co command;
+  output_string co "Coq options are:\n";
+  output_string co
+"  -I dir                 add directory dir in the include path
+  -include dir           (idem)
+  -R dir coqdir          recursively map physical dir to logical coqdir 
+  -src                   add source directories in the include path
+
+  -inputstate f          read state from file f.coq
+  -is f                  (idem)
+  -nois                  start with an empty state
+  -outputstate f         write state in file f.coq
+
+  -load-ml-object f      load ML object file f 
+  -load-ml-source f      load ML file f 
+  -load-vernac-source f  load Coq file f.v (Load f.)
+  -l f                   (idem) 
+  -load-vernac-source-verbose f  load Coq file f.v (Load Verbose f.)
+  -lv f			(idem)
+  -load-vernac-object f  load Coq object file f.vo
+  -require f             load Coq object file f.vo and import it (Require f.)
+  -compile f             compile Coq file f.v (implies -batch)
+  -compile-verbose f     verbosely compile Coq file f.v (implies -batch)
+
+  -opt                   run the native-code version of Coq or Coq_SearchIsos
+  -byte                  run the bytecode version of Coq or Coq_SearchIsos
+
+  -where                 print Coq's standard library location and exit
+  -v                     print Coq version and exit
+
+  -q                     skip loading of rcfile
+  -init-file f           set the rcfile to f
+  -user u                use the rcfile of user u
+  -batch                 batch mode (exits just after arguments parsing)
+  -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)
+  -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
+                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to
+                         stdout (if unset)
+"
+
+(* print the usage on standard error *)
+
+let print_usage = print_usage_channel stderr
+
+let print_usage_coqtop () =
+  print_usage "Usage: coqtop <options>\n\n"
+
+let print_usage_coqc () =
+  print_usage "Usage: coqc <options> <Coq options> file...\n
+options are:
+  -verbose  compile verbosely
+  -image f  specify an alternative executable for Coq
+  -t        keep temporary files\n\n"
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
new file mode 100644
index 00000000..16929d68
--- /dev/null
+++ b/toplevel/usage.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: usage.mli,v 1.5.16.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*s Prints the version number on the standard output and exits (with 0). *)
+
+val version : unit -> 'a
+
+(*s Prints the usage on the error output, preceeded by a user-provided message. *)
+val print_usage : string -> unit
+
+(*s Prints the usage on the error output. *)
+val print_usage_coqtop : unit -> unit
+val print_usage_coqc : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
new file mode 100644
index 00000000..a5716619
--- /dev/null
+++ b/toplevel/vernac.ml
@@ -0,0 +1,301 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernac.ml,v 1.59.2.3 2004/07/16 20:48:17 herbelin Exp $ *)
+
+(* Parsing of vernacular. *)
+
+open Pp
+open Lexer
+open Util
+open Options
+open System
+open Coqast
+open Vernacexpr
+open Vernacinterp
+open Ppvernacnew
+
+(* The functions in this module may raise (unexplainable!) exceptions.
+   Use the module Coqtoplevel, which catches these exceptions
+   (the exceptions are explained only at the toplevel). *)
+
+exception DuringCommandInterp of Util.loc * exn
+
+(* Specifies which file is read. The intermediate file names are
+   discarded here. The Drop exception becomes an error. We forget
+   if the error ocurred during interpretation or not *)
+
+let raise_with_file file exc =
+  let (cmdloc,re) =
+    match exc with
+      | DuringCommandInterp(loc,e) -> (loc,e)
+      | e -> (dummy_loc,e) 
+  in
+  let (inner,inex) =
+    match re with
+      | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc ->
+          ((b, f, loc), e)
+      | Stdpp.Exc_located (loc, e) when loc <> dummy_loc ->
+          ((false,file, loc), e)
+      | _ -> ((false,file,cmdloc), re)
+  in 
+  raise (Error_in_file (file, inner, disable_drop inex))
+
+let real_error = function
+  | Stdpp.Exc_located (_, e) -> e
+  | Error_in_file (_, _, e) -> e
+  | e -> e
+
+(* Opening and closing a channel. Open it twice when verbose: the first
+   channel is used to read the commands, and the second one to print them.
+   Note: we could use only one thanks to seek_in, but seeking on and on in
+   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 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
+  (in_chan, longfname, (po, verb_ch))
+
+let close_input in_chan (_,verb) =
+  try 
+    close_in in_chan;
+    match verb with
+      | Some verb_ch -> close_in verb_ch
+      | _ -> ()
+  with _ -> ()
+
+let verbose_phrase verbch loc =
+  let loc = unloc loc in
+  match verbch with
+    | Some ch ->
+	let len = snd loc - fst loc in
+	let s = String.create len in
+        seek_in ch (fst loc);
+        really_input ch s 0 len;
+        message s;
+        pp_flush()
+    | _ -> ()
+
+exception End_of_input
+  
+let parse_phrase (po, verbch) =
+  match Pcoq.Gram.Entry.parse Pcoq.main_entry po with
+    | Some (loc,_ as com) -> verbose_phrase verbch loc; com
+    | None -> raise End_of_input
+
+(* vernac parses the given stream, executes interpfun on the syntax tree it
+ * parses, and is verbose on "primitives" commands if verbosely is true *)
+
+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
+  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
+  if !translate_file then
+    msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc)))
+  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) ->
+        (* translator state *)
+        let ch = !chan_translate in
+        let cs = Lexer.com_state() in
+        let cl = !Pp.comments in
+        (* 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;
+
+    | VernacList l -> List.iter (fun (_,v) -> interp v) l
+
+    | VernacTime v ->
+	let tstart = System.get_time() in
+        if not !just_parsing then interp v;
+	let tend = System.get_time() in
+        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
+      interp com
+  with e -> 
+    Format.set_formatter_out_channel stdout;
+    Options.v7_only := false;
+    raise (DuringCommandInterp (loc, e))
+
+and vernac interpfun input =
+  vernac_com interpfun (parse_phrase input)
+
+and read_vernac_file verbosely s =
+  let interpfun =
+    if verbosely then 
+      Vernacentries.interp
+    else 
+      Options.silently Vernacentries.interp 
+  in
+  let (in_chan, fname, input) = open_file_twice_if verbosely s in
+  try
+    (* we go out of the following infinite loop when a End_of_input is
+     * raised, which means that we raised the end of the file being loaded *)
+    while true do vernac interpfun input; pp_flush () done
+  with e ->   (* whatever the exception *)
+    Format.set_formatter_out_channel stdout;
+    close_input in_chan input;    (* we must close the file first *)
+    match real_error e with
+      | End_of_input ->
+          if do_translate () then pr_new_syntax (make_loc (max_int,max_int)) None
+      | _ -> raise_with_file fname e
+
+(* raw_do_vernac : char Stream.t -> unit
+ * parses and executes one command of the vernacular char stream.
+ * Marks the end of the command in the lib_stk to make vernac undoing
+ * easier. *)
+
+let raw_do_vernac po =
+  vernac (States.with_heavy_rollback Vernacentries.interp) (po,None);
+  Lib.mark_end_of_command()
+
+(* XML output hooks *)
+let xml_start_library = ref (fun _ -> ())
+let xml_end_library = ref (fun _ -> ())
+
+let set_xml_start_library f = xml_start_library := f
+let set_xml_end_library f = xml_end_library := f
+
+(* Load a vernac file. Errors are annotated with file and location *)
+let load_vernac verb file =
+  chan_translate :=
+    if !Options.translate_file then open_out (file^"8") else stdout;
+  try 
+    read_vernac_file verb file;
+    if !Options.translate_file then close_out !chan_translate;
+  with e -> 
+    if !Options.translate_file then close_out !chan_translate;
+    raise_with_file file e
+
+(* Compile a vernac file (f is assumed without .v suffix) *)
+let compile verbosely f =
+  let ldir,long_f_dot_v = Library.start_library f in
+  if !dump then dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
+  if !Options.xml_export then !xml_start_library ();
+  let _ = load_vernac verbosely long_f_dot_v in
+  if Pfedit.get_all_proof_names () <> [] then
+    (message "Error: There are pending proofs"; exit 1);
+  if !Options.xml_export then !xml_end_library ();
+  Library.save_library_to ldir (long_f_dot_v ^ "o")
+
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
new file mode 100644
index 00000000..d8f4b247
--- /dev/null
+++ b/toplevel/vernac.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernac.mli,v 1.10.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(* Parsing of vernacular. *)
+
+(* Read a vernac command on the specified input (parse only).
+   Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
+
+val parse_phrase : Pcoq.Gram.parsable * in_channel option ->
+  Util.loc * Vernacexpr.vernac_expr
+
+(* Reads and executes vernac commands from a stream.
+   The boolean [just_parsing] disables interpretation of commands. *)
+
+exception DuringCommandInterp of Util.loc * exn
+exception End_of_input
+
+val just_parsing : bool ref
+val raw_do_vernac : Pcoq.Gram.parsable -> unit
+
+(* Set XML hooks *)
+val set_xml_start_library : (unit -> unit) -> unit
+val set_xml_end_library   : (unit -> unit) -> unit
+
+(* Load a vernac file, verbosely or not. Errors are annotated with file
+   and location *)
+
+val load_vernac : bool -> string -> unit
+
+
+(* Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
+
+val compile : bool -> string -> unit
+
+(* Interpret a vernac AST *)
+
+val vernac_com : 
+  (Vernacexpr.vernac_expr -> unit) ->
+  Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
new file mode 100644
index 00000000..1c6ad9a6
--- /dev/null
+++ b/toplevel/vernacentries.ml
@@ -0,0 +1,1240 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernacentries.ml,v 1.195.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(* Concrete syntax of the mathematical vernacular MV V2.6 *)
+
+open Pp
+open Util
+open Options
+open Names
+open Entries
+open Nameops
+open Term
+open Pfedit
+open Tacmach
+open Proof_trees
+open Constrintern
+open Prettyp
+open Printer
+open Tacinterp
+open Command
+open Goptions
+open Libnames
+open Nametab
+open Vernacexpr
+open Decl_kinds
+open Topconstr
+open Pretyping
+
+(* Pcoq hooks *)
+
+type pcoq_hook = {
+  start_proof : unit -> unit;
+  solve : int -> unit;
+  abort : string -> unit;
+  search : searchable -> dir_path list * bool -> unit;
+  print_name : reference -> unit;
+  print_check : Environ.unsafe_judgment -> unit;
+  print_eval : (constr -> constr) -> Environ.env -> constr_expr -> 
+    Environ.unsafe_judgment -> unit;
+  show_goal : int option -> unit
+}
+
+let pcoq = ref None
+let set_pcoq_hook f = pcoq := Some f
+
+(* Misc *)
+
+let cl_of_qualid = function
+  | FunClass -> Classops.CL_FUN
+  | SortClass -> Classops.CL_SORT
+  | RefClass r -> Class.class_of_ref (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
+  msgnl (str"LOC: " ++
+    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 ())
+      meta_types
+    ++ str"Proof: " ++ prterm (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 () ++
+         (match pf.Proof_type.ref with
+            | None -> (str"BY <rule>")
+            | Some(r,spfl) ->
+		(str"BY " ++ Refiner.pr_rule r ++ fnl () ++
+		 str"  " ++
+		   hov 0 (prlist_with_sep pr_fnl prgl
+			    (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)
+
+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))
+
+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)
+
+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 "" 
+
+(********************)
+(* "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
+  msgnl (Pp.t (str "Physical path:                                 " ++
+		 tab () ++ str "Logical Path:" ++ fnl () ++ 
+		 prlist_with_sep pr_fnl print_path_entry l))
+
+let print_modules () =
+  let opened = Library.opened_libraries ()
+  and loaded = Library.loaded_libraries () in
+  let loaded_opened = list_intersect loaded opened
+  and only_loaded = list_subtract loaded opened in
+  str"Loaded and imported library files: " ++ 
+  pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
+  str"Loaded and not imported library files: " ++
+  pr_vertical_list pr_dirpath only_loaded
+
+
+let print_module r =
+  let (loc,qid) = qualid_of_reference r in
+  try
+    let globdir = Nametab.locate_dir qid in
+      match globdir with
+	  DirModule (dirpath,(mp,_)) ->
+	    msgnl (Printmod.print_module (Printmod.printable_body dirpath) mp)
+	| _ -> raise Not_found
+  with
+      Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid)
+
+let print_modtype r = 
+  let (loc,qid) = qualid_of_reference r in
+  try
+    let kn = Nametab.locate_modtype qid in
+      msgnl (Printmod.print_modtype kn)
+  with
+      Not_found -> msgnl (str"Unknown Module Type " ++ pr_qualid qid)
+
+let dump_universes s =
+  let output = open_out s in
+  try
+    Univ.dump_universes output (Global.universes ());
+    close_out output;
+    msgnl (str ("Universes written to file \""^s^"\".")) 
+  with
+      e -> close_out output; raise e
+
+(*********************)
+(* "Locate" commands *)
+
+let locate_file f =
+  try
+    let _,file =
+      System.where_in_path (Library.get_load_path()) f in
+    msgnl (str file)
+  with Not_found -> 
+    msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++
+		  str"on loadpath"))
+
+let msg_found_library = function
+  | Library.LibLoaded, fulldir, file ->
+      msgnl(pr_dirpath fulldir ++ str " has been loaded from file" ++ fnl () ++
+      str file)
+  | Library.LibInPath, fulldir, file ->
+      msgnl(pr_dirpath fulldir ++ str " is bound to file " ++ str file)
+let msg_notfound_library loc qid = function
+  | Library.LibUnmappedDir ->
+      let dir = fst (repr_qualid qid) in
+      user_err_loc (loc,"locate_library",
+        str "Cannot find a physical path bound to logical path " ++
+           pr_dirpath dir ++ fnl ())
+  | Library.LibNotFound ->
+      msgnl (hov 0 
+	(str"Unable to locate library" ++ spc () ++ pr_qualid qid))
+  | e -> assert false
+
+let print_located_library r =
+  let (loc,qid) = qualid_of_reference r in
+  try msg_found_library (Library.locate_qualified_library qid)
+  with e -> msg_notfound_library loc qid e
+
+(**********)
+(* 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
+
+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_arguments_scope qid scl =
+  Symbols.declare_arguments_scope (global qid) scl
+
+let vernac_infix = Metasyntax.add_infix
+
+let vernac_distfix = Metasyntax.add_distfix
+
+let vernac_notation = Metasyntax.add_notation
+
+(***********)
+(* Gallina *)
+
+let start_proof_and_print idopt k t hook =
+  start_proof_com idopt k t hook;
+  print_subgoals ();
+  if !pcoq <> None then (out_some !pcoq).start_proof ()
+
+let vernac_definition (local,_ as k) id def hook =
+  match def with
+  | ProveBody (bl,t) ->   (* local binders, typ *)
+      if Lib.is_modtype () then
+	errorlabstrm "Vernacentries.VernacDefinition"
+	  (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
+  | DefineBody (bl,red_option,c,typ_opt) ->
+      let red_option = match red_option with
+        | None -> None
+        | Some r -> 
+	    let (evc,env)= Command.get_current_context () in
+	    Some (interp_redexp env evc r) in
+      declare_definition id k bl red_option c typ_opt hook
+
+let vernac_start_proof kind sopt (bl,t) lettop hook =
+  if not(refining ()) then
+    if lettop then
+      errorlabstrm "Vernacentries.StartProof"
+	(str "Let declarations can only be used in proof editing mode");
+  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
+
+let vernac_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
+
+  (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
+     the theories [??] *)
+
+let vernac_exact_proof c =
+  by (Tactics.exact_proof c); 
+  save_named true
+
+let vernac_assumption kind l =
+  List.iter (fun (is_coe,(idl,c)) -> declare_assumption idl is_coe kind [] c) l
+
+let vernac_inductive f indl = build_mutual indl f
+
+let vernac_fixpoint = build_recursive
+
+let vernac_cofixpoint = build_corecursive
+
+let vernac_scheme = build_scheme
+
+(**********************)
+(* Modules            *)
+
+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";
+
+  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 = 
+  (* 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
+	  id binders_ast mty_ast_o;
+	if_verbose message 
+	  ("Interactive Module "^ string_of_id id ^" started")
+	  
+    | 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")
+
+(* 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")
+
+  
+
+
+let vernac_declare_module_type id binders_ast mty_ast_o =
+  if Lib.sections_are_opened () then
+    error "Modules and Module Types are not allowed inside sections";
+  
+  match mty_ast_o with
+    | None ->
+	Declaremods.start_modtype Modintern.interp_modtype id binders_ast;
+	if_verbose message 
+	  ("Interactive Module Type "^ string_of_id id ^" started")
+	  
+    | Some base_mty ->
+	Declaremods.declare_modtype Modintern.interp_modtype 
+	  id binders_ast base_mty;
+	if_verbose message 
+	  ("Module Type "^ string_of_id id ^" is defined")
+
+
+let vernac_end_modtype id =
+  Declaremods.end_modtype id;
+  if_verbose message 
+    ("Module Type "^ string_of_id id ^" is defined")
+
+
+(**********************)
+(* Gallina extensions *)
+
+let vernac_record struc binders sort nameopt cfs =
+  let const = match nameopt with 
+    | None -> add_prefix "Build_" (snd (snd struc))
+    | Some (_,id) -> id in
+  let sigma = Evd.empty in
+  let env = Global.env() in
+  let s = interp_constr sigma env sort in
+  let s = Reductionops.whd_betadeltaiota env sigma s in
+  let s = match kind_of_term s with
+    | Sort s -> s
+    | _ -> user_err_loc
+        (constr_loc sort,"definition_structure", str "Sort expected") in
+  Record.definition_structure (struc,binders,cfs,const,s)
+
+  (* 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_end_segment id =
+  check_no_pending_proofs ();
+  try
+    match Lib.what_is_opened () with
+      | _,Lib.OpenedModule _ -> vernac_end_module 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;
+*)
+
+let vernac_canonical locqid =
+  Recordobj.objdef_declare (Nametab.global locqid)
+
+let locate_reference ref =
+  let (loc,qid) = qualid_of_reference ref in
+  try 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 Not_found
+  with Not_found ->
+    error_global_not_found_loc loc qid
+
+let vernac_coercion stre ref qids qidt =
+  let target = cl_of_qualid qidt in
+  let source = cl_of_qualid qids in
+  let ref' = locate_reference ref in
+  Class.try_add_new_coercion_with_target ref' stre source target;
+  if_verbose message ((string_of_reference ref) ^ " is now a coercion")
+
+let vernac_identity_coercion stre id qids qidt =
+  let target = cl_of_qualid qidt in
+  let source = cl_of_qualid qids in
+  Class.try_add_new_identity_coercion id stre source target
+
+
+(***********)
+(* Solving *)
+let vernac_solve n tcom b =
+  if not (refining ()) then
+    error "Unknown command of the non proof-editing mode";
+  begin
+    if b then 
+      solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ()))
+    else solve_nth n (Tacinterp.hide_interp tcom None)
+  end;
+  (* in case a strict subtree was completed, 
+     go back to the top of the prooftree *) 
+  if subtree_solved () then begin
+    Options.if_verbose msgnl (str "Subgoal proved");
+    make_focus 0;
+    reset_top_of_tree ()
+  end;
+  print_subgoals();
+  if !pcoq <> None then (out_some !pcoq).solve n
+
+  (* A command which should be a tactic. It has been
+     added by Christine to patch an error in the design of the proof
+     machine, and enables to instantiate existential variables when
+     there are no more goals to solve. It cannot be a tactic since 
+     all tactics fail if there are no further goals to prove. *)
+  
+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*)
+ 
+   
+(*****************************)
+(* 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
+
+let vernac_add_loadpath isrec pdir ldiropt =
+  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
+
+  (* 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_declare_ml_module l = Mltop.declare_ml_modules l
+
+let vernac_chdir = function
+  | None -> message (Sys.getcwd())
+  | Some s ->
+      begin
+	try Sys.chdir (System.glob s)
+	with Sys_error str -> warning ("Cd failed: " ^ str)
+      end;
+      if_verbose message (Sys.getcwd())
+
+
+(********************)
+(* State management *)
+
+let abort_refine f x =
+  if Pfedit.refining() then delete_all_proofs ();
+  f x
+  (* used to be: error "Must save or abort current goal first" *)
+
+let vernac_write_state file = abort_refine States.extern_state file
+
+let vernac_restore_state file = abort_refine States.intern_state file
+
+
+(*************)
+(* Resetting *)
+
+let vernac_reset_name id = abort_refine Lib.reset_name id
+
+let vernac_reset_initial () = abort_refine Lib.reset_initial ()
+
+let vernac_back n = Lib.back n
+
+
+(************)
+(* Commands *)
+
+let vernac_declare_tactic_definition = Tacinterp.add_tacdef
+
+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_reserve idl c =
+  let t = Constrintern.interp_type Evd.empty (Global.env()) c in
+  let t = Detyping.detype (false,Global.env()) [] [] t in
+  List.iter (fun id -> Reserve.declare_reserved_type id t) idl
+
+let make_silent_if_not_pcoq b =
+  if !pcoq <> None then 
+    error "Turning on/off silent flag is not supported in Centaur mode"
+  else make_silent b
+
+let _ =
+  declare_bool_option 
+    { optsync  = false;
+      optname  = "silent";
+      optkey   = (PrimaryTable "Silent");
+      optread  = is_silent;
+      optwrite = make_silent_if_not_pcoq }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "implicit arguments";
+      optkey   = (SecondaryTable ("Implicit","Arguments"));
+      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 *)
+      optname  = "strict implicit arguments";
+      optkey   = (SecondaryTable ("Strict",impargs));
+      optread  = Impargs.is_strict_implicit_args;
+      optwrite = Impargs.make_strict_implicit_args }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "contextual implicit arguments";
+      optkey   = (SecondaryTable ("Contextual",impargs));
+      optread  = Impargs.is_contextual_implicit_args;
+      optwrite = Impargs.make_contextual_implicit_args }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "coercion printing";
+      optkey   = (SecondaryTable ("Printing","Coercions"));
+      optread  = (fun () -> !Constrextern.print_coercions);
+      optwrite = (fun b ->  Constrextern.print_coercions := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "implicit arguments printing";
+      optkey   = (SecondaryTable ("Printing",impargs));
+      optread  = (fun () -> !Constrextern.print_implicits);
+      optwrite = (fun b ->  Constrextern.print_implicits := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "projection printing using dot notation";
+      optkey   = (SecondaryTable ("Printing","Projections"));
+      optread  = (fun () -> !Constrextern.print_projections);
+      optwrite = (fun b ->  Constrextern.print_projections := b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "notations printing";
+      optkey   = (SecondaryTable ("Printing",if !Options.v7 then "Symbols" else "Notations"));
+      optread  = (fun () -> not !Constrextern.print_no_symbol);
+      optwrite = (fun b ->  Constrextern.print_no_symbol := not b) }
+
+let _ =
+  declare_bool_option 
+    { optsync  = true;
+      optname  = "raw printing";
+      optkey   = (SecondaryTable ("Printing","All"));
+      optread  = (fun () -> !Options.raw_print);
+      optwrite = (fun b -> Options.raw_print := b) }
+
+let _ =
+  declare_int_option
+    { optsync=false;
+      optkey=PrimaryTable("Undo");
+      optname="the undo limit";
+      optread=Pfedit.get_undo;
+      optwrite=Pfedit.set_undo }
+
+let _ =
+  declare_int_option
+    { optsync=false;
+      optkey=SecondaryTable("Hyps","Limit");
+      optname="the hypotheses limit";
+      optread=Options.print_hyps_limit;
+      optwrite=Options.set_print_hyps_limit }
+
+let _ =
+  declare_int_option
+    { optsync=true;
+      optkey=SecondaryTable("Printing","Depth");
+      optname="the printing depth";
+      optread=Pp_control.get_depth_boxes;
+      optwrite=Pp_control.set_depth_boxes }
+
+let _ =
+  declare_int_option
+    { optsync=true;
+      optkey=SecondaryTable("Printing","Width");
+      optname="the printing width";
+      optread=Pp_control.get_margin;
+      optwrite=Pp_control.set_margin }
+
+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
+    | VarRef id ->
+	if opaq then Tacred.set_opaque_var id
+	else Tacred.set_transparent_var id
+    | _ -> error "cannot set an inductive type or a constructor as transparent"
+
+let vernac_set_option key = function
+  | StringValue s -> set_string_option_value key s
+  | IntValue n -> set_int_option_value key (Some n)
+  | BoolValue b -> set_bool_option_value key b
+
+let vernac_unset_option key =
+  try set_bool_option_value key false
+  with _ ->
+  set_int_option_value key None
+
+let vernac_add_option key lv =
+  let f = function
+    | StringRefValue s -> (get_string_table key)#add s
+    | QualidRefValue locqid -> (get_ref_table key)#add locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_remove_option key lv =
+  let f = function
+  | StringRefValue s -> (get_string_table key)#remove s
+  | QualidRefValue locqid -> (get_ref_table key)#remove locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_mem_option key lv =
+  let f = function
+  | StringRefValue s -> (get_string_table key)#mem s
+  | QualidRefValue locqid -> (get_ref_table key)#mem locqid
+  in
+  try List.iter f lv with Not_found -> error_undeclared_key key
+
+let vernac_print_option key =
+  try (get_ref_table key)#print
+  with Not_found ->
+  try (get_string_table key)#print
+  with Not_found ->
+  try print_option_value key
+  with Not_found -> error_undeclared_key key
+
+let get_current_context_of_args = function
+  | Some n -> get_goal_context n
+  | None -> get_current_context ()
+
+let vernac_check_may_eval redexp glopt rc =
+  let (evmap,env) = get_current_context_of_args glopt in
+  let c = interp_constr evmap env rc in
+  let j = Typeops.typing env c in
+  match redexp with
+    | None ->
+	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
+	if !pcoq <> None
+	then (out_some !pcoq).print_eval (redfun env evmap) env rc j
+	else msg (print_eval redfun env j)
+
+  (* The same but avoiding the current goal context if any *)
+let vernac_global_check c =
+  let evmap = Evd.empty in
+  let env = Global.env() in
+  let c = interp_constr evmap env c in
+  let senv = Global.safe_env() in
+  let j = Safe_typing.typing senv c in
+  msg (print_safe_judgment env j)
+
+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)
+  | PrintGrammar (uni,ent) -> Metasyntax.print_grammar uni ent
+  | PrintLoadPath -> (* For compatibility ? *) print_loadpath ()
+  | PrintModules -> msg (print_modules ())
+  | PrintModule qid -> print_module qid
+  | PrintModuleType qid -> print_modtype qid
+  | PrintMLLoadPath -> Mltop.print_ml_path ()
+  | PrintMLModules -> Mltop.print_ml_modules ()
+  | PrintName qid -> 
+      if !pcoq <> None then (out_some !pcoq).print_name qid
+      else msg (print_name qid)
+  | PrintOpaqueName qid -> msg (print_opaque_name qid)
+  | PrintGraph -> ppnl (Prettyp.print_graph())
+  | PrintClasses -> ppnl (Prettyp.print_classes())
+  | PrintCoercions -> ppnl (Prettyp.print_coercions())
+  | PrintCoercionPaths (cls,clt) ->
+      ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
+  | 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
+  | PrintHintDb -> Auto.print_searchtable ()
+  | PrintScopes ->
+      pp (Symbols.pr_scopes (Constrextern.without_symbols pr_rawterm))
+  | PrintScope s ->
+      pp (Symbols.pr_scope (Constrextern.without_symbols pr_rawterm) s)
+  | PrintVisibility s ->
+      pp (Symbols.pr_visibility (Constrextern.without_symbols pr_rawterm) s)
+  | PrintAbout qid -> msgnl (print_about qid)
+  | PrintImplicit qid -> msg (print_impargs qid)
+
+let global_module r =
+  let (loc,qid) = qualid_of_reference r in
+  try Nametab.full_name_module qid
+  with Not_found -> 
+    user_err_loc (loc, "global_module",
+      str "Module/section " ++ pr_qualid qid ++ str " not found")
+
+let interp_search_restriction = function
+  | SearchOutside l -> (List.map global_module l, true)
+  | SearchInside l -> (List.map global_module l, false)
+
+open Search
+
+let interp_search_about_item = function
+  | SearchRef qid -> GlobSearchRef (Nametab.global qid)
+  | SearchString s -> GlobSearchString s
+
+let vernac_search s r =
+  let r = interp_search_restriction r in
+  if !pcoq <> None then (out_some !pcoq).search s r else
+  match s with
+  | SearchPattern c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      Search.search_pattern pat r
+  | SearchRewrite c ->
+      let _,pat = interp_constrpattern Evd.empty (Global.env()) c in
+      Search.search_rewrite pat r
+  | SearchHead locqid ->
+      Search.search_by_head (Nametab.global locqid) r
+  | SearchAbout sl ->
+      Search.search_about (List.map interp_search_about_item sl) r
+
+let vernac_locate = function
+  | LocateTerm qid -> msgnl (print_located_qualid qid)
+  | LocateLibrary qid -> print_located_library qid
+  | LocateFile f -> locate_file f
+  | LocateNotation ntn ->
+      ppnl (Symbols.locate_notation (Constrextern.without_symbols pr_rawterm)
+	(Metasyntax.standardise_locatable_notation ntn))
+
+(********************)
+(* Proof management *)
+
+let vernac_goal = function
+  | None -> ()
+  | Some c ->
+      if not (refining()) then begin
+        let unnamed_kind = Lemma (* Arbitrary *) in
+        start_proof_com None (IsGlobal (Proof unnamed_kind)) c (fun _ _ ->());
+	print_subgoals ()
+      end else 
+	error "repeated Goal not permitted in refining mode"
+
+let vernac_abort = function
+  | None ->
+      delete_current_proof ();
+      if_verbose message "Current goal aborted";
+      if !pcoq <> None then (out_some !pcoq).abort ""
+  | Some id ->
+      delete_proof id;
+      let s = string_of_id (snd id) in
+      if_verbose message ("Goal "^s^" aborted");
+      if !pcoq <> None then (out_some !pcoq).abort s
+
+let vernac_abort_all () =
+  if refining() then begin
+    delete_all_proofs ();
+    message "Current goals aborted"
+  end else
+    error "No proof-editing in progress"
+
+let vernac_restart () = restart_proof(); print_subgoals ()
+
+  (* Proof switching *)
+
+let vernac_suspend = suspend_proof
+
+let vernac_resume = function
+  | None -> resume_last_proof ()
+  | Some id -> resume_proof id
+
+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 ()
+
+  (* Reset the focus to the top of the tree *)
+let vernac_unfocus () =
+  make_focus 0; reset_top_of_tree (); print_subgoals ()
+
+let vernac_go = function
+  | GoTo n -> Pfedit.traverse n;show_node()
+  | GoTop -> Pfedit.reset_top_of_tree ();show_node()
+  | GoNext -> Pfedit.traverse_next_unproven ();show_node()
+  | GoPrev -> Pfedit.traverse_prev_unproven ();show_node()
+
+let apply_subproof f occ =
+  let pts = get_pftreestate() in
+  let evc = evc_of_pftreestate pts in
+  let rec aux pts = function
+    | [] -> pts
+    | (n::l) -> aux (Tacmach.traverse n pts) occ in 
+  let pts = aux pts (occ@[-1]) in
+  let pf = proof_of_pftreestate pts in
+  f evc (Global.named_context()) pf
+
+let explain_proof occ =
+  msg (apply_subproof (Refiner.print_treescript true) occ)
+
+let explain_tree occ =
+  msg (apply_subproof Refiner.print_proof occ)
+
+let vernac_show = function
+  | ShowGoal nopt ->
+      if !pcoq <> None then (out_some !pcoq).show_goal nopt
+      else msg (match nopt with
+	| None -> pr_open_subgoals ()
+	| Some n -> pr_nth_open_subgoal n)
+  | ShowGoalImplicitly None ->
+      Constrextern.with_implicits msg (pr_open_subgoals ())
+  | ShowGoalImplicitly (Some n) ->
+      Constrextern.with_implicits msg (pr_nth_open_subgoal n)
+  | ShowProof -> show_proof ()
+  | ShowNode -> show_node ()
+  | ShowScript -> show_script ()
+  | ShowExistentials -> show_top_evars ()
+  | ShowTree -> show_prooftree ()
+  | ShowProofNames ->
+      msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names()))
+  | ShowIntros all -> show_intro all
+  | 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 (pfterm,_) = extract_open_pftreestate pts in
+  let message = 
+    try 
+      Inductiveops.control_only_guard (Evarutil.evar_env (goal_of_proof pf))
+	pfterm; 
+      (str "The condition holds up to here")
+    with UserError(_,s) -> 
+      (str ("Condition violated : ") ++s)
+  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
+  | 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
+
+  (* Gallina *)
+  | VernacDefinition (k,(_,id),d,f) -> vernac_definition k id d f
+  | VernacStartTheoremProof (k,(_,id),t,top,f) ->
+      vernac_start_proof k (Some id) t top f
+  | VernacEndProof e -> vernac_end_proof e
+  | 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
+  | 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
+  | VernacDeclareModuleType ((_,id),bl,mtyo) -> 
+      vernac_declare_module_type id bl mtyo
+
+  (* Gallina extensions *)
+  | VernacBeginSection (_,id) -> vernac_begin_section id
+
+  | VernacEndSegment (_,id) -> vernac_end_segment id
+
+  | VernacRecord (_,id,bl,s,idopt,fs) -> vernac_record id bl s idopt fs
+  | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl
+  | VernacImport (export,qidl) -> vernac_import export qidl
+  | VernacCanonical qid -> vernac_canonical qid
+  | VernacCoercion (str,r,s,t) -> vernac_coercion str r s t
+  | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t
+
+  (* Solving *)
+  | VernacSolve (n,tac,b) -> vernac_solve n tac b
+  | VernacSolveExistential (n,c) -> vernac_solve_existential n c
+
+  (* 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
+  | VernacRemoveLoadPath s -> vernac_remove_loadpath s
+  | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
+  | VernacDeclareMLModule l -> vernac_declare_ml_module l
+  | VernacChdir s -> vernac_chdir s
+
+  (* State management *)
+  | VernacWriteState s -> vernac_write_state s
+  | VernacRestoreState s -> vernac_restore_state s
+
+  (* Resetting *)
+  | VernacResetName id -> vernac_reset_name id
+  | VernacResetInitial -> vernac_reset_initial ()
+  | VernacBack n -> vernac_back 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
+  | 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
+  | VernacUnsetOption key -> vernac_unset_option key
+  | VernacRemoveOption (key,v) -> vernac_remove_option key v
+  | VernacAddOption (key,v) -> vernac_add_option key v
+  | VernacMemOption (key,v) -> vernac_mem_option key v
+  | VernacPrintOption key -> vernac_print_option key
+  | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
+  | VernacGlobalCheck c -> vernac_global_check c
+  | VernacPrint p -> vernac_print p
+  | VernacSearch (s,r) -> vernac_search s r
+  | VernacLocate l -> vernac_locate l
+  | VernacComments l -> if_verbose message ("Comments ok\n")
+  | VernacNop -> ()
+
+  (* Proof management *)
+  | VernacGoal t -> vernac_start_proof Theorem None ([],t) false (fun _ _ ->())
+  | VernacAbort id -> vernac_abort id
+  | VernacAbortAll -> vernac_abort_all ()
+  | VernacRestart -> vernac_restart ()
+  | VernacSuspend -> vernac_suspend ()
+  | VernacResume id -> vernac_resume id
+  | VernacUndo n -> vernac_undo n
+  | 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
+
+  (* Extensions *)
+  | VernacExtend (opn,args) -> Vernacinterp.call (opn,args)
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
new file mode 100644
index 00000000..a359b4a1
--- /dev/null
+++ b/toplevel/vernacentries.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernacentries.mli,v 1.16.2.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Vernacinterp
+open Vernacexpr
+open Topconstr
+(*i*)
+
+(* Vernacular entries *)
+
+val show_script : unit -> unit
+val show_prooftree : unit -> unit
+
+val show_node : unit -> unit
+
+(* This function can be used by any command that want to observe terms
+   in the context of the current goal, as for instance in pcoq *)
+val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
+
+(* this function is used to analyse the extra arguments in search commands.
+   It is used in pcoq. *) (*i anciennement: inside_outside i*)
+(*
+val interp_search_restriction : search_restriction -> dir_path list * bool
+*)
+
+type pcoq_hook = {
+  start_proof : unit -> unit;
+  solve : int -> unit;
+  abort : string -> unit;
+  search : searchable -> dir_path list * bool -> unit;
+  print_name : Libnames.reference -> unit;
+  print_check : Environ.unsafe_judgment -> unit;
+  print_eval : (constr -> constr) -> Environ.env -> constr_expr -> Environ.unsafe_judgment -> unit;
+  show_goal : int option -> unit
+}
+
+val set_pcoq_hook : pcoq_hook -> unit
+
+(* This function makes sure that the function given is argument is preceded
+   by a command aborting all proofs if necessary.
+   It is used in pcoq. *)
+val abort_refine : ('a -> unit) -> 'a -> unit;;
+
+val interp : Vernacexpr.vernac_expr -> unit
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
new file mode 100644
index 00000000..e1525c17
--- /dev/null
+++ b/toplevel/vernacexpr.ml
@@ -0,0 +1,293 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernacexpr.ml,v 1.55.2.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+open Util
+open Names
+open Tacexpr
+open Extend
+open Genarg
+open Topconstr
+open Decl_kinds
+open Ppextend
+
+(* Toplevel control exceptions *)
+exception ProtectedLoop
+exception Drop
+exception Quit
+
+open Libnames
+open Nametab
+
+type lident = identifier located
+type lname = name located
+type lstring = string
+type lreference = reference
+
+type class_rawexpr = FunClass | SortClass | RefClass of reference
+  
+type printable =
+  | PrintTables
+  | PrintLocalContext
+  | PrintFullContext
+  | PrintSectionContext of reference
+  | PrintInspect of int
+  | PrintGrammar of string * string
+  | PrintLoadPath
+  | PrintModules
+  | PrintModule of reference
+  | PrintModuleType of reference
+  | PrintMLLoadPath
+  | PrintMLModules
+  | PrintName of reference
+  | PrintOpaqueName of reference
+  | PrintGraph
+  | PrintClasses
+  | PrintCoercions
+  | PrintCoercionPaths of class_rawexpr * class_rawexpr
+  | PrintUniverses of string option
+  | PrintHint of reference
+  | PrintHintGoal
+  | PrintHintDbName of string
+  | PrintHintDb
+  | PrintScopes
+  | PrintScope of string
+  | PrintVisibility of string option
+  | PrintAbout of reference
+  | PrintImplicit of reference
+
+type search_about_item =
+  | SearchRef of reference
+  | SearchString of string
+
+type searchable =
+  | SearchPattern of pattern_expr
+  | SearchRewrite of pattern_expr
+  | SearchHead of reference
+  | SearchAbout of search_about_item list
+
+type locatable =
+  | LocateTerm of reference
+  | LocateLibrary of reference
+  | LocateFile of string
+  | LocateNotation of notation
+
+type goable =
+  | GoTo of int
+  | GoTop
+  | GoNext
+  | GoPrev
+
+type showable =
+  | ShowGoal of int option
+  | ShowGoalImplicitly of int option
+  | ShowProof
+  | ShowNode
+  | ShowScript
+  | ShowExistentials
+  | ShowTree
+  | ShowProofNames
+  | ShowIntros of bool
+  | ExplainProof of int list
+  | ExplainTree of int list
+
+type comment =
+  | CommentConstr of constr_expr
+  | CommentString of string
+  | 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
+  | HintsDestruct of identifier *
+      int * (bool,unit) location * constr_expr * raw_tactic_expr
+
+type search_restriction =
+  | SearchInside of reference list
+  | SearchOutside of reference list
+
+type option_value =
+  | StringValue of string
+  | IntValue of int
+  | BoolValue of bool
+
+type option_ref_value =
+  | StringRefValue of string
+  | QualidRefValue of reference
+
+type rec_flag       = bool (* true = Rec;           false = NoRec          *)
+type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
+type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
+type locality_flag  = bool (* true = Local;         false = Global         *)
+type coercion_flag  = bool (* true = AddCoercion;   false = NoCoercion     *)
+type export_flag    = bool (* true = Export;        false = Import         *)
+type specif_flag    = bool (* true = Specification; false = Implementation *)
+type inductive_flag = bool (* true = Inductive;     false = CoInductive    *)
+type onlyparsing_flag = bool (* true = Parse only;  false = Print also     *)
+
+type sort_expr = Rawterm.rawsort
+
+type decl_notation = (string * constr_expr * scope_name option) option
+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
+type definition_expr =
+  | ProveBody of local_binder list * constr_expr
+  | DefineBody of local_binder list * raw_red_expr option * constr_expr
+      * constr_expr option
+
+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 proof_end =
+  | Admitted
+  | Proved of opacity_flag * (lident * theorem_kind option) option
+
+type vernac_expr =
+  (* Control *)
+  | VernacList of located_vernac_expr list
+  | VernacLoad of verbose_flag * lstring
+  | VernacTime of 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
+  | 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
+  | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
+      lreference * (lstring * syntax_modifier list) option * scope_name option
+  | VernacNotation of
+      locality_flag * constr_expr * (lstring * syntax_modifier list) option *
+      (lstring * syntax_modifier list) option * scope_name option
+
+  (* Gallina *)
+  | VernacDefinition of definition_kind * lident * definition_expr * 
+      declaration_hook
+  | VernacStartTheoremProof of theorem_kind * lident *
+      (local_binder list * constr_expr) * bool * declaration_hook
+  | 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
+  | VernacScheme of (lident * bool * lreference * sort_expr) list
+
+  (* Gallina extensions *)
+  | VernacRecord of bool (* = Record or Structure *)
+      * lident with_coercion * local_binder list
+      * constr_expr * lident option * local_decl_expr with_coercion list
+  | VernacBeginSection of lident
+  | VernacEndSegment of lident
+  | VernacRequire of
+      export_flag option * specif_flag option * lreference list
+  | VernacImport of export_flag * lreference list
+  | VernacCanonical of lreference
+  | VernacCoercion of strength * lreference * class_rawexpr * class_rawexpr
+  | VernacIdentityCoercion of strength * lident * 
+      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 * 
+      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
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom of export_flag option * specif_flag option * lstring
+  | VernacAddLoadPath of rec_flag * lstring * dir_path option
+  | VernacRemoveLoadPath of lstring
+  | VernacAddMLPath of rec_flag * lstring
+  | VernacDeclareMLModule of lstring list
+  | VernacChdir of lstring option
+
+  (* State management *)
+  | VernacWriteState of lstring
+  | VernacRestoreState of lstring
+
+  (* Resetting *)
+  | VernacResetName of lident
+  | VernacResetInitial
+  | VernacBack of int
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition of
+      rec_flag * (lident * raw_tactic_expr) list
+  | VernacHints of locality_flag * lstring list * hints
+  | VernacSyntacticDefinition of identifier * constr_expr * locality_flag *
+      onlyparsing_flag
+  | VernacDeclareImplicits of lreference * explicitation list option
+  | VernacReserve of lident list * constr_expr
+  | VernacSetOpacity of opacity_flag * lreference list
+  | VernacUnsetOption of Goptions.option_name
+  | VernacSetOption of Goptions.option_name * option_value
+  | VernacAddOption of Goptions.option_name * option_ref_value list
+  | VernacRemoveOption of Goptions.option_name * option_ref_value list
+  | VernacMemOption of Goptions.option_name * option_ref_value list
+  | VernacPrintOption of Goptions.option_name
+  | VernacCheckMayEval of raw_red_expr option * int option * constr_expr
+  | VernacGlobalCheck of constr_expr
+  | VernacPrint of printable
+  | VernacSearch of searchable * search_restriction
+  | VernacLocate of locatable
+  | VernacComments of comment list
+  | VernacNop
+
+  (* Proof management *)
+  | VernacGoal of constr_expr
+  | VernacAbort of lident option
+  | VernacAbortAll
+  | VernacRestart
+  | VernacSuspend
+  | VernacResume of lident option
+  | VernacUndo of 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
+
+and located_vernac_expr = loc * vernac_expr
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
new file mode 100644
index 00000000..c7846d71
--- /dev/null
+++ b/toplevel/vernacinterp.ml
@@ -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        *)
+(************************************************************************)
+
+(* $Id: vernacinterp.ml,v 1.17.8.1 2004/07/16 19:31:50 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+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
+  else UserError("Vernac.disable_drop",(str"Drop is forbidden."))
+
+(* Table of vernac entries *)
+let vernac_tab =
+  (Hashtbl.create 51 :
+    (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t)
+
+let vinterp_add s f =
+  try 
+    Hashtbl.add vernac_tab s f
+  with Failure _ ->
+    errorlabstrm "vinterp_add"
+      (str"Cannot add the vernac command " ++ str s ++ str" twice")
+
+let overwriting_vinterp_add s f =
+  begin 
+    try 
+      let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s 
+    with Not_found -> ()
+  end;
+  Hashtbl.add vernac_tab s f
+
+let vinterp_map s =
+  try 
+    Hashtbl.find vernac_tab s
+  with Not_found -> 
+    errorlabstrm "Vernac Interpreter"
+      (str"Cannot find vernac command " ++ str s)
+
+let vinterp_init () = Hashtbl.clear vernac_tab
+
+(* Interpretation of a vernac command *)
+
+let call (opn,converted_args) =
+  let loc = ref "Looking up command" in
+  try
+    let callback = vinterp_map opn in
+    loc:= "Checking arguments";
+    let hunk = callback converted_args in
+    loc:= "Executing command";
+    hunk()
+  with
+    | Drop -> raise Drop
+    | ProtectedLoop -> raise ProtectedLoop
+    | e ->
+        if !Options.debug then
+	  msgnl (str"Vernac Interpreter " ++ str !loc);
+        raise e
+
+let bad_vernac_args s =
+  anomalylabstrm s
+    (str"Vernac " ++ str s ++ str" called with bad arguments")
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
new file mode 100644
index 00000000..86b80935
--- /dev/null
+++ b/toplevel/vernacinterp.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: vernacinterp.mli,v 1.11.10.1 2004/07/16 19:31:50 herbelin Exp $ i*)
+
+(*i*)
+open Tacexpr
+(*i*)
+
+(* Interpretation of extended vernac phrases. *)
+ 
+val disable_drop : exn -> exn
+
+val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit
+val overwriting_vinterp_add : 
+  string -> (raw_generic_argument list -> unit -> unit) -> unit
+
+val vinterp_init : unit -> unit
+val call : string * raw_generic_argument list -> unit
diff --git a/translate/ppconstrnew.ml b/translate/ppconstrnew.ml
new file mode 100644
index 00000000..7d2feaf2
--- /dev/null
+++ b/translate/ppconstrnew.ml
@@ -0,0 +1,958 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2 2004/07/16 20:48:17 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 u = str "<univ>"
+
+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 id bl annot t c =
+  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 ltop) c
+
+let pr_fixdecl pr (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 id bl annot t c
+
+let pr_cofixdecl pr (id,bl,t,c) =
+  pr_recursive_decl pr id bl (mt()) t c
+
+let pr_recursive pr_decl id = function
+  | [] -> anomaly "(co)fixpoint with no definition"
+  | [d1] -> pr_decl d1
+  | dl ->
+      prlist_with_sep (fun () -> fnl() ++ str "with ") pr_decl 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) ->
+      let p = hov 0 (str"fix " ++
+                pr_recursive (pr_fixdecl (pr mt)) (snd id) fix) in
+      if List.length fix = 1 & prec_less (fst inherited) ltop
+      then surround p, latom else p, lfix
+  | CCoFix (_,id,cofix) ->
+      let p =
+        hov 0 (str "cofix " ++
+               pr_recursive (pr_cofixdecl (pr mt)) (snd id) cofix) in
+      if List.length cofix = 1 & prec_less (fst inherited) ltop
+      then surround p, latom else p, 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 mt)) c
+            ++ pr_case_type (pr 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 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)
+
+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,c) ->
+      hov 1 (str s ++ pr_arg pr_constr c)
+
+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
new file mode 100644
index 00000000..4477728c
--- /dev/null
+++ b/translate/ppconstrnew.mli
@@ -0,0 +1,100 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.mli,v 1.16.2.1 2004/07/16 19:31:52 herbelin Exp $ *)
+
+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
new file mode 100644
index 00000000..80298c3e
--- /dev/null
+++ b/translate/pptacticnew.ml
@@ -0,0 +1,903 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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.2 2004/07/16 19:31:52 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 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 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)
+
diff --git a/translate/pptacticnew.mli b/translate/pptacticnew.mli
new file mode 100644
index 00000000..2558413f
--- /dev/null
+++ b/translate/pptacticnew.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+ 
+(* $Id: pptacticnew.mli,v 1.6.2.1 2004/07/16 19:31:52 herbelin Exp $ *)
+
+open Pp
+open Genarg
+open Tacexpr
+open Proof_type
+open Topconstr
+open Names
+
+val qsnew : string -> 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
+
+
diff --git a/translate/ppvernacnew.ml b/translate/ppvernacnew.ml
new file mode 100644
index 00000000..246253eb
--- /dev/null
+++ b/translate/ppvernacnew.ml
@@ -0,0 +1,1123 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ppvernacnew.ml,v 1.95.2.2 2004/07/16 20:48:17 herbelin Exp $ *)  
+
+open Pp
+open Names
+open Nameops
+open Nametab 
+open Util
+open Extend
+open Vernacexpr
+open Ppconstrnew
+open Pptacticnew
+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_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_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
+      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 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)
+
+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
+
+let pr_raw_tactic tac =
+  pr_raw_tactic_env [] (Global.env()) tac
+
+let rec extract_signature = function
+  | [] -> []
+  | Egrammar.TacNonTerm (_,(_,t),_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+let rec match_vernac_rule tys = function
+    [] -> raise Not_found
+  | (s,pargs)::rls ->
+      if extract_signature pargs = tys then (s,pargs)
+      else match_vernac_rule tys rls
+
+let sep = fun _ -> spc()
+let sep_p = fun _ -> str"."
+let sep_v = fun _ -> str","
+let sep_v2 = fun _ -> str"," ++ spc()
+let sep_pp = fun _ -> str":"
+
+let pr_ne_sep sep pr = function
+    [] -> mt()
+  | l -> sep() ++ pr l
+
+let pr_entry_prec = function
+  | Some Gramext.LeftA -> str"LEFTA "
+  | Some Gramext.RightA -> str"RIGHTA "
+  | Some Gramext.NonA -> str"NONA "
+  | None -> mt()
+
+let pr_prec = function
+  | Some Gramext.LeftA -> str", left associativity"
+  | Some Gramext.RightA -> str", right associativity"
+  | Some Gramext.NonA -> str", no associativity"
+  | None -> mt()
+
+let pr_set_entry_type = function
+  | ETIdent -> str"ident"
+  | ETReference -> str"global"
+  | ETPattern -> str"pattern"
+  | ETConstr _ -> str"constr"
+  | ETOther (_,e) -> str e
+  | 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
+
+let pr_comment pr_c = function
+  | CommentConstr c -> pr_c c
+  | CommentString s -> qsnew s
+  | CommentInt n -> int n
+
+let pr_in_out_modules = function
+  | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l
+  | SearchOutside [] -> mt()
+  | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l
+
+let pr_search_about = function
+  | SearchRef r -> pr_reference r
+  | SearchString s -> qsnew s
+
+let pr_search a b pr_p = match a with
+  | SearchHead qid -> str"Search" ++ spc() ++ pr_reference qid ++ pr_in_out_modules b
+  | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+  | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+  | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b
+
+let pr_locality local = if local then str "Local " else str ""
+
+let pr_explanation imps = function
+  | ExplByPos n -> pr_id (Impargs.name_of_implicit (List.nth imps (n-1)))
+  | ExplByName id -> pr_id id
+
+let pr_class_rawexpr = function
+  | FunClass -> str"Funclass"
+  | SortClass -> str"Sortclass"
+  | RefClass qid -> pr_reference qid
+
+let pr_option_ref_value = function
+  | QualidRefValue id -> pr_reference id
+  | StringRefValue s -> qsnew 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
+  | Goptions.SecondaryTable (table,field) -> str table ++ spc() ++ str field ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b
+
+let pr_set_option a b = 
+  let pr_opt_value = function 
+    | IntValue n -> spc() ++ int n
+    | StringValue s -> spc() ++ str s
+    | BoolValue b -> mt()
+  in pr_printoption a None ++ pr_opt_value b
+
+let pr_topcmd _ = str"(* <Warning> : No printer for toplevel commands *)"
+
+let pr_destruct_location = function
+  | Tacexpr.ConclLocation ()  -> str"Conclusion"
+  | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis"
+
+let pr_opt_hintbases l = match l with
+  | [] -> mt()
+  | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
+
+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)
+    | HintsImmediate l ->
+        str"Immediate" ++ spc() ++
+        prlist_with_sep sep pr_c (List.map snd 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 "Extern" ++ spc() ++ int n ++ spc() ++ pr_pat c ++ str" =>" ++
+        spc() ++ pr_raw_tactic tac
+    | HintsDestruct(name,i,loc,c,tac) ->
+        str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++
+        hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++
+               pr_c c ++ str " =>") ++ spc() ++
+        pr_raw_tactic tac in
+  hov 2 (str"Hint "++pr_locality local ++ pph ++ opth)
+
+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
+  | CWith_Module (id,qid) ->
+      str"Module" ++ spc() ++ pr_lident id ++ str" := " ++
+      pr_located pr_qualid qid
+
+let rec pr_module_type pr_c = function
+  | CMTEident qid -> spc () ++ pr_located pr_qualid qid
+  | CMTEwith (mty,decl) ->
+      let m = pr_module_type pr_c mty in
+      let p = pr_with_declaration pr_c decl in
+      m ++ spc() ++ str"with" ++ spc() ++ p
+
+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 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
+  List.iter (fun (_,id) ->
+    Declaremods.process_module_bindings [id]
+      [make_mbid lib_dir (string_of_id id),
+       Modintern.interp_modtype (Global.env()) mty]) idl;
+  (* Builds the stream *)
+  spc() ++
+  hov 1 (str"(" ++ 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
+  modules parametres dans la Nametab des l'appel de pr_module_binders
+  malgre l'aspect paresseux des streams *)
+  let ml = List.map (pr_module_vardecls pr_c) l in
+  prlist (fun id -> id) ml
+
+let pr_module_binders_list l pr_c = pr_module_binders l pr_c
+
+let rec pr_module_expr = function
+  | CMEident qid -> pr_located pr_qualid qid
+  | CMEapply (me1,(CMEident _ as me2)) ->
+      pr_module_expr me1 ++ spc() ++ pr_module_expr me2
+  | CMEapply (me1,me2) ->
+      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 ++
+    pr_opt (fun sc -> str ": " ++ str sc) scopt)
+
+let pr_vbinders l =
+  hv 0 (pr_binders l)
+
+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)
+
+let begin_of_inductive = function
+    [] -> 0
+  | (_,((loc,_),_))::_ -> fst (unloc loc)
+
+let pr_class_rawexpr = function
+  | FunClass -> str"Funclass"
+  | SortClass -> str"Sortclass"
+  | RefClass qid -> pr_reference qid
+
+let pr_assumption_token many = function
+  | (Local,Logical) ->
+      str (if many then "Hypotheses" else "Hypothesis")
+  | (Local,Definitional) ->
+      str (if many then "Variables" else "Variable")
+  | (Global,Logical) ->
+      str (if many then "Axioms" else "Axiom")
+  | (Global,Definitional) -> 
+      str (if many then "Parameters" else "Parameter")
+  | (Global,Conjectural) -> str"Conjecture"
+  | (Local,Conjectural) -> 
+      anomaly "Don't know how to translate a local conjecture"
+
+let pr_params pr_c (xl,(c,t)) =
+  hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
+         (if c then str":>" else str":" ++
+         spc() ++ pr_c t))
+
+let rec factorize = function
+  | [] -> []
+  | (c,(idl,t))::l ->
+      match factorize l with
+	| (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l'
+	| l' -> (idl,(c,t))::l'
+
+let pr_ne_params_list pr_c l =
+  match factorize l with
+    | [p] -> pr_params pr_c p
+    | l ->
+	prlist_with_sep spc
+          (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) 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_syntax_modifier = function
+  | SetItemLevel (l,NextLevel) ->
+      prlist_with_sep sep_v2 str l ++
+      spc() ++ str"at next level"
+  | SetItemLevel (l,NumLevel n) ->
+      prlist_with_sep sep_v2 str l ++
+      spc() ++ str"at level" ++ spc() ++ int n
+  | SetLevel n -> str"at level" ++ spc() ++ int n
+  | SetAssoc Gramext.LeftA -> str"left associativity"
+  | SetAssoc Gramext.RightA -> str"right associativity"
+  | 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
+
+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 ++
+    spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
+
+let pr_box b = let pr_boxkind = function
+  | PpHB n -> str"h" ++ spc() ++ int n
+  | PpVB n -> str"v" ++ spc() ++ int n
+  | PpHVB n -> str"hv" ++ spc() ++ int n
+  | PpHOVB n -> str"hov" ++ spc() ++ int n
+  | PpTB -> str"t"
+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
+  | _ -> 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 *)
+(**************************************)
+let make_pr_vernac pr_constr pr_lconstr =
+
+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
+
+let rec pr_vernac = function
+  
+  (* Proof management *)
+  | VernacAbortAll -> str "Abort All"
+  | VernacRestart -> str"Restart"
+  | VernacSuspend -> str"Suspend"
+  | VernacUnfocus -> str"Unfocus"
+  | VernacGoal c -> str"Goal" ++ pr_lconstrarg c
+  | 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
+  | VernacFocus i -> str"Focus" ++ pr_opt int i
+  | VernacGo g -> 
+      let pr_goable = function
+	| GoTo i -> int i
+	| GoTop -> str"top"
+	| GoNext -> str"next"
+	| GoPrev -> str"prev" 
+      in str"Go" ++ spc() ++  pr_goable g
+  | VernacShow s -> 
+      let pr_showable = function
+	| ShowGoal n -> str"Show" ++ pr_opt int n
+	| ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n
+	| ShowProof -> str"Show Proof"
+	| ShowNode -> str"Show Node"
+	| ShowScript -> str"Show Script"
+	| ShowExistentials -> str"Show Existentials"
+	| ShowTree -> str"Show Tree"
+	| ShowProofNames -> str"Show Conjectures"
+	| ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro")
+	| 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
+
+  (* State management *)
+  | VernacWriteState s -> str"Write State" ++ spc () ++ qsnew s
+  | VernacRestoreState s -> str"Restore State" ++ spc() ++ qsnew s
+
+  (* Control *)
+  | VernacList l ->
+      hov 2 (str"[" ++ spc() ++
+             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
+  | 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 " *)"
+  | VernacOpenCloseScope (local,opening,sc) ->
+      str (if opening then "Open " else "Close ") ++ pr_locality local ++
+      str "Scope" ++ spc() ++ str sc
+  | VernacDelimiters (sc,key) ->
+      str"Delimit Scope" ++ spc () ++ str sc ++
+      spc() ++ str "with " ++ str key
+  | 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 
+      |	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
+      hov 0 (hov 0 (str"Infix " ++ pr_locality local
+      ++ qsnew s ++ str " :=" ++ spc() ++ pr_reference q) ++
+      pr_syntax_modifiers mv8 ++
+      (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
+      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
+      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 ++
+      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_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))
+        | ProveBody (bl,t) ->
+            (pr_and_type_binders_arg bl, str" :" ++ pr_spc_type 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
+        | None -> mt()
+        | Some cc -> str" :=" ++ spc() ++ cc))
+
+  | VernacStartTheoremProof (ki,id,(bl,c),b,d) ->
+      hov 1 (pr_thm_token ki ++ spc() ++ pr_lident id ++ spc() ++
+      (match bl with
+        | [] -> mt()
+        | _ -> error "Statements with local binders no longer supported")
+      ++ str":" ++ pr_spc_type (rename_bound_variables (snd id) c))
+  | VernacEndProof Admitted -> str"Admitted"
+  | VernacEndProof (Proved (opac,o)) -> (match o with
+    | None -> if opac then str"Qed" else str"Defined"
+    | Some (id,th) -> (match th with
+      |	None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id
+      |	Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) 
+  | VernacExactProof c ->
+      hov 2 (str"Proof" ++ pr_lconstrarg c)
+  | VernacAssumption (stre,l) ->
+      hov 2
+        (pr_assumption_token (List.length l > 1) stre ++ spc() ++ 
+	 pr_ne_params_list pr_type 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
+      let pr_constructor_list l = match l with
+        | [] -> mt()
+        | _ ->
+            pr_com_at (begin_of_inductive l) ++
+            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) =
+	hov 0 (
+          str key ++ spc() ++
+          pr_lident id ++ pr_and_type_binders_arg indpar ++ spc() ++ str":" ++ 
+	  spc() ++ pr_type 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
+      
+      let name_of_binder = function
+        | LocalRawAssum (nal,_) -> nal
+        | LocalRawDef (_,_) -> [] in
+      let pr_onerec = function
+        | (id,n,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
+            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_decl_notation pr_constr ntn
+      in
+      hov 1 (str"Fixpoint" ++ spc() ++
+        prlist_with_sep (fun _ -> fnl() ++ fnl() ++ str"with ") pr_onerec recs)
+
+  | VernacCoFixpoint corecs ->
+      let pr_onecorec (id,bl,c,def) =
+        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() ++
+      prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)  
+  | VernacScheme l ->
+      hov 2 (str"Scheme" ++ spc() ++
+             prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l)
+
+  (* Gallina extensions *)
+  | VernacRecord (b,(oc,name),ps,s,c,fs) ->
+      let pr_record_field = function
+        | (oc,AssumExpr (id,t)) ->
+            hov 1 (pr_lname id ++
+            (if oc then str" :>" else str" :") ++ spc() ++
+            pr_type 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)
+	    | 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" := " ++
+         (match c with
+           | None -> mt()
+           | Some sc -> pr_lident sc) ++
+	spc() ++ str"{"  ++
+        hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}"))
+  | 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() ++
+      (match spe with
+      |	None -> mt()
+      |	Some flag ->
+          (if flag then str"Specification" else str"Implementation") ++
+          spc ()) ++
+      prlist_with_sep sep pr_module l)
+  | VernacImport (f,l) ->
+      (if f then str"Export" else str"Import") ++ spc() ++
+      prlist_with_sep sep pr_import_module l
+  | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_reference q
+  | VernacCoercion (s,id,c1,c2) ->
+      hov 1 (
+	str"Coercion" ++ (match s with | Local -> spc() ++
+	  str"Local" ++ spc() | Global -> spc()) ++
+	pr_reference id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+	spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
+  | VernacIdentityCoercion (s,id,c1,c2) ->
+      hov 1 (
+	str"Identity Coercion" ++ (match s with | Local -> spc() ++
+	  str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ 
+	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
+	spc() ++ pr_class_rawexpr c2)
+
+  (* Modules and Module Types *)
+  | VernacDefineModule (m,bl,ty,bd) ->
+      let b = pr_module_binders_list bl pr_lconstr in 
+      hov 2 (str"Module " ++ 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) ->
+      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)
+  | VernacDeclareModuleType (id,bl,m) ->
+      let b = pr_module_binders_list bl pr_lconstr in 
+      hov 2 (str"Module Type " ++ pr_lident id ++ b ++
+             pr_opt (fun mt -> str ":= " ++ pr_module_type pr_lconstr mt) m)
+
+  (* 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)
+
+  | VernacSolveExistential (i,c) ->
+      str"Existential " ++ int i ++ pr_lconstrarg c
+
+  (* Auxiliary file and library management *)
+  | VernacRequireFrom (exp,spe,f) -> hov 2
+      (str"Require " ++ pr_require_token exp ++ spc() ++
+      (match spe with
+        | None -> mt()
+        | Some false -> str"Implementation" ++ spc()
+        | Some true -> str"Specification" ++ spc ()) ++
+      qsnew f)
+  | VernacAddLoadPath (fl,s,d) -> hov 2
+      (str"Add" ++
+       (if fl then str" Rec " else spc()) ++
+       str"LoadPath" ++ spc() ++ qsnew s ++
+       (match d with 
+         | None -> mt()
+         | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) 
+  | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qsnew s
+  | VernacAddMLPath (fl,s) ->
+      str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qsnew s
+  | VernacDeclareMLModule l ->
+      hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qsnew l)
+  | VernacChdir s -> str"Cd" ++ pr_opt qsnew s
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition (rc,l) ->
+      let pr_tac_body (id, body) =
+        let idl, body =
+          match body with
+	    | Tacexpr.TacFun (idl,b) -> idl,b
+            | _ -> [], body in
+        pr_located pr_ltac_id id ++ 
+	prlist (function None -> str " _"
+                       | Some id -> spc () ++ pr_id id) idl
+	++ str" :=" ++ brk(1,1) ++
+	let idl = List.map out_some (List.filter (fun x -> not (x=None)) idl)in
+        pr_raw_tactic_env 
+	  (idl @ List.map snd (List.map fst l))
+	  (Global.env())
+	  body in
+      hov 1
+        (((*if !Options.p1 then
+	  (if rc then str "Recursive " else mt()) ++
+	  str "Tactic Definition " else*)
+	    (* 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
+  | 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) ->
+      hov 2 (str"Implicit Arguments" ++ spc() ++ pr_reference q)
+  | VernacDeclareImplicits (q,Some l) ->
+      let r = Nametab.global q in
+      Impargs.declare_manual_implicits 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)
+  | 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)
+  | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l))
+  | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l))
+  | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l))
+  | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None)
+  | VernacCheckMayEval (r,io,c) -> 
+      let pr_mayeval r c = match r with 
+      | Some r0 ->
+          hov 2 (str"Eval" ++ spc() ++
+          pr_red_expr (pr_constr,pr_lconstr,pr_reference) r0 ++
+          spc() ++ str"in" ++ spc () ++ pr_constr c)
+      | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) 
+      in 
+      (if io = None then mt() else int (out_some io) ++ str ": ") ++ 
+      pr_mayeval r c
+  | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c)
+  | VernacPrint p -> 
+      let pr_printable = function
+	| PrintFullContext -> str"Print All"
+	| PrintSectionContext s ->
+            str"Print Section" ++ spc() ++ Libnames.pr_reference s
+	| PrintGrammar (uni,ent) ->
+            msgerrnl (str "warning: no direct translation of Print Grammar entry"); 
+            str"Print Grammar" ++ spc() ++ str ent
+	| PrintLoadPath -> str"Print LoadPath"
+	| PrintModules -> str"Print Modules"
+	| PrintMLLoadPath -> str"Print ML Path"
+	| PrintMLModules -> str"Print ML Modules"
+	| PrintGraph -> str"Print Graph"
+	| PrintClasses -> str"Print Classes"
+	| PrintCoercions -> str"Print Coercions"
+	| PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t
+	| 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
+	| 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
+	| 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 -> 
+      let pr_locate =function
+	| LocateTerm qid ->  pr_reference qid
+	| LocateFile f -> str"File" ++ spc() ++ qsnew f
+	| LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid
+	| LocateNotation s -> qsnew s
+      in str"Locate" ++ spc() ++ pr_locate loc
+  | VernacComments l ->
+      hov 2
+        (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l)
+  | VernacNop -> mt()
+  
+  (* Toplevel control *)
+  | VernacToplevelControl exn -> pr_topcmd exn
+
+  (* For extension *)
+  | VernacExtend (s,c) -> pr_extend s c
+  | VernacV7only _ -> mt()
+  | VernacV8only com -> pr_vernac com
+  | VernacProof Tacexpr.TacId _ -> str "Proof"
+  | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te 
+
+and pr_extend s cl =
+  let pr_arg a =
+    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 (pp,_) =
+      List.fold_left
+        (fun (strm,args) pi ->
+          match pi with
+              Egrammar.TacNonTerm _ -> 
+                (strm ++ pr_gen (Global.env()) (List.hd args),
+                List.tl args)
+            | Egrammar.TacTerm s -> (strm ++ spc() ++ str s, args))
+        (str hd,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 ()
+
diff --git a/translate/ppvernacnew.mli b/translate/ppvernacnew.mli
new file mode 100644
index 00000000..73101a1a
--- /dev/null
+++ b/translate/ppvernacnew.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole 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: ppvernacnew.mli,v 1.3.2.1 2004/07/16 19:31:52 herbelin Exp $ *)
+
+open Pp
+open Genarg
+open Vernacexpr
+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
+
+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