diff options
| author |  Samuel Mimram <smimram@debian.org> | 2006-07-13 14:28:31 +0000 |
|---|---|---|
| committer | Samuel Mimram <smimram@debian.org> | 2006-07-13 14:28:31 +0000 |
| commit | de0085539583f59dc7c4bf4e272e18711d565466 (patch) | |
| tree | 347e1d95a2df56f79a01b303e485563588179e91 | |
| parent | e978da8c41d8a3c19a29036d9c569fbe2a4616b0 (diff) | |
Imported Upstream version 8.0pl3+8.1beta.2upstream/8.0pl3+8.1beta.2
113 files changed, 6635 insertions, 3241 deletions
@@ -282,7 +282,7 @@ tactics/evar_tactics.cmi: kernel/term.cmi proofs/tacmach.cmi \ tactics/extraargs.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ proofs/tacexpr.cmo tactics/setoid_replace.cmi pretyping/rawterm.cmi \ proofs/proof_type.cmi parsing/pcoq.cmi kernel/names.cmi -tactics/extratactics.cmi: interp/topconstr.cmi kernel/term.cmi \ +tactics/extratactics.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ proofs/tacexpr.cmo pretyping/rawterm.cmi proofs/proof_type.cmi \ parsing/pcoq.cmi kernel/names.cmi interp/genarg.cmi tactics/hiddentac.cmi: kernel/term.cmi tactics/tacticals.cmi \ @@ -429,9 +429,11 @@ contrib/first-order/unify.cmi: kernel/term.cmi contrib/funind/functional_principles_proofs.cmi: kernel/term.cmi \ proofs/tacmach.cmi kernel/names.cmi contrib/funind/functional_principles_types.cmi: kernel/term.cmi \ - proofs/tacmach.cmi pretyping/rawterm.cmi kernel/names.cmi -contrib/funind/indfun_common.cmi: kernel/term.cmi pretyping/rawterm.cmi \ - lib/pp.cmi kernel/names.cmi library/libnames.cmi + proofs/tacmach.cmi pretyping/rawterm.cmi kernel/names.cmi \ + library/libnames.cmi kernel/entries.cmi +contrib/funind/indfun_common.cmi: kernel/term.cmi proofs/tacexpr.cmo \ + pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \ + kernel/entries.cmi library/decl_kinds.cmo contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \ kernel/names.cmi library/libnames.cmi contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \ @@ -480,8 +482,7 @@ contrib/subtac/subtac_command.cmi: toplevel/vernacexpr.cmo \ contrib/subtac/subtac_errors.cmi: lib/util.cmi lib/pp.cmi contrib/subtac/subtac_interp_fixpoint.cmi: lib/util.cmi interp/topconstr.cmi \ lib/pp.cmi kernel/names.cmi library/libnames.cmi -contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi \ - interp/topconstr.cmi kernel/names.cmi +contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi contrib/subtac/subtac_pretyping.cmi: interp/topconstr.cmi kernel/term.cmi \ kernel/sign.cmi pretyping/pretyping.cmi kernel/names.cmi \ library/global.cmi pretyping/evd.cmi kernel/environ.cmi @@ -540,13 +541,13 @@ ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \ lib/system.cmi ide/preferences.cmi lib/pp.cmi proofs/pfedit.cmi \ ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \ - ide/coq_commands.cmo ide/coq.cmi ide/command_windows.cmi \ - ide/blaster_window.cmo ide/coqide.cmi + config/coq_config.cmi ide/coq_commands.cmo ide/coq.cmi \ + ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \ lib/system.cmx ide/preferences.cmx lib/pp.cmx proofs/pfedit.cmx \ ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \ - ide/coq_commands.cmx ide/coq.cmx ide/command_windows.cmx \ - ide/blaster_window.cmx ide/coqide.cmi + config/coq_config.cmx ide/coq_commands.cmx ide/coq.cmx \ + ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi ide/coq.cmo: toplevel/vernacexpr.cmo toplevel/vernacentries.cmi \ toplevel/vernac.cmi lib/util.cmi pretyping/termops.cmi kernel/term.cmi \ proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi \ @@ -2181,16 +2182,16 @@ toplevel/coqtop.cmo: kernel/vm.cmi toplevel/vernac.cmi kernel/vconv.cmi \ kernel/names.cmi library/nameops.cmi toplevel/mltop.cmi \ library/library.cmi library/libnames.cmi library/lib.cmi \ library/global.cmi library/declaremods.cmi kernel/declarations.cmi \ - toplevel/coqinit.cmi config/coq_config.cmi toplevel/cerrors.cmi \ - toplevel/coqtop.cmi + toplevel/coqinit.cmi config/coq_config.cmi interp/constrintern.cmi \ + toplevel/cerrors.cmi toplevel/coqtop.cmi toplevel/coqtop.cmx: kernel/vm.cmx toplevel/vernac.cmx kernel/vconv.cmx \ lib/util.cmx toplevel/usage.cmx toplevel/toplevel.cmx lib/system.cmx \ library/states.cmx lib/profile.cmx lib/pp.cmx lib/options.cmx \ kernel/names.cmx library/nameops.cmx toplevel/mltop.cmx \ library/library.cmx library/libnames.cmx library/lib.cmx \ library/global.cmx library/declaremods.cmx kernel/declarations.cmx \ - toplevel/coqinit.cmx config/coq_config.cmx toplevel/cerrors.cmx \ - toplevel/coqtop.cmi + toplevel/coqinit.cmx config/coq_config.cmx interp/constrintern.cmx \ + toplevel/cerrors.cmx toplevel/coqtop.cmi toplevel/discharge.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \ kernel/sign.cmi kernel/names.cmi kernel/inductive.cmi kernel/entries.cmi \ kernel/declarations.cmi kernel/cooking.cmi toplevel/discharge.cmi @@ -2851,122 +2852,156 @@ contrib/funind/functional_principles_proofs.cmo: lib/util.cmi \ pretyping/tacred.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \ kernel/sign.cmi pretyping/reductionops.cmi contrib/recdef/recdef.cmo \ pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \ - lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi contrib/funind/indfun_common.cmi \ - tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \ - pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \ - kernel/entries.cmi tactics/elim.cmi tactics/eauto.cmi \ - kernel/declarations.cmi interp/coqlib.cmi kernel/closure.cmi \ - toplevel/cerrors.cmi contrib/funind/functional_principles_proofs.cmi + lib/pp.cmi proofs/pfedit.cmi lib/options.cmi library/nametab.cmi \ + kernel/names.cmi library/nameops.cmi library/libnames.cmi \ + contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \ + interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \ + kernel/environ.cmi kernel/entries.cmi tactics/elim.cmi tactics/eauto.cmi \ + kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \ + toplevel/command.cmi kernel/closure.cmi toplevel/cerrors.cmi \ + contrib/funind/functional_principles_proofs.cmi contrib/funind/functional_principles_proofs.cmx: lib/util.cmx \ pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \ tactics/tactics.cmx tactics/tacticals.cmx proofs/tactic_debug.cmx \ pretyping/tacred.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \ kernel/sign.cmx pretyping/reductionops.cmx contrib/recdef/recdef.cmx \ pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \ - lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx contrib/funind/indfun_common.cmx \ - tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \ - pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \ - kernel/entries.cmx tactics/elim.cmx tactics/eauto.cmx \ - kernel/declarations.cmx interp/coqlib.cmx kernel/closure.cmx \ - toplevel/cerrors.cmx contrib/funind/functional_principles_proofs.cmi -contrib/funind/functional_principles_types.cmo: toplevel/vernacexpr.cmo \ - toplevel/vernacentries.cmi lib/util.cmi pretyping/typing.cmi \ - pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \ - tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \ - tactics/tacinterp.cmi lib/system.cmi proofs/proof_type.cmi \ - parsing/printer.cmi pretyping/pretyping.cmi parsing/ppconstr.cmi \ - lib/pp.cmi proofs/pfedit.cmi lib/options.cmi kernel/names.cmi \ + lib/pp.cmx proofs/pfedit.cmx lib/options.cmx library/nametab.cmx \ + kernel/names.cmx library/nameops.cmx library/libnames.cmx \ + contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \ + interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \ + kernel/environ.cmx kernel/entries.cmx tactics/elim.cmx tactics/eauto.cmx \ + kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \ + toplevel/command.cmx kernel/closure.cmx toplevel/cerrors.cmx \ + contrib/funind/functional_principles_proofs.cmi +contrib/funind/functional_principles_types.cmo: lib/util.cmi \ + pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \ + tactics/tactics.cmi tactics/tacticals.cmi pretyping/tacred.cmi \ + proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \ + pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \ + pretyping/pretyping.cmi parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi \ + lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \ library/libnames.cmi pretyping/indrec.cmi \ contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \ contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ kernel/environ.cmi kernel/entries.cmi library/declare.cmi \ kernel/declarations.cmi library/decl_kinds.cmo toplevel/command.cmi \ - kernel/closure.cmi toplevel/cerrors.cmi \ - contrib/funind/functional_principles_types.cmi -contrib/funind/functional_principles_types.cmx: toplevel/vernacexpr.cmx \ - toplevel/vernacentries.cmx lib/util.cmx pretyping/typing.cmx \ - pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \ - tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \ - tactics/tacinterp.cmx lib/system.cmx proofs/proof_type.cmx \ - parsing/printer.cmx pretyping/pretyping.cmx parsing/ppconstr.cmx \ - lib/pp.cmx proofs/pfedit.cmx lib/options.cmx kernel/names.cmx \ + kernel/closure.cmi contrib/funind/functional_principles_types.cmi +contrib/funind/functional_principles_types.cmx: lib/util.cmx \ + pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \ + tactics/tactics.cmx tactics/tacticals.cmx pretyping/tacred.cmx \ + proofs/tacmach.cmx tactics/tacinterp.cmx lib/system.cmx kernel/sign.cmx \ + pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \ + pretyping/pretyping.cmx parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx \ + lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \ library/libnames.cmx pretyping/indrec.cmx \ contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \ contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ kernel/environ.cmx kernel/entries.cmx library/declare.cmx \ kernel/declarations.cmx library/decl_kinds.cmx toplevel/command.cmx \ - kernel/closure.cmx toplevel/cerrors.cmx \ - contrib/funind/functional_principles_types.cmi + kernel/closure.cmx contrib/funind/functional_principles_types.cmi contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \ - kernel/term.cmi pretyping/rawterm.cmi lib/pp.cmi library/nametab.cmi \ - kernel/names.cmi library/libnames.cmi library/global.cmi \ - kernel/declarations.cmi interp/coqlib.cmi \ - contrib/funind/indfun_common.cmi + kernel/term.cmi library/summary.cmi proofs/refiner.cmi \ + pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ + parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \ + library/nametab.cmi kernel/names.cmi library/nameops.cmi \ + kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \ + library/lib.cmi library/global.cmi pretyping/evd.cmi \ + pretyping/evarutil.cmi kernel/entries.cmi library/declare.cmi \ + kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \ + kernel/closure.cmi contrib/funind/indfun_common.cmi contrib/funind/indfun_common.cmx: lib/util.cmx pretyping/termops.cmx \ - kernel/term.cmx pretyping/rawterm.cmx lib/pp.cmx library/nametab.cmx \ - kernel/names.cmx library/libnames.cmx library/global.cmx \ - kernel/declarations.cmx interp/coqlib.cmx \ - contrib/funind/indfun_common.cmi + kernel/term.cmx library/summary.cmx proofs/refiner.cmx \ + pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \ + parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \ + library/nametab.cmx kernel/names.cmx library/nameops.cmx \ + kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \ + library/lib.cmx library/global.cmx pretyping/evd.cmx \ + pretyping/evarutil.cmx kernel/entries.cmx library/declare.cmx \ + kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \ + kernel/closure.cmx contrib/funind/indfun_common.cmi contrib/funind/indfun_main.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \ - tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \ - tactics/tacinterp.cmi proofs/tacexpr.cmo kernel/sign.cmi \ - proofs/refiner.cmi pretyping/rawterm.cmi parsing/pptactic.cmi \ - parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \ - library/nameops.cmi parsing/lexer.cmi contrib/funind/invfun.cmo \ - pretyping/indrec.cmi contrib/funind/indfun_common.cmi \ - contrib/funind/indfun.cmo tactics/hiddentac.cmi interp/genarg.cmi \ - contrib/funind/functional_principles_types.cmi tactics/equality.cmi \ - parsing/egrammar.cmi toplevel/cerrors.cmi + tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \ + proofs/tacexpr.cmo proofs/refiner.cmi pretyping/rawterm.cmi \ + proofs/proof_type.cmi parsing/printer.cmi parsing/pptactic.cmi \ + parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi \ + kernel/names.cmi library/nameops.cmi parsing/lexer.cmi \ + contrib/funind/invfun.cmo contrib/funind/indfun_common.cmi \ + contrib/funind/indfun.cmo interp/genarg.cmi \ + contrib/funind/functional_principles_types.cmi parsing/egrammar.cmi \ + toplevel/cerrors.cmi contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \ - tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \ - tactics/tacinterp.cmx proofs/tacexpr.cmx kernel/sign.cmx \ - proofs/refiner.cmx pretyping/rawterm.cmx parsing/pptactic.cmx \ - parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \ - library/nameops.cmx parsing/lexer.cmx contrib/funind/invfun.cmx \ - pretyping/indrec.cmx contrib/funind/indfun_common.cmx \ - contrib/funind/indfun.cmx tactics/hiddentac.cmx interp/genarg.cmx \ - contrib/funind/functional_principles_types.cmx tactics/equality.cmx \ - parsing/egrammar.cmx toplevel/cerrors.cmx + tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \ + proofs/tacexpr.cmx proofs/refiner.cmx pretyping/rawterm.cmx \ + proofs/proof_type.cmx parsing/printer.cmx parsing/pptactic.cmx \ + parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx library/nametab.cmx \ + kernel/names.cmx library/nameops.cmx parsing/lexer.cmx \ + contrib/funind/invfun.cmx contrib/funind/indfun_common.cmx \ + contrib/funind/indfun.cmx interp/genarg.cmx \ + contrib/funind/functional_principles_types.cmx parsing/egrammar.cmx \ + toplevel/cerrors.cmx contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - interp/topconstr.cmi kernel/term.cmi proofs/tacmach.cmi \ - library/states.cmi contrib/recdef/recdef.cmo \ + interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \ + tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \ + tactics/tacinterp.cmi proofs/tacexpr.cmo library/states.cmi \ + kernel/sign.cmi contrib/recdef/recdef.cmo \ contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \ - parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi interp/notation.cmi \ - kernel/names.cmi library/nameops.cmi library/libnames.cmi \ - pretyping/indrec.cmi contrib/funind/indfun_common.cmi library/impargs.cmi \ - library/global.cmi contrib/funind/functional_principles_types.cmi \ + parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \ + interp/notation.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \ + contrib/funind/indfun_common.cmi library/impargs.cmi \ + tactics/hiddentac.cmi library/global.cmi \ + contrib/funind/functional_principles_types.cmi \ contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ - kernel/environ.cmi kernel/declarations.cmi library/decl_kinds.cmo \ - interp/constrintern.cmi interp/constrextern.cmi toplevel/command.cmi \ - toplevel/cerrors.cmi + tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \ + toplevel/command.cmi toplevel/cerrors.cmi contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - interp/topconstr.cmx kernel/term.cmx proofs/tacmach.cmx \ - library/states.cmx contrib/recdef/recdef.cmx \ + interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \ + tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \ + tactics/tacinterp.cmx proofs/tacexpr.cmx library/states.cmx \ + kernel/sign.cmx contrib/recdef/recdef.cmx \ contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \ - parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx interp/notation.cmx \ - kernel/names.cmx library/nameops.cmx library/libnames.cmx \ - pretyping/indrec.cmx contrib/funind/indfun_common.cmx library/impargs.cmx \ - library/global.cmx contrib/funind/functional_principles_types.cmx \ + parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \ + interp/notation.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \ + contrib/funind/indfun_common.cmx library/impargs.cmx \ + tactics/hiddentac.cmx library/global.cmx \ + contrib/funind/functional_principles_types.cmx \ contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ - kernel/environ.cmx kernel/declarations.cmx library/decl_kinds.cmx \ - interp/constrintern.cmx interp/constrextern.cmx toplevel/command.cmx \ - toplevel/cerrors.cmx -contrib/funind/invfun.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \ - tactics/tacticals.cmi proofs/tacmach.cmi contrib/funind/tacinvutils.cmi \ - kernel/sign.cmi pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi \ - library/libnames.cmi contrib/funind/indfun_common.cmi \ - tactics/hiddentac.cmi library/global.cmi tactics/extratactics.cmi \ - tactics/equality.cmi kernel/declarations.cmi -contrib/funind/invfun.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \ - tactics/tacticals.cmx proofs/tacmach.cmx contrib/funind/tacinvutils.cmx \ - kernel/sign.cmx pretyping/rawterm.cmx lib/pp.cmx kernel/names.cmx \ - library/libnames.cmx contrib/funind/indfun_common.cmx \ - tactics/hiddentac.cmx library/global.cmx tactics/extratactics.cmx \ - tactics/equality.cmx kernel/declarations.cmx + tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \ + toplevel/command.cmx toplevel/cerrors.cmx +contrib/funind/invfun.cmo: toplevel/vernacentries.cmi lib/util.cmi \ + pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \ + tactics/tauto.cmo tactics/tactics.cmi tactics/tacticals.cmi \ + proofs/tactic_debug.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \ + proofs/tacexpr.cmo kernel/sign.cmi lib/rtree.cmi \ + pretyping/reductionops.cmi pretyping/rawterm.cmi parsing/printer.cmi \ + parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi \ + library/nameops.cmi library/libnames.cmi tactics/inv.cmi \ + kernel/inductive.cmi pretyping/indrec.cmi \ + contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \ + interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \ + kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo interp/coqlib.cmi toplevel/command.cmi \ + kernel/closure.cmi toplevel/cerrors.cmi +contrib/funind/invfun.cmx: toplevel/vernacentries.cmx lib/util.cmx \ + pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \ + tactics/tauto.cmx tactics/tactics.cmx tactics/tacticals.cmx \ + proofs/tactic_debug.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \ + proofs/tacexpr.cmx kernel/sign.cmx lib/rtree.cmx \ + pretyping/reductionops.cmx pretyping/rawterm.cmx parsing/printer.cmx \ + parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx \ + library/nameops.cmx library/libnames.cmx tactics/inv.cmx \ + kernel/inductive.cmx pretyping/indrec.cmx \ + contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \ + interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \ + kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx interp/coqlib.cmx toplevel/command.cmx \ + kernel/closure.cmx toplevel/cerrors.cmx contrib/funind/rawtermops.cmo: lib/util.cmi proofs/tactic_debug.cmi \ tactics/tacinterp.cmi pretyping/rawterm.cmi parsing/printer.cmi \ parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \ @@ -3559,8 +3594,8 @@ contrib/subtac/subtac_command.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ interp/genarg.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ contrib/subtac/eterm.cmi kernel/environ.cmi kernel/entries.cmi \ lib/dyn.cmi library/declare.cmi kernel/declarations.cmi \ - library/decl_kinds.cmo interp/constrintern.cmi toplevel/command.cmi \ - kernel/closure.cmi contrib/subtac/subtac_command.cmi + library/decl_kinds.cmo interp/coqlib.cmi interp/constrintern.cmi \ + toplevel/command.cmi kernel/closure.cmi contrib/subtac/subtac_command.cmi contrib/subtac/subtac_command.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ pretyping/typing.cmx interp/topconstr.cmx pretyping/termops.cmx \ kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ @@ -3579,8 +3614,8 @@ contrib/subtac/subtac_command.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ interp/genarg.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ contrib/subtac/eterm.cmx kernel/environ.cmx kernel/entries.cmx \ lib/dyn.cmx library/declare.cmx kernel/declarations.cmx \ - library/decl_kinds.cmx interp/constrintern.cmx toplevel/command.cmx \ - kernel/closure.cmx contrib/subtac/subtac_command.cmi + library/decl_kinds.cmx interp/coqlib.cmx interp/constrintern.cmx \ + toplevel/command.cmx kernel/closure.cmx contrib/subtac/subtac_command.cmi contrib/subtac/subtac_errors.cmo: lib/util.cmi parsing/printer.cmi lib/pp.cmi \ contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_errors.cmx: lib/util.cmx parsing/printer.cmx lib/pp.cmx \ @@ -3612,14 +3647,12 @@ contrib/subtac/subtac_interp_fixpoint.cmx: lib/util.cmx kernel/typeops.cmx \ contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \ kernel/term.cmi contrib/subtac/subtac_utils.cmi \ - contrib/subtac/subtac_pretyping.cmi \ - contrib/subtac/subtac_interp_fixpoint.cmi \ - contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_command.cmi \ - contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \ - pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ - parsing/printer.cmi pretyping/pretype_errors.cmi parsing/ppconstr.cmi \ - lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \ - library/nametab.cmi kernel/names.cmi library/library.cmi \ + contrib/subtac/subtac_pretyping.cmi contrib/subtac/subtac_errors.cmi \ + contrib/subtac/subtac_command.cmi contrib/subtac/subtac_coercion.cmi \ + kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \ + pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \ + parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi \ + lib/options.cmi library/nametab.cmi kernel/names.cmi library/library.cmi \ library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \ library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \ @@ -3629,14 +3662,12 @@ contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \ kernel/term.cmx contrib/subtac/subtac_utils.cmx \ - contrib/subtac/subtac_pretyping.cmx \ - contrib/subtac/subtac_interp_fixpoint.cmx \ - contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_command.cmx \ - contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \ - pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ - parsing/printer.cmx pretyping/pretype_errors.cmx parsing/ppconstr.cmx \ - lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \ - library/nametab.cmx kernel/names.cmx library/library.cmx \ + contrib/subtac/subtac_pretyping.cmx contrib/subtac/subtac_errors.cmx \ + contrib/subtac/subtac_command.cmx contrib/subtac/subtac_coercion.cmx \ + kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \ + pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \ + parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx \ + lib/options.cmx library/nametab.cmx kernel/names.cmx library/library.cmx \ library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \ library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \ @@ -3809,10 +3840,6 @@ contrib/xml/xmlentries.cmx: contrib/xml/xmlcommand.cmx \ parsing/egrammar.cmx toplevel/cerrors.cmx contrib/xml/xml.cmo: contrib/xml/xml.cmi contrib/xml/xml.cmx: contrib/xml/xml.cmi -doc/refman/euclid.cmo: doc/refman/euclid.cmi -doc/refman/euclid.cmx: doc/refman/euclid.cmi -doc/refman/heapsort.cmo: doc/refman/heapsort.cmi -doc/refman/heapsort.cmx: doc/refman/heapsort.cmi ide/utils/config_file.cmo: ide/utils/config_file.cmi ide/utils/config_file.cmx: ide/utils/config_file.cmi ide/utils/configwin_html_config.cmo: ide/utils/configwin_types.cmo \ @@ -3964,58 +3991,96 @@ tools/coq_makefile.cmx: tools/coq-tex.cmo: tools/coq-tex.cmx: coq_fix_code.o: kernel/byterun/coq_fix_code.c \ - /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/memory.h \ kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \ - kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ - kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + kernel/byterun/coq_jumptbl.h coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \ - kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ - kernel/byterun/coq_values.h /usr/local/lib/ocaml/caml/alloc.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h coq_fix_code.d.o: kernel/byterun/coq_fix_code.c \ - /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/memory.h \ kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h coq_interp.d.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \ - kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ - kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + kernel/byterun/coq_jumptbl.h coq_memory.d.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \ - kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h coq_values.d.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \ - kernel/byterun/coq_values.h /usr/local/lib/ocaml/caml/alloc.h + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/compatibility.h \ + /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \ + /user/jforest/home//lib/ocaml/caml/fail.h \ + /user/jforest/home//lib/ocaml/caml/mlvalues.h \ + /user/jforest/home//lib/ocaml/caml/misc.h \ + /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ + /user/jforest/home//lib/ocaml/caml/alloc.h diff --git a/.depend.coq b/.depend.coq index 949cc501..17de70f7 100644 --- a/.depend.coq +++ b/.depend.coq @@ -180,7 +180,7 @@ theories/ZArith/Zwf.vo: theories/ZArith/Zwf.v theories/ZArith/ZArith_base.vo the theories/ZArith/ZArith_base.vo: theories/ZArith/ZArith_base.v theories/NArith/BinPos.vo theories/NArith/BinNat.vo theories/ZArith/BinInt.vo theories/ZArith/Zcompare.vo theories/ZArith/Zorder.vo theories/ZArith/Zeven.vo theories/ZArith/Zmin.vo theories/ZArith/Zmax.vo theories/ZArith/Zminmax.vo theories/ZArith/Zabs.vo theories/ZArith/Znat.vo theories/ZArith/auxiliary.vo theories/ZArith/ZArith_dec.vo theories/ZArith/Zbool.vo theories/ZArith/Zmisc.vo theories/ZArith/Wf_Z.vo theories/ZArith/Zhints.vo theories/ZArith/Zbool.vo: theories/ZArith/Zbool.v theories/ZArith/BinInt.vo theories/ZArith/Zeven.vo theories/ZArith/Zorder.vo theories/ZArith/Zcompare.vo theories/ZArith/ZArith_dec.vo theories/Bool/Sumbool.vo theories/ZArith/Zbinary.vo: theories/ZArith/Zbinary.v theories/Bool/Bvector.vo theories/ZArith/ZArith.vo theories/ZArith/Zpower.vo contrib/omega/Omega.vo -theories/ZArith/Znumtheory.vo: theories/ZArith/Znumtheory.v theories/ZArith/ZArith_base.vo contrib/ring/ZArithRing.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zdiv.vo +theories/ZArith/Znumtheory.vo: theories/ZArith/Znumtheory.v theories/ZArith/ZArith_base.vo contrib/ring/ZArithRing.vo theories/ZArith/Zcomplements.vo theories/ZArith/Zdiv.vo theories/NArith/Ndigits.vo theories/Arith/Wf_nat.vo theories/ZArith/Int.vo: theories/ZArith/Int.v theories/ZArith/ZArith.vo contrib/romega/ROmega.vo theories/Setoids/Setoid.vo: theories/Setoids/Setoid.v theories/Relations/Relation_Definitions.vo theories/Lists/MonoList.vo: theories/Lists/MonoList.v theories/Arith/Le.vo @@ -274,54 +274,6 @@ theories/Reals/Raxioms.vo: theories/Reals/Raxioms.v theories/ZArith/ZArith_base. 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/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/Arith/Arith.vo theories/Sorting/Sorting.vo: theories/Sorting/Sorting.v theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Relations/Relations.vo @@ -332,6 +284,7 @@ theories/QArith/Qreduction.vo: theories/QArith/Qreduction.v theories/QArith/QAri theories/QArith/Qring.vo: theories/QArith/Qring.v contrib/ring/Ring.vo contrib/ring/Setoid_ring.vo theories/QArith/QArith_base.vo theories/QArith/Qreals.vo: theories/QArith/Qreals.v theories/Reals/Rbase.vo theories/QArith/QArith_base.vo theories/QArith/QArith.vo: theories/QArith/QArith.v theories/QArith/QArith_base.vo theories/QArith/Qring.vo theories/QArith/Qreduction.vo +theories/QArith/Qcanon.vo: theories/QArith/Qcanon.v theories/QArith/QArith.vo theories/Logic/Eqdep_dec.vo contrib/field/Field.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_base.vo contrib/omega/OmegaLemmas.vo theories/Logic/Decidable.vo @@ -353,7 +306,7 @@ contrib/field/Field_Tactic.vo: contrib/field/Field_Tactic.v theories/Lists/List. 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/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo +contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo theories/Arith/Wf_nat.vo theories/Arith/Lt.vo contrib/subtac/Utils.vo: contrib/subtac/Utils.v contrib/rtauto/Bintree.vo: contrib/rtauto/Bintree.v theories/Lists/List.vo theories/NArith/BinPos.vo contrib/rtauto/Rtauto.vo: contrib/rtauto/Rtauto.v theories/Lists/List.vo contrib/rtauto/Bintree.vo theories/Bool/Bool.vo theories/NArith/BinPos.vo @@ -10,38 +10,37 @@ Syntax - No more support for version 7 syntax and for translation to version 8 syntax. - In fixpoints, the { struct ... } annotation is not mandatory any more when - only one of the arguments has an inductive type (doc TODO) -- Added disjunctive patterns in match-with patterns (doc TODO) -- Support for primitive interpretation of string literals (doc TODO) -- Extended support for Unicode ranges (doc TODO) + only one of the arguments has an inductive type +- Added disjunctive patterns in match-with patterns +- Support for primitive interpretation of string literals +- Extended support for Unicode ranges Vernacular commands -- Added "Print Ltac qualid" to print a user defined tactic (doc TODO) +- Added "Print Ltac qualid" to print a user defined tactic. - Added "Print Rewrite HintDb" to print the content of a DB used by - autorewrite (doc TODO) -- Added "Print Canonical Projections" (doc TODO) -- Added "Example" as synonym of "Definition" (doc TODO) -- Added "Property", "Proposition" and "Corollary" as extra synonyms of "Lemma" - (doc TODO) + autorewrite. +- Added "Print Canonical Projections". +- Added "Example" as synonym of "Definition". +- Added "Proposition" and "Corollary" as extra synonyms of "Lemma". - New command "Whelp" to send requests to the Helm database of proofs - formalized in the Calculus of Inductive Constructions (doc TODO) + formalized in the Calculus of Inductive Constructions. - Command "functional induction" has been re-implemented from the new - "definition" command. + "Function" command. Ltac and tactic syntactic extensions -- New primitive "external" for communication with tool external to Coq - (doc TODO). +- New primitive "external" for communication with tool external to Coq. - New semantics for "match t with": if a clause returns a tactic, it is now applied to the current goal. If it fails, the next clause or next matching subterm is tried (i.e. it behaves as "match - goal with" does) (doc TODO). + goal with" does). The keyword "lazymatch" can be used to delay the + evaluation of tactics occurring in matching clauses. - Hint base names can be parametric in auto and trivial. - Occurrence values can be parametric in unfold, pattern, etc. - Added entry constr_may_eval for tactic extensions. - Low-priority term printer made available in ML-written tactic extensions. -- "Tactic Notation" extended to allow notations of tacticals (doc TODO). +- "Tactic Notation" extended to allow notations of tacticals. Tactics @@ -57,40 +56,41 @@ Tactics - "rewrite ... in" now accepts a clause as place where to rewrite instead of juste a simple hypothesis name. For instance: rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H - rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H - (doc TODO). -- Added "clear - id" to clear all hypotheses except the ones depending in id - (doc TODO). + rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H. - Added "dependent rewrite term" and "dependent rewrite term in hyp" (doc TODO) +- Added "autorewrite with ... in hyp [using ...]". +- Tactic "replace" now accepts a "by" tactic clause. +- Added "clear - id" to clear all hypotheses except the ones depending in id. - The argument of Declare Left Step and Declare Right Step is now a term - (it used to be a reference) (doc TODO). + (it used to be a reference). - Omega now handles arbitrary precision integers. - Several bug fixes in Reflexive Omega (romega). - Idtac can now be left implicit in a [...|...] construct: for instance, - [ foo | | bar ] stands for [ foo | idtac | bar ] (doc TODO). -- Added "autorewrite with ... in hyp [using ...]" (doc TODO). + [ foo | | bar ] stands for [ foo | idtac | bar ]. - Fixed a "fold" bug (non critical but possible source of incompatibilities). - Added classical_left and classical_right which transforms |- A \/ B into ~B |- A and ~A |- B respectively. - Added command "Declare Implicit Tactic" to set up a default tactic to be - used to solve unresolved subterms of term arguments of tactics (doc TODO). + used to solve unresolved subterms of term arguments of tactics. - Better support for coercions to Sortclass in tactics expecting type arguments. -- Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses - (doc TODO). -- Tactic "replace" now accepts a "by" tactic clause (doc TODO). -- New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns - (doc TODO). -- New introduction pattern "?" for letting Coq choose a name (doc TODO). -- Added "eassumption" (doc TODO). -- Added option 'using lemmas' to auto, trivial and eauto (doc TODO). +- Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses. +- New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns. +- New introduction pattern "?" for letting Coq choose a name. +- Added "eassumption". +- Added option 'using lemmas' to auto, trivial and eauto. +- Tactic "congruence" is now complete for its intended scope (ground + equalities and inequalities with constructors). Furthermore, it + tries to equates goal and hypotheses. +- New tactic "rtauto" solves pure propositional logic and gives a + reflective version of the available proof. - Numbering of "pattern", "unfold", "simpl", ... occurrences in "match with" made consistent with the printing of the return clause after the term to match in the "match-with" construct (use "Set Printing All" to see hidden occurrences). - Generalization of induction "induction x1...xn using scheme" where scheme is an induction principle with complex predicates (like the - ones generated by function induction) (doc TODO). + ones generated by function induction). - Some small Ltac tactics has been added to the standard library (file Tactics.v): * f_equal : instead of using the different f_equalX lemmas @@ -111,13 +111,13 @@ Extraction Modules -- Added "Locate Module qualid" to get the full path of a module (TODO doc). -- Module/Declare Module syntax made more uniform (doc TODO). +- Added "Locate Module qualid" to get the full path of a module. +- Module/Declare Module syntax made more uniform. - Added syntactic sugar "Declare Module Export/Import" and - "Module Export/Import" (doc TODO). + "Module Export/Import". - Added syntactic sugar "Module M(Export/Import X Y: T)" and "Module Type M(Export/Import X Y: T)" - (only for interactive definitions) (doc TODO) + (only for interactive definitions) - Construct "with" generalized to module paths: T with (Definition|Module) M1.M2....Mn.l := l' (doc TODO). @@ -127,6 +127,9 @@ Notations - Added insertion of spaces by default in recursive notations w/o separators. - No more automatic printing box in case of user-provided printing "format". - New notation "exists! x:A, P" for unique existence. +- Notations for specific numerals now compatible with generic notations of + numerals (e.g. "1" can be used to denote the unit of a group without + hiding 1%nat) Libraries @@ -134,8 +137,8 @@ Libraries - New library FSets+FMaps of finite sets and maps. - New library QArith on rational numbers. - Small extension of Zmin.V, new Zmax.v, new Zminmax.v. -- Reworking of the files on classical logic and description principles - (possible incompatibilities). +- Reworking and extension of the files on classical logic and + description principles (possible incompatibilities) - Few other improvements in ZArith potentially exceptionally breaking the compatibility (useless hypothesys of Zgt_square_simpl and Zlt_square_simpl removed; fixed names mentioning letter O instead of @@ -144,6 +147,11 @@ Libraries - Znumtheory now contains a gcd function that can compute within Coq. - More lemmas stated on Type in Wf.v, removal of redundant Fix_F. - Change of the internal names of lemmas in OmegaLemmas. +- Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on + the allowance for recursively non uniform parameters (possible + source of incompatibilities: explicit pattern-matching on these + types may require to remove the occurrence associated to their + recursively non uniform parameter). - Coq.List.In_dec has been set transparent (this may exceptionally break proof scripts, set it locally opaque for compatibility). - More on permutations of lists in List.v and Permutation.v. @@ -169,7 +177,7 @@ Tools "make clean" - New environment variable COQREMOTEBROWSER to set the command invoked to start the remote browser both in Coq and coqide. Standard syntax: - "%s" is the placeholder for the URL (doc TODO) + "%s" is the placeholder for the URL. Changes from V8.0beta to V8.0 diff --git a/COMPATIBILITY b/COMPATIBILITY new file mode 100644 index 00000000..bb293baa --- /dev/null +++ b/COMPATIBILITY @@ -0,0 +1,32 @@ +Potential sources of incompatibilities between Coq V8.0 and V8.1 +---------------------------------------------------------------- + +(see also file CHANGES) + +- Inductive types in Type are now polymorphic over their parameters in + Type. This may affect the naming of introduction hypotheses if such + an inductive type in Type is used on small types such as Prop or + Set: the hypothesis names suffix will default to H instead of X. As + a matter of fact, it is recommended to systematically name the + hypotheses that are later refered to in the proof script. + +- Some bug fixes may lead to incompatibilities. This is e.g. the case + of inversion on Type which failed to rewrite some hypotheses as it + did on Prop/Set. + +- Add Morphism for the Prop/iff setoid now requires a proof of + biimplication instead of a proof of implication. + +- The order of arguments in compatibility morphisms changed: the + premises and the parameters are now interleaved while the whole + bunch of parameters used to come first. + +- A few changes in the library (as mentioned in the CHANGES file) may + imply the need for local adaptations. + +- Occurrence numbering order for unfold, pattern, etc changed for the + match construction: occurrences in the return clause now come after + the occurrences in the term matched; this was the opposite before. + +- For changes in the ML interfaces, see file dev/doc/changes.txt in + the main archive. @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id: Makefile 8933 2006-06-09 14:08:38Z herbelin $ +# $Id: Makefile 8989 2006-06-25 22:17:49Z letouzey $ # Makefile for Coq @@ -874,7 +874,7 @@ ZARITHVO=\ QARITHVO=\ theories/QArith/QArith_base.vo theories/QArith/Qreduction.vo \ theories/QArith/Qring.vo theories/QArith/Qreals.vo \ - theories/QArith/QArith.vo + theories/QArith/QArith.vo theories/QArith/Qcanon.vo LISTSVO=\ theories/Lists/MonoList.vo \ @@ -30,6 +30,8 @@ coq_profile_flag= best_compiler=opt local=false +src_spec=no +prefix_spec=no bindir_spec=no libdir_spec=no mandir_spec=no @@ -44,7 +46,7 @@ arch_spec=no coqide_spec=no with_geoproof=true -COQTOP=`pwd` +# COQTOP=`pwd` # Parse command-line arguments @@ -52,49 +54,32 @@ COQTOP=`pwd` 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 + -prefix|--prefix) prefix_spec=yes + prefix="$2" 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 - fsets_opt=yes - fsets=all reals_opt=yes reals=all;; - -src|--src) COQTOP=$2 + -src|--src) src_spec=yes + COQTOP="$2" shift;; -bindir|--bindir) bindir_spec=yes - bindir=$2 + bindir="$2" shift;; -libdir|--libdir) libdir_spec=yes - libdir=$2 + libdir="$2" shift;; -mandir|--mandir) mandir_spec=yes - mandir=$2 + mandir="$2" shift;; -emacslib|--emacslib) emacslib_spec=yes - emacslib=$2 + emacslib="$2" shift;; -emacs |--emacs) emacs_spec=yes - emacs=$2 + emacs="$2" shift;; -coqdocdir|--coqdocdir) coqdocdir_spec=yes - coqdocdir=$2 + coqdocdir="$2" shift;; -arch|--arch) arch_spec=yes arch=$2 @@ -125,6 +110,11 @@ while : ; do shift done +if [ $prefix_spec = yes -a $local = true ] ; then + echo "Options -prefix and -local are incompatible" + echo "Configure script failed!" + exit 1 +fi # compile date DATEPGM=`which date` @@ -160,137 +150,28 @@ case $arch_spec in 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 $fsets_opt in - no) echo "Should I compile the complete theory of finite sets [Y/N, default is Y] ?" - read fsets_ans - - case $fsets_ans in - "N"|"n"|"No"|"NO"|"no") - fsets=basic;; - *) fsets=all;; - esac;; - yes) true;; -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 +# executable extension 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" + win32) EXE=".exe";; + *) EXE="" esac -# executable extension +# strip command case $ARCH in - win32) EXE=".exe";; - *) EXE="" + win32) + # true -> strip : it exists under cygwin ! + STRIPCOMMAND="strip";; + *) + if [ "$coq_profile_flag" = "-p" ] ; then + STRIPCOMMAND="true" + else + STRIPCOMMAND="strip" + fi esac +######################################### # Objective Caml programs CAMLC=`which $bytecamlc` @@ -372,6 +253,22 @@ CAMLP4BIN=${CAMLBIN} # CAMLP4LIB=${CAMLLIB}/camlp4 #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 + # lablgtk2 and CoqIDE if [ "$coqide_spec" = "no" ] ; then @@ -423,6 +320,132 @@ esac # "") MKTEXLSR=true;; #esac +########################################### +# bindir, libdir, mandir, etc. + +canonical_pwd () { +ocaml 2>&1 1>/dev/null <<EOF + prerr_endline(Sys.getcwd());; +EOF +} + +case $src_spec in + no) COQTOP=`canonical_pwd` +esac + +case $ARCH in + win32) + bindir_def='C:\coq\bin' + libdir_def='C:\coq\lib' + mandir_def='C:\coq\man' + emacslib_def='C:\coq\emacs' + coqdocdir_def='C:\coq\latex';; + *) + 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/$prefix_spec/$local in + yes/*/*) BINDIR=$bindir ;; + */yes/*) BINDIR=$prefix/bin ;; + */*/true) BINDIR=$COQTOP/bin ;; + *) echo "Where should I install the Coq binaries [$bindir_def] ?" + read BINDIR + case $BINDIR in + "") BINDIR=$bindir_def;; + *) true;; + esac;; +esac + +case $libdir_spec/$prefix_spec/$local in + yes/*/*) LIBDIR=$libdir;; + */yes/*) + case $ARCH in + win32) LIBDIR=$prefix ;; + *) LIBDIR=$prefix/lib/coq ;; + esac ;; + */*/true) LIBDIR=$COQTOP ;; + *) echo "Where should I install the Coq library [$libdir_def] ?" + read LIBDIR + case $LIBDIR in + "") LIBDIR=$libdir_def;; + *) true;; + esac;; +esac + +case $mandir_spec/$prefix_spec/$local in + yes/*/*) MANDIR=$mandir;; + */yes/*) MANDIR=$prefix/man ;; + */*/true) MANDIR=$COQTOP/man ;; + *) echo "Where should I install the Coq man pages [$mandir_def] ?" + read MANDIR + case $MANDIR in + "") MANDIR=$mandir_def;; + *) true;; + esac;; +esac + +case $emacslib_spec/$prefix_spec/$local in + yes/*/*) EMACSLIB=$emacslib;; + */yes/*) + case $ARCH in + win32) EMACSLIB=$prefix/emacs ;; + *) EMACSLIB=$prefix/share/emacs/site-lisp ;; + esac ;; + */*/true) EMACSLIB=$COQTOP/tools/emacs ;; + *) echo "Where should I install the Coq Emacs mode [$emacslib_def] ?" + read EMACSLIB + case $EMACSLIB in + "") EMACSLIB=$emacslib_def;; + *) true;; + esac;; +esac + +case $coqdocdir_spec/$prefix_spec/$local in + yes/*/*) COQDOCDIR=$coqdocdir;; + */yes/*) + case $ARCH in + win32) COQDOCDIR=$prefix/latex ;; + *) COQDOCDIR=$prefix/share/emacs/site-lisp ;; + esac ;; + */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;; + *) echo "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def] ?" + read COQDOCDIR + case $COQDOCDIR in + "") COQDOCDIR=$coqdocdir_def;; + *) true;; + esac;; +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 + +########################################### # Summary of the configuration echo "" @@ -460,16 +483,19 @@ 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 +# An escaped version of a variable +escape_var () { +ocaml 2>&1 1>/dev/null <<EOF + prerr_endline(String.escaped(Sys.getenv"$VAR"));; +EOF +} + +export COQTOP BINDIR LIBDIR CAMLLIB +ESCCOQTOP="`VAR=COQTOP escape_var`" +ESCBINDIR="`VAR=BINDIR escape_var`" +ESCLIBDIR="`VAR=LIBDIR escape_var`" +ESCCAMLLIB="`VAR=CAMLLIB escape_var`" +ESCCAMLP4LIB="$ESCCAMLLIB"/camlp4 mlconfig_file=$COQTOP/config/coq_config.ml rm -f $mlconfig_file @@ -477,11 +503,11 @@ 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 bindir = "$ESCBINDIR" +let coqlib = "$ESCLIBDIR" +let coqtop = "$ESCCOQTOP" +let camllib = "$ESCCAMLLIB" +let camlp4lib = "$ESCCAMLP4LIB" let best = "$best_compiler" let arch = "$ARCH" let osdeplibs = "$OSDEPLIBS" @@ -522,29 +548,40 @@ 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'` + ESCCOQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'` + ESCBINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'` + ESCLIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'` + ESCMANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'` + ESCEMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'` + ESCCOQDOCDIR=`echo $COQDOCDIR |sed -e 's|\\\|\\\\\\\|g'` + ESCCAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'` ;; + *) + ESCCOQTOP="$COQTOP" + ESCBINDIR="$BINDIR" + ESCLIBDIR="$LIBDIR" + ESCMANDIR="$MANDIR" + ESCEMACSLIB="$EMACSLIB" + ESCCOQDOCDIR="$COQDOCDIR" + ESCCAMLP4BIN="$CAMLP4BIN" ;; esac sed -e "s|LOCALINSTALLATION|$local|" \ - -e "s|COQTOPDIRECTORY|$COQTOP|" \ + -e "s|COQTOPDIRECTORY|$ESCCOQTOP|" \ -e "s|COQVERSION|$VERSION|" \ - -e "s|BINDIRDIRECTORY|$BINDIR|" \ - -e "s|COQLIBDIRECTORY|$LIBDIR|" \ - -e "s|MANDIRDIRECTORY|$MANDIR|" \ - -e "s|EMACSLIBDIRECTORY|$EMACSLIB|" \ + -e "s|BINDIRDIRECTORY|$ESCBINDIR|" \ + -e "s|COQLIBDIRECTORY|$ESCLIBDIR|" \ + -e "s|MANDIRDIRECTORY|$ESCMANDIR|" \ + -e "s|EMACSLIBDIRECTORY|$ESCEMACSLIB|" \ -e "s|EMACSCOMMAND|$EMACS|" \ - -e "s|COQDOCDIRECTORY|$COQDOCDIR|" \ + -e "s|COQDOCDIRECTORY|$ESCCOQDOCDIR|" \ -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|CAMLP4BINDIRECTORY|$ESCCAMLP4BIN|" \ -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \ -e "s|CAMLP4TOOL|$camlp4o|" \ -e "s|CAMLP4COMPATFLAGS|$CAMLP4COMPAT|" \ @@ -602,4 +639,4 @@ echo echo "*Warning* To compile the system for a new architecture" echo " don't forget to do a 'make archclean' before './configure'." -# $Id: configure 8932 2006-06-09 09:29:03Z notin $ +# $Id: configure 8961 2006-06-15 15:22:05Z notin $ diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index e97df539..2b4b7967 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 8931 2006-06-09 07:43:37Z letouzey $ i*) +(*i $Id: extraction.ml 9032 2006-07-07 16:30:34Z herbelin $ i*) (*i*) open Util @@ -406,7 +406,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) List.iter (option_iter (fun kn -> if Cset.mem kn !projs then add_projection n kn)) - (lookup_structure ip).s_PROJ + (lookup_projections ip) with Not_found -> () end; Record field_glob diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index f0e986fb..7977d4e0 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -16,10 +16,7 @@ open Indfun_common open Libnames let msgnl = Pp.msgnl - -let do_observe () = - Tacinterp.get_debug () <> Tactic_debug.DebugOff - + let observe strm = if do_observe () @@ -173,9 +170,11 @@ let isAppConstruct t = then isConstruct (fst (destApp t)) else false - -let nf_betaiotazeta = Reductionops.local_strong Reductionops.whd_betaiotazeta - +let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = let nochange msg = @@ -231,12 +230,6 @@ let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = end_of_type_with_pop sub'' in - (* let new_end_of_type = *) - (* Intmap.fold *) - (* (fun i t end_of_type -> lift 1 (substnl [t] (i-1) end_of_type)) *) - (* sub *) - (* end_of_type_with_pop *) - (* in *) let old_context_length = List.length context + 1 in let witness_fun = mkLetIn(Anonymous,make_refl_eq t1_typ t1,t, @@ -556,10 +549,17 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = g +let my_orelse tac1 tac2 g = + try + tac1 g + with e -> +(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) + tac2 g + let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in let instanciate_one_hyp hid = - tclORELSE + my_orelse ( (* we instanciate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in @@ -748,10 +748,6 @@ let build_proof (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> -(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *) -(* then msgnl (str "build_proof_args with " ++ *) -(* pr_lconstr_env (pf_env g) f_args' *) -(* ); *) let (f_args',args) = dyn_infos.info in let tac : tactic = fun g -> @@ -812,7 +808,8 @@ type static_fix_info = types : types; offset : int; nb_realargs : int; - body_with_param : constr + body_with_param : constr; + num_in_block : int } @@ -838,11 +835,12 @@ let prove_rec_hyp fix_info = exception Not_Rec let generalize_non_dep hyp g = +(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in let hyp_typ = pf_type_of g (mkVar hyp) in let to_revert,_ = - Environ. fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps or List.exists (occur_var_in_decl env hyp) keep or occur_var env hyp hyp_typ @@ -853,7 +851,7 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - (observe_tac "h_generalize" (h_generalize (List.map mkVar to_revert))) + (observe_tac "h_generalize" (h_generalize (List.map mkVar to_revert) )) (observe_tac "thin" (thin to_revert)) g @@ -864,47 +862,97 @@ let revert idl = (generalize (List.map mkVar idl)) (thin idl) +let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = +(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) +(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) +(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) + let f_def = Global.lookup_constant (destConst f) in + let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in + let f_body = + force (out_some f_def.const_body) + in + let params,f_body_with_params = decompose_lam_n nb_params f_body in + let (_,num),(_,_,bodies) = destFix f_body_with_params in + let fnames_with_params = + let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in + let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in + fnames + in +(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) +(* observe (str "body " ++ pr_lconstr bodies.(num)); *) + let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in +(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) + let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in +(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) + let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) f_def.const_type in + let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in + let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in + let f_id = id_of_label (con_label (destConst f)) in + let prove_replacement = + tclTHENSEQ + [ + tclDO (nb_params + rec_args_num + 1) intro; + observe_tac "" (fun g -> + let rec_id = pf_nth_hyp_id g 1 in + tclTHENSEQ + [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); + observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings)); + intros_reflexivity] g + ) + ] + in + Command.start_proof + (*i The next call to mk_equation_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_equation_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + lemma_type + (fun _ _ -> ()); + Pfedit.by (prove_replacement); + Command.save_named false + + -let do_replace params rec_arg_num rev_args_id fun_to_replace body = - fun g -> - let nb_intro_to_do = nb_prod (pf_concl g) in + +let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = + let equation_lemma = + try + let finfos = find_Function_infos (destConst f) in + mkConst (out_some finfos.equation_lemma) + with (Not_found | Failure "out_some" as e) -> + let f_id = id_of_label (con_label (destConst f)) in + (*i The next call to mk_equation_id is valid since we will construct the lemma + Ensures by: obvious + i*) + let equation_lemma_id = (mk_equation_id f_id) in + generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + let _ = + match e with + | Failure "out_some" -> + let finfos = find_Function_infos (destConst f) in + update_Function + {finfos with + equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with + ConstRef c -> c + | _ -> Util.anomaly "Not a constant" + ) + } + | _ -> () + + in + Tacinterp.constr_of_id (pf_env g) equation_lemma_id + in + let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN (tclDO nb_intro_to_do intro) ( fun g' -> let just_introduced = nLastHyps nb_intro_to_do g' in let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in - let old_rev_args_id = rev_args_id in - let rev_args_id = just_introduced_id@rev_args_id in - let to_replace = - Reductionops.nf_betaiota (substl (List.map mkVar rev_args_id) fun_to_replace ) - and by = - Reductionops.nf_betaiota (applist(body,List.rev_map mkVar rev_args_id)) - in -(* observe (str "to_replace := " ++ pr_lconstr_env (pf_env g') to_replace); *) -(* observe (str "by := " ++ pr_lconstr_env (pf_env g') by); *) - let prove_replacement = - let rec_id = List.nth (List.rev old_rev_args_id) (rec_arg_num) in - observe_tac "prove_replacement" - (tclTHENSEQ - [ - revert just_introduced_id; - keep ((List.map id_of_decl params)@ old_rev_args_id); - generalize_non_dep rec_id; - observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings)); - intros_reflexivity - ] - ) - in - tclTHENS - (observe_tac "replacement" (Equality.replace to_replace by)) - [ revert just_introduced_id; - tclSOLVE [prove_replacement]] - g' + tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' ) g - - let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> @@ -1011,7 +1059,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : nb_realargs = List.length (fst (decompose_lam bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i) + body_with_param = bodies_with_all_params.(i); + num_in_block = i } ) typess @@ -1027,7 +1076,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let app_f = mkApp(f,first_args) in let pte_args = (Array.to_list first_args)@[app_f] in let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in - let body_with_param = + let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = Reductionops.nf_betaiota ( @@ -1043,13 +1092,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) - ) + ),num | _ -> error "Not a mutual block" in let info = {infos with types = compose_prod type_args app_pte; - body_with_param = body_with_param + body_with_param = body_with_param; + num_in_block = num } in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) @@ -1118,8 +1168,17 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tclTHENSEQ [ observe_tac "do_replace" - (do_replace princ_info.params fix_info.idx args_id - (List.hd (List.rev pte_args)) fix_body); + (do_replace + full_params + (fix_info.idx + List.length princ_params) + (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) + (all_funs.(fix_info.num_in_block)) + fix_info.num_in_block + all_funs + ); +(* observe_tac "do_replace" *) +(* (do_replace princ_info.params fix_info.idx args_id *) +(* (List.hd (List.rev pte_args)) fix_body); *) let do_prove = build_proof interactive_proof @@ -1133,13 +1192,16 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : nb_rec_hyps = List.length branches } in - clean_goal_with_heq + observe_tac "cleaning" (clean_goal_with_heq (Idmap.map prove_rec_hyp ptes_to_fix) do_prove - dyn_infos + dyn_infos) in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches); *) +(* observe (str "branches := " ++ *) +(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) +(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + +(* ); *) observe_tac "instancing" (instanciate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) diff --git a/contrib/funind/functional_principles_proofs.mli b/contrib/funind/functional_principles_proofs.mli index 35da5d50..62eb528e 100644 --- a/contrib/funind/functional_principles_proofs.mli +++ b/contrib/funind/functional_principles_proofs.mli @@ -16,5 +16,4 @@ val prove_principle_for_gen : Tacmach.tactic -val is_pte : rel_declaration -> bool -val do_observe : unit -> bool +(* val is_pte : rel_declaration -> bool *) diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index 8ef13264..f83eae8d 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -19,9 +19,41 @@ exception Toberemoved_with_rel of int*constr exception Toberemoved +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in + msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl + +let observe s = + if do_observe () + then Pp.msgnl s +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in + msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl + + +let observe s = + if do_observe () + then Pp.msgnl s + (* Transform an inductive induction principle into a functional one @@ -29,6 +61,25 @@ exception Toberemoved let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type_info = compute_elim_sig princ_type in let env = Global.env () in + let env_with_params = Environ.push_rel_context princ_type_info.params env in + let tbl = Hashtbl.create 792 in + let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context) : Sign.rel_context = + match predicates with + | [] -> [] + |(Name x,v,t)::predicates -> + let id = Nameops.next_ident_away x avoid in + Hashtbl.add tbl id x; + (Name id,v,t)::(change_predicates_names (id::avoid) predicates) + | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " + in + let avoid = (Termops.ids_of_context env_with_params ) in + let princ_type_info = + { princ_type_info with + predicates = change_predicates_names avoid princ_type_info.predicates + } + in +(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) +(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i (x,_,t) = let new_sort = sorts.(i) in let args,_ = decompose_prod t in @@ -37,7 +88,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = then List.tl args else args in - x,None,compose_prod real_args (mkSort new_sort) + Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in let new_predicates = list_map_i @@ -45,20 +96,21 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = 0 princ_type_info.predicates in - let env_with_params_and_predicates = - Environ.push_rel_context - new_predicates - (Environ.push_rel_context - princ_type_info.params - env - ) - in + let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with | Some (Libnames.IndRef ind) -> ind - | _ -> failwith "Not a valid predicate" + | _ -> error "Not a valid predicate" ) in + let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in + let is_pte = + let set = List.fold_right Idset.add ptes_vars Idset.empty in + fun t -> + match kind_of_term t with + | Var id -> Idset.mem id set + | _ -> false + in let pre_princ = it_mkProd_or_LetIn ~init: @@ -72,6 +124,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = ) princ_type_info.branches in + let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with | Ind((u,_)) -> u = rel_as_kn @@ -108,21 +161,15 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Prod(x,t,b) -> compute_new_princ_type_for_binder remove mkProd env x t b | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b + compute_new_princ_type_for_binder remove mkLambda env x t b | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved | App(f,args) when is_dom f -> let var_to_be_removed = destRel (array_last args) in let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> - let is_pte = - match kind_of_term f with - | Rel n -> - is_pte (Environ.lookup_rel n env) - | _ -> false - in let args = - if is_pte && remove + if is_pte f && remove then array_get_start args else args in @@ -138,15 +185,13 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = compute_new_princ_type_for_letin remove env x v t b | _ -> pre_princ,[] in -(* observennl ( *) -(* match kind_of_term pre_princ with *) -(* | Prod _ -> *) -(* str "compute_new_princ_type for "++ *) +(* let _ = match kind_of_term pre_princ with *) +(* | Prod _ -> *) +(* observe(str "compute_new_princ_type for "++ *) (* pr_lconstr_env env pre_princ ++ *) (* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl () *) -(* | _ -> str "" *) -(* ); *) +(* pr_lconstr_env env new_princ_type ++ fnl ()) *) +(* | _ -> () in *) res and compute_new_princ_type_for_binder remove bind_fun env x t b = @@ -156,25 +201,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_x : name = get_name (ids_of_context env) x in let new_env = Environ.push_rel (x,None,t) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - eq_constr - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + else + ( + bind_fun(new_x,new_t,new_b), + list_union_eq + eq_constr + binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) + ) + + with + | Toberemoved -> +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = @@ -184,7 +229,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x : name = get_name (ids_of_context env) x in let new_env = Environ.push_rel (x,Some v,t) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b else @@ -198,24 +243,33 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = with | Toberemoved -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) +(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc + let new_e,to_remove_from_e = compute_new_princ_type remove env e + in + new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in + compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + in + let pre_res = + replace_vars + (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) + (lift (List.length ptes_vars) pre_res) + in it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn ~init:pre_res new_predicates) + ~init:(it_mkProd_or_LetIn + ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + new_predicates) + ) princ_type_info.params @@ -246,128 +300,101 @@ let change_property_sort toSort princ princName = let pp_dur time time' = str (string_of_float (System.time_difference time time')) -(* End of things to be removed latter : just here to compare - saving proof with and without normalizing the proof -*) - -let qed () = Command.save_named true +(* let qed () = save_named true *) let defined () = Command.save_named false -let generate_functional_principle - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = - let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) - | Some a -> a - in + + + + + +let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (compute_elim_sig old_princ_type).nparams in - (* First we get the type of the old graph principle *) - let new_principle_type = + (* let time1 = System.get_time () in *) + let new_principle_type = compute_new_princ_type_from_rel (Array.map mkConst funs) - new_sorts + sorts old_princ_type - in -(* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id - | None -> - let id_of_f = id_of_label (con_label f) in - id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in - let names = ref [new_princ_name] in - let hook _ _ = - if sorts = None - then -(* let id_of_f = id_of_label (con_label f) in *) - let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let value = - change_property_sort s new_principle_type new_princ_name - in -(* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = - { const_entry_body = value; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions() - } - in - ignore( - Declare.declare_constant - name - (Entries.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme) - ) - ); - names := name :: !names - in - register_with_sort InProp; - register_with_sort InSet + (* let time2 = System.get_time () in *) + (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) + (* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) + let new_princ_name = + next_global_ident_away true (id_of_string "___________princ_________") [] in begin Command.start_proof new_princ_name (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) new_principle_type - hook + (hook new_principle_type) ; - try - let _tim1 = System.get_time () in - Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); - let _tim2 = System.get_time () in -(* begin *) -(* let dur1 = System.time_difference tim1 tim2 in *) -(* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) -(* end; *) - let do_save = not (do_observe ()) && not interactive_proof in - let _ = - try -(* Vernacentries.show_script (); *) - Options.silently defined (); - let _dur2 = System.time_difference _tim2 (System.get_time ()) in -(* Pp.msgnl (str ("Time to check proof: ") ++ str (string_of_float dur2)); *) - Options.if_verbose - (fun () -> - Pp.msgnl ( - prlist_with_sep - (fun () -> str" is defined " ++ fnl ()) - Ppconstr.pr_id - (List.rev !names) ++ str" is defined " - ) - ) - () - with e when do_save -> - msg_warning - ( - Cerrors.explain_exn e - ); - if not (do_observe ()) - then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end - in - () - -(* let tim3 = Sys.time () in *) -(* Pp.msgnl (str ("Time to save proof: ") ++ str (string_of_float (tim3 -. tim2))); *) - - with - | e -> - msg_warning - ( - Cerrors.explain_exn e - ); - if not ( do_observe ()) - then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end + (* let _tim1 = System.get_time () in *) + Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) + get_proof_clean true end +let generate_functional_principle + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + let f = funs.(i) in + let type_sort = Termops.new_sort_in_family InType in + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) (type_sort) + | Some a -> a + in + let base_new_princ_name,new_princ_name = + match new_princ_name with + | Some (id) -> id,id + | None -> + let id_of_f = id_of_label (con_label f) in + id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) + in + let names = ref [new_princ_name] in + let hook new_principle_type _ _ = + if sorts = None + then + (* let id_of_f = id_of_label (con_label f) in *) + let register_with_sort fam_sort = + let s = Termops.new_sort_in_family fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let value = change_property_sort s new_principle_type new_princ_name in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let ce = + { const_entry_body = value; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions() + } + in + ignore( + Declare.declare_constant + name + (Entries.DefinitionEntry ce, + Decl_kinds.IsDefinition (Decl_kinds.Scheme) + ) + ); + names := name :: !names + in + register_with_sort InProp; + register_with_sort InSet + in + let (id,(entry,g_kind,hook)) = + build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook + in + save false new_princ_name entry g_kind hook +(* defined () *) + exception Not_Rec @@ -441,30 +468,20 @@ let get_funs_constant mp dp = l_const exception No_graph_found - -let make_scheme fas = +exception Found_type of int + +let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = let env = Global.env () and sigma = Evd.empty in - let id_to_constr id = - Tacinterp.constr_of_id env id - in - let funs = - List.map - (fun (_,f,_) -> - try id_to_constr f - with Not_found -> - Util.error ("Cannot find "^ string_of_id f) - ) - fas - in - let first_fun = destConst (List.hd funs) in - let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in - let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in + let funs = List.map fst fas in + let first_fun = List.hd funs in + + + let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try - (* Fixme: take into account funs_mp and funs_dp *) - fst (destInd (id_to_constr first_fun_rel_id)) - with Not_found -> raise No_graph_found + fst (find_Function_infos first_fun).graph_ind + with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map fst this_block_funs_indexes in @@ -472,7 +489,7 @@ let make_scheme fas = let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function const -> List.assoc (destConst const) this_block_funs_indexes) + (function const -> List.assoc const this_block_funs_indexes) funs in let ind_list = @@ -484,49 +501,149 @@ let make_scheme fas = ) funs_indexes in - let l_schemes = List.map (Typing.type_of env sigma ) (Indrec.build_mutual_indrec env sigma ind_list) in + let l_schemes = + List.map + (Typing.type_of env sigma) + (Indrec.build_mutual_indrec env sigma ind_list) + in let i = ref (-1) in let sorts = - List.rev_map (fun (_,_,x) -> + List.rev_map (fun (_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) ) fas in - let princ_names = List.map (fun (x,_,_) -> x) fas in - let _ = List.map2 - (fun princ_name scheme_type -> - incr i; -(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) -(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) -(* ); *) - generate_functional_principle - false - scheme_type - (Some (Array.of_list sorts)) - (Some princ_name) - this_block_funs - !i - (prove_princ_for_struct false !i (Array.of_list (List.map destConst funs))) - ) - princ_names - l_schemes + (* We create the first priciple by tactic *) + let first_type,other_princ_types = + match l_schemes with + s::l_schemes -> s,l_schemes + | _ -> anomaly "" in - () + let (_,(const,_,_)) = + build_functional_principle false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (prove_princ_for_struct false 0 (Array.of_list funs)) + (fun _ _ _ -> ()) + in + incr i; + (* The others are just deduced *) + if other_princ_types = [] + then + [const] + else + let other_fun_princ_types = + let funs = Array.map mkConst this_block_funs in + let sorts = Array.of_list sorts in + List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types + in + let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) + let (idxs,_),(_,ta,_ as decl) = destFix fix in + let other_result = + List.map (* we can now compute the other principles *) + (fun scheme_type -> + incr i; + observe (Printer.pr_lconstr scheme_type); + let type_concl = snd (Sign.decompose_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in + let f = fst (decompose_app applied_f) in + try (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = snd (Sign.decompose_prod_assum t) in + let applied_g = List.hd (List.rev (snd (decompose_app t))) in + let g = fst (decompose_app applied_g) in + if eq_constr f g + then raise (Found_type j); + observe (Printer.pr_lconstr f ++ str " <> " ++ + Printer.pr_lconstr g) + + ) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let (_,(const,_,_)) = + build_functional_principle + false + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) + this_block_funs + !i + (prove_princ_for_struct false !i (Array.of_list funs)) + (fun _ _ _ -> ()) + in + const + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt + in + {const with + Entries.const_entry_body = princ_body; + Entries.const_entry_type = Some scheme_type + } + ) + other_fun_princ_types + in + const::other_result + +let build_scheme fas = +(* (fun (f,_) -> *) +(* try Libnames.constr_of_global (Nametab.global f) *) +(* with Not_found -> *) +(* Util.error ("Cannot find "^ Libnames.string_of_reference f) *) +(* ) *) +(* fas *) -let make_case_scheme fa = + let bodies_types = + make_scheme + (List.map + (fun (_,f,sort) -> + let f_as_constant = + try + match Nametab.global f with + | Libnames.ConstRef c -> c + | _ -> Util.error "Functional Scheme can only be used with functions" + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f) + in + (f_as_constant,sort) + ) + fas + ) + in + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore (Declare.declare_constant + princ_id + (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id + ) + fas + bodies_types + + + +let build_case_scheme fa = let env = Global.env () and sigma = Evd.empty in - let id_to_constr id = - Tacinterp.constr_of_id env id - in - let funs = (fun (_,f,_) -> id_to_constr f) fa in +(* let id_to_constr id = *) +(* Tacinterp.constr_of_id env id *) +(* in *) + let funs = (fun (_,f,_) -> + try Libnames.constr_of_global (Nametab.global f) + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in let first_fun = destConst funs in - let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in - let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in - let first_fun_kn = - (* Fixme: take into accour funs_mp and funs_dp *) - fst (destInd (id_to_constr first_fun_rel_id)) - in + + let funs_mp,funs_dp,_ = Names.repr_con first_fun in + let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in + + + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in diff --git a/contrib/funind/functional_principles_types.mli b/contrib/funind/functional_principles_types.mli index 8b4faaf4..cf28c6e6 100644 --- a/contrib/funind/functional_principles_types.mli +++ b/contrib/funind/functional_principles_types.mli @@ -1,5 +1,7 @@ open Names open Term + + val generate_functional_principle : (* do we accept interactive proving *) bool -> @@ -19,13 +21,14 @@ val generate_functional_principle : (constr array -> int -> Tacmach.tactic) -> unit - - val compute_new_princ_type_from_rel : constr array -> sorts array -> types -> types exception No_graph_found -val make_scheme : (identifier*identifier*Rawterm.rawsort) list -> unit -val make_case_scheme : (identifier*identifier*Rawterm.rawsort) -> unit +val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list + +val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list -> unit +val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort) -> unit + diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index f6d554a8..dffc8120 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -7,6 +7,124 @@ open Libnames open Rawterm open Declarations +let is_rec_info scheme_info = + let test_branche min acc (_,_,br) = + acc || ( + let new_branche = + Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in + let free_rels_in_br = Termops.free_rels new_branche in + let max = min + scheme_info.Tactics.npredicates in + Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br + ) + in + Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) + + +let choose_dest_or_ind scheme_info = + if is_rec_info scheme_info + then Tactics.new_induct + else Tactics.new_destruct + + +let functional_induction with_clean c princl pat = + let f,args = decompose_app c in + fun g -> + let princ,bindings, princ_type = + match princl with + | None -> (* No principle is given let's find the good one *) + begin + match kind_of_term f with + | Const c' -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + try find_Function_infos c' + with Not_found -> + errorlabstrm "" (str "Cannot find induction information on "++Printer.pr_lconstr (mkConst c') ) + in + match Tacticals.elimination_sort_of_goal g with + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ = (* then we get the principle *) + try mkConst (out_some princ_option ) + with Failure "out_some" -> + (*i If there is not default lemma defined then, we cross our finger and try to + find a lemma named f_ind (or f_rec, f_rect) i*) + let princ_name = + Indrec.make_elimination_ident + (id_of_label (con_label c')) + (Tacticals.elimination_sort_of_goal g) + in + try + mkConst(const_of_id princ_name ) + with Not_found -> (* This one is neither defined ! *) + errorlabstrm "" (str "Cannot find induction principle for " + ++Printer.pr_lconstr (mkConst c') ) + in + (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) + | _ -> raise (UserError("",str "functional induction must be used with a function" )) + + end + | Some ((princ,binding)) -> + princ,binding,Tacmach.pf_type_of g princ + in + let princ_infos = Tactics.compute_elim_sig princ_type in + let args_as_induction_constr = + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] + in + List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) + in + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Idset.add (destVar a) acc + with _ -> acc + ) + args + Idset.empty + in + let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in + let old_idl = Idset.diff old_idl princ_vars in + let subst_and_reduce g = + let idl = + map_succeed + (fun id -> + if Idset.mem id old_idl then failwith "subst_and_reduce"; + id + ) + (Tacmach.pf_ids_of_hyps g) + in + let flag = + Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + } + in + if with_clean + then + Tacticals.tclTHEN + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) + (Hiddentac.h_reduce flag Tacticals.allClauses) + g + else Tacticals.tclIDTAC g + + in + Tacticals.tclTHEN + (choose_dest_or_ind + princ_infos + args_as_induction_constr + princ' + pat) + subst_and_reduce + g + + + + type annot = Struct of identifier | Wf of Topconstr.constr_expr * identifier option @@ -120,9 +238,22 @@ let prepare_body (name,annot,args,types,body) rt = (fun_args,rt') +let derive_inversion fix_names = + try + Invfun.derive_correctness + Functional_principles_types.make_scheme + functional_induction + (List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names) + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : register_built + i*) + (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names) + with e -> + msg_warning (str "Cannot define correction of function and graph" ++ Cerrors.explain_exn e) + let generate_principle do_built fix_rec_l recdefs interactive_proof parametrize - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) = + (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in @@ -133,6 +264,9 @@ let generate_principle if do_built then begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg @@ -149,7 +283,7 @@ let generate_principle in let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = - Util.list_map_i + list_map_i (fun i x -> let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in let princ_type = @@ -167,6 +301,7 @@ let generate_principle 0 fix_rec_l in + Array.iter add_Function funs_kn; () end with e -> @@ -210,7 +345,7 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body if List.length names = 1 then 1 else error "Recursive argument must be specified" | Some wf_arg -> - Util.list_index (Name wf_arg) names + list_index (Name wf_arg) names in let unbounded_eq = let f_app_args = @@ -236,7 +371,7 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); - Command.save_named true + derive_inversion [fname] with e -> (* No proof done *) () @@ -333,15 +468,15 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = (Topconstr.names_of_local_assums args) in let annot = - try Some (Util.list_index (Name id) names - 1), Topconstr.CStructRec + try Some (list_index (Name id) names - 1), Topconstr.CStructRec with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id)) in (name,annot,args,types,body),(None:Vernacexpr.decl_notation) | (name,None,args,types,body),recdef -> let names = (Topconstr.names_of_local_assums args) in if is_one_rec recdef && List.length names > 1 then - Util.user_err_loc - (Util.dummy_loc,"Function", + user_err_loc + (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified in Function") else (name,(Some 0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation) @@ -364,8 +499,8 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = interactive_proof true (Functional_principles_proofs.prove_princ_for_struct interactive_proof); - true - + if register_built then derive_inversion fix_names; + true; in () @@ -397,19 +532,19 @@ let rec add_args id new_args b = | CApp(loc,(pf,b),bl) -> CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,b_option,cel,cal) -> - CCases(loc,Util.option_map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,Util.option_map (add_args id new_args) b_option)) cel, + CCases(loc,option_map (add_args id new_args) b_option, + List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,option_map (add_args id new_args) b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> - CLetTuple(loc,nal,(na,Util.option_map (add_args id new_args) b_option), + CLetTuple(loc,nal,(na,option_map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) | CIf(loc,b1,(na,b_option),b2,b3) -> CIf(loc,add_args id new_args b1, - (na,Util.option_map (add_args id new_args) b_option), + (na,option_map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 ) @@ -426,15 +561,17 @@ let rec add_args id new_args b = -let make_graph (id:identifier) = - let c_body = - try - let c = const_of_id id in - Global.lookup_constant c - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id) ) - in +let make_graph (f_ref:global_reference) = + let c,c_body = + match f_ref with + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + end + | _ -> raise (UserError ("", str "Not a function reference") ) + in match c_body.const_body with | None -> error "Cannot build a graph over an axiom !" | Some b -> @@ -494,7 +631,7 @@ let make_graph (id:identifier) = (fun n (nal,t'') -> n+List.length nal) n nal_ta' in - assert (n'<= n); +(* assert (n'<= n); *) chop_n_arrow (n - n') t' | _ -> anomaly "Not enough products" else t @@ -511,16 +648,6 @@ let make_graph (id:identifier) = let l = List.map (fun (id,(n,recexp),bl,t,b) -> -(* let nal = *) -(* List.flatten *) -(* (List.map *) -(* (function *) -(* | Topconstr.LocalRawDef (na,_)-> [] *) -(* | Topconstr.LocalRawAssum (nal,_) -> nal *) -(* ) *) -(* (nal_tas@bl) *) -(* ) *) -(* in *) let bl' = List.flatten (List.map @@ -539,7 +666,8 @@ let make_graph (id:identifier) = (List.map (function | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal + | Topconstr.LocalRawAssum (nal,_) -> + List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal ) nal_tas ) @@ -551,23 +679,17 @@ let make_graph (id:identifier) = in l | _ -> + let id = id_of_label (con_label c) in [(id,None,nal_tas,t,b)] in -(* List.iter (fun (id,rec_arg,bl,t,b) -> *) -(* Pp.msgnl *) -(* (Ppconstr.pr_id id ++ *) -(* Ppconstr.pr_binders bl ++ *) -(* begin match rec_arg with *) -(* | Some (Struct id) -> str " { struct " ++ Ppconstr.pr_id id ++ str " }" *) -(* | _ -> (mt ()) *) -(* end ++ *) -(* str " : " ++ Ppconstr.pr_lconstr_expr t ++ *) -(* str " := " ++ *) -(* Ppconstr.pr_lconstr_expr b *) -(* ) *) -(* ) *) -(* expr_list; *) - do_generate_principle false false expr_list + do_generate_principle false false expr_list; + (* We register the infos *) + let mp,dp,_ = repr_con c in + List.iter (fun (id,_,_,_,_) -> add_Function (make_con mp dp (label_of_id id))) expr_list + + (* let make_graph _ = assert false *) let do_generate_principle = do_generate_principle true + + diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml index b32dfacb..f41aac20 100644 --- a/contrib/funind/indfun_common.ml +++ b/contrib/funind/indfun_common.ml @@ -5,30 +5,15 @@ open Libnames let mk_prefix pre id = id_of_string (pre^(string_of_id id)) let mk_rel_id = mk_prefix "R_" +let mk_correct_id id = Nameops.add_suffix id "_correct" +let mk_complete_id id = Nameops.add_suffix id "_complete" +let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () let invalid_argument s = raise (Invalid_argument s) -(* let idtbl = Hashtbl.create 29 *) -(* let reset_name () = Hashtbl.clear idtbl *) - -(* let fresh_id s = *) -(* try *) -(* let id = Hashtbl.find idtbl s in *) -(* incr id; *) -(* id_of_string (s^(string_of_int !id)) *) -(* with Not_found -> *) -(* Hashtbl.add idtbl s (ref (-1)); *) -(* id_of_string s *) - -(* let fresh_name s = Name (fresh_id s) *) -(* let get_name ?(default="H") = function *) -(* | Anonymous -> fresh_name default *) -(* | Name n -> Name n *) - - let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid @@ -159,161 +144,323 @@ let find_reference sl s = let eq = lazy(coq_constant "eq") let refl_equal = lazy(coq_constant "refl_equal") +(*****************************************************************) +(* Copy of the standart save mechanism but without the much too *) +(* slow reduction function *) +(*****************************************************************) +open Declarations +open Entries +open Decl_kinds +open Declare +let definition_message id = + Options.if_verbose message ((string_of_id id) ^ " is defined") + + +let save with_clean id const (locality,kind) hook = + let {const_entry_body = pft; + const_entry_type = tpo; + const_entry_opaque = opacity } = const in + let l,r = match locality with + | Local when Lib.sections_are_opened () -> + let k = logical_kind_of_goal_kind kind in + let c = SectionLocalDef (pft, tpo, opacity) in + let _ = declare_variable id (Lib.cwd(), c, k) in + (Local, VarRef id) + | Local -> + let k = logical_kind_of_goal_kind kind in + let kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) + | Global -> + let k = logical_kind_of_goal_kind kind in + let kn = declare_constant id (DefinitionEntry const, k) in + (Global, ConstRef kn) in + if with_clean then Pfedit.delete_current_proof (); + hook l r; + definition_message id + + + + +let extract_pftreestate pts = + let pfterm,subgoals = Refiner.extract_open_pftreestate pts in + let tpfsigma = Refiner.evc_of_pftreestate pts in + let exl = Evarutil.non_instantiated tpfsigma in + if subgoals <> [] or exl <> [] then + Util.errorlabstrm "extract_proof" + (if subgoals <> [] then + str "Attempt to save an incomplete proof" + else + str "Attempt to save a proof with existential variables still non-instantiated"); + let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in + env,tpfsigma,pfterm + + +let nf_betaiotazeta = + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiotazeta + +let nf_betaiota = + let clos_norm_flags flgs env sigma t = + Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags Closure.betaiota + +let cook_proof do_reduce = + let pfs = Pfedit.get_pftreestate () +(* and ident = Pfedit.get_current_proof_name () *) + and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in + let env,sigma,pfterm = extract_pftreestate pfs in + let pfterm = + if do_reduce + then nf_betaiota env sigma pfterm + else pfterm + in + (ident, + ({ const_entry_body = pfterm; + const_entry_type = Some concl; + const_entry_opaque = false; + const_entry_boxed = false}, + strength, hook)) + + +let new_save_named opacity = + let id,(const,persistence,hook) = cook_proof true in + let const = { const with const_entry_opaque = opacity } in + save true id const persistence hook + +let get_proof_clean do_reduce = + let result = cook_proof do_reduce in + Pfedit.delete_current_proof (); + result + + + + +(**********************) + +type function_info = + { + function_constant : constant; + graph_ind : inductive; + equation_lemma : constant option; + correctness_lemma : constant option; + completeness_lemma : constant option; + rect_lemma : constant option; + rec_lemma : constant option; + prop_lemma : constant option; + } + + +type function_db = function_info list + +let function_table = ref ([] : function_db) + -(* (\************************************************\) *) -(* (\* Should be removed latter *\) *) -(* (\* Comes from new induction (cf Pierre) *\) *) -(* (\************************************************\) *) - -(* open Sign *) -(* open Term *) - -(* type elim_scheme = *) - -(* (\* { (\\* lists are in reverse order! *\\) *\) *) -(* (\* params: rel_context; (\\* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *\\) *\) *) -(* (\* predicates: rel_context; (\\* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *\\) *\) *) -(* (\* branches: rel_context; (\\* branchr,...,branch1 *\\) *\) *) -(* (\* args: rel_context; (\\* (xni, Ti_ni) ... (x1, Ti_1) *\\) *\) *) -(* (\* indarg: rel_declaration option; (\\* Some (H,I prm1..prmp x1...xni) if present, None otherwise *\\) *\) *) -(* (\* concl: types; (\\* Qi x1...xni HI, some prmis may not be present *\\) *\) *) -(* (\* indarg_in_concl:bool; (\\* true if HI appears at the end of conclusion (dependent scheme) *\\) *\) *) -(* (\* } *\) *) - - - -(* let occur_rel n c = *) -(* let res = not (noccurn n c) in *) -(* res *) - -(* let list_filter_firsts f l = *) -(* let rec list_filter_firsts_aux f acc l = *) -(* match l with *) -(* | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l' *) -(* | _ -> acc,l *) -(* in *) -(* list_filter_firsts_aux f [] l *) - -(* let count_rels_from n c = *) -(* let rels = Termops.free_rels c in *) -(* let cpt,rg = ref 0, ref n in *) -(* while Util.Intset.mem !rg rels do *) -(* cpt:= !cpt+1; rg:= !rg+1; *) -(* done; *) -(* !cpt *) - -(* let count_nonfree_rels_from n c = *) -(* let rels = Termops.free_rels c in *) -(* if Util.Intset.exists (fun x -> x >= n) rels then *) -(* let cpt,rg = ref 0, ref n in *) -(* while not (Util.Intset.mem !rg rels) do *) -(* cpt:= !cpt+1; rg:= !rg+1; *) -(* done; *) -(* !cpt *) -(* else raise Not_found *) - -(* (\* cuts a list in two parts, first of size n. Size must be greater than n *\) *) -(* let cut_list n l = *) -(* let rec cut_list_aux acc n l = *) -(* if n<=0 then acc,l *) -(* else match l with *) -(* | [] -> assert false *) -(* | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in *) -(* let res = cut_list_aux [] n l in *) -(* res *) - -(* let exchange_hd_prod subst_hd t = *) -(* let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) *) - -(* let compute_elim_sig elimt = *) -(* (\* conclusion is the final (Qi ...) *\) *) -(* let hyps,conclusion = decompose_prod_assum elimt in *) -(* (\* ccl is conclusion where Qi (that is rel <something>) is replaced *) -(* by a constant (Prop) to avoid it being counted as an arg or *) -(* parameter in the following. *\) *) -(* let ccl = exchange_hd_prod mkProp conclusion in *) -(* (\* indarg is the inductive argument if it exists. If it exists it is *) -(* the last hyp before the conclusion, so it is the first element of *) -(* hyps. To know the first elmt is an inductive arg, we check if the *) -(* it appears in the conclusion (as rel 1). If yes, then it is not *) -(* an inductive arg, otherwise it is. There is a pathological case *) -(* with False_inf where Qi is rel 1, so we first get rid of Qi in *) -(* ccl. *\) *) -(* (\* if last arg of ccl is an application then this a functional ind *) -(* principle *\) let last_arg_ccl = *) -(* try List.hd (List.rev (snd (decompose_app ccl))) *) -(* with Failure "hd" -> mkProp in (\* dummy constr that is not an app *) -(* *\) let hyps',indarg,dep = *) -(* if isApp last_arg_ccl *) -(* then *) -(* hyps,None , false (\* no HI at all *\) *) -(* else *) -(* try *) -(* if noccurn 1 ccl (\* rel 1 does not occur in ccl *\) *) -(* then *) -(* List.tl hyps , Some (List.hd hyps), false (\* it does not *) -(* occur in concl *\) else *) -(* List.tl hyps , Some (List.hd hyps) , true (\* it does occur in concl *\) *) -(* with Failure s -> Util.error "cannot recognise an induction schema" *) -(* in *) - -(* (\* Arguments [xni...x1] must appear in the conclusion, so we count *) -(* successive rels appearing in conclusion **Qi is not considered a *) -(* rel** *\) let nargs = count_rels_from *) -(* (match indarg with *) -(* | None -> 1 *) -(* | Some _ -> 2) ccl in *) -(* let args,hyps'' = cut_list nargs hyps' in *) -(* let rel_is_pred (_,_,c) = isSort (snd(decompose_prod_assum c)) in *) -(* let branches,hyps''' = *) -(* list_filter_firsts (function x -> not (rel_is_pred x)) hyps'' *) -(* in *) -(* (\* Now we want to know which hyps remaining are predicates and which *) -(* are parameters *\) *) -(* (\* We rebuild *) - -(* forall (x1:Ti_1) (xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY *) -(* x1...xni HI ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^ *) -(* optional *) -(* opt *) - -(* Free rels appearing in this term are parameters. We catch all of *) -(* them if HI is present. In this case the number of parameters is *) -(* the number of free rels. Otherwise (principle generated by *) -(* functional induction or by hand) WE GUESS that all parameters *) -(* appear in Ti_js, IS THAT TRUE??. *) - -(* TODO: if we want to generalize to the case where arges are merged *) -(* with branches (?) and/or where several predicates are cited in *) -(* the conclusion, we should do something more precise than just *) -(* counting free rels. *) -(* *\) *) -(* let concl_with_indarg = *) -(* match indarg with *) -(* | None -> ccl *) -(* | Some c -> it_mkProd_or_LetIn ccl [c] in *) -(* let concl_with_args = it_mkProd_or_LetIn concl_with_indarg args in *) -(* (\* let nparams2 = Util.Intset.cardinal (Termops.free_rels concl_with_args) in *\) *) -(* let nparams = *) -(* try List.length (hyps'''@branches) - count_nonfree_rels_from 1 *) -(* concl_with_args with Not_found -> 0 in *) -(* let preds,params = cut_list (List.length hyps''' - nparams) hyps''' in *) -(* let elimscheme = { *) -(* params = params; *) -(* predicates = preds; *) -(* branches = branches; *) -(* args = args; *) -(* indarg = indarg; *) -(* concl = conclusion; *) -(* indarg_in_concl = dep; *) -(* } *) -(* in *) -(* elimscheme *) - -(* let get_params elimt = *) -(* (compute_elim_sig elimt).params *) -(* (\************************************************\) *) -(* (\* end of Should be removed latter *\) *) -(* (\* Comes from new induction (cf Pierre) *\) *) -(* (\************************************************\) *) +let rec do_cache_info finfo = function + | [] -> raise Not_found + | (finfo'::finfos as l) -> + if finfo' == finfo then l + else if finfo'.function_constant = finfo.function_constant + then finfo::finfos + else + let res = do_cache_info finfo finfos in + if res == finfos then l else finfo'::l + +let cache_Function (_,(finfos)) = + let new_tbl = + try do_cache_info finfos !function_table + with Not_found -> finfos::!function_table + in + if new_tbl != !function_table + then function_table := new_tbl + +let load_Function _ = cache_Function +let open_Function _ = cache_Function +let subst_Function (_,subst,finfos) = + let do_subst_con c = fst (Mod_subst.subst_con subst c) + and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i) + in + let function_constant' = do_subst_con finfos.function_constant in + let graph_ind' = do_subst_ind finfos.graph_ind in + let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in + let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in + let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in + let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in + let prop_lemma' = Util.option_smartmap do_subst_con finfos.prop_lemma in + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && + equation_lemma' == finfos.equation_lemma && + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then finfos + else + { function_constant = function_constant'; + graph_ind = graph_ind'; + equation_lemma = equation_lemma' ; + correctness_lemma = correctness_lemma' ; + completeness_lemma = completeness_lemma' ; + rect_lemma = rect_lemma' ; + rec_lemma = rec_lemma'; + prop_lemma = prop_lemma'; + } + +let classify_Function (_,infos) = Libobject.Substitute infos + +let export_Function infos = Some infos + + +let discharge_Function (_,finfos) = + let function_constant' = Lib.discharge_con finfos.function_constant + and graph_ind' = Lib.discharge_inductive finfos.graph_ind + and equation_lemma' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma + in + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && + equation_lemma' == finfos.equation_lemma && + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then Some finfos + else + Some { function_constant = function_constant' ; + graph_ind = graph_ind' ; + equation_lemma = equation_lemma' ; + correctness_lemma = correctness_lemma' ; + completeness_lemma = completeness_lemma'; + rect_lemma = rect_lemma'; + rec_lemma = rec_lemma'; + prop_lemma = prop_lemma' ; + } + +open Term +let pr_info f_info = + str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + str "function_constant_type := " ++ + (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ + str "equation_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ + str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ + str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ + str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ + str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ + str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ + str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + +let pr_table l = + Util.prlist_with_sep fnl pr_info l + +let in_Function,out_Function = + Libobject.declare_object + {(Libobject.default_object "FUNCTIONS_DB") with + Libobject.cache_function = cache_Function; + Libobject.load_function = load_Function; + Libobject.classify_function = classify_Function; + Libobject.subst_function = subst_Function; + Libobject.export_function = export_Function; + Libobject.discharge_function = discharge_Function +(* Libobject.open_function = open_Function; *) + } + + + +(* Synchronisation with reset *) +let freeze () = + let tbl = !function_table in +(* Pp.msgnl (str "freezing function_table : " ++ pr_table tbl); *) + tbl + +let unfreeze l = +(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) + function_table := + l +let init () = +(* Pp.msgnl (str "reseting function_table"); *) + function_table := [] + +let _ = + Summary.declare_summary "functions_db_sum" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } + +let find_or_none id = + try Some + (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" + ) + with Not_found -> None + + + +let find_Function_infos f = + List.find (fun finfo -> finfo.function_constant = f) !function_table + + +let find_Function_of_graph ind = + List.find (fun finfo -> finfo.graph_ind = ind) !function_table + +let update_Function finfo = +(* Pp.msgnl (pr_info finfo); *) + Lib.add_anonymous_leaf (in_Function finfo) + + +let add_Function f = + let f_id = id_of_label (con_label f) in + let equation_lemma = find_or_none (mk_equation_id f_id) + and correctness_lemma = find_or_none (mk_correct_id f_id) + and completeness_lemma = find_or_none (mk_complete_id f_id) + and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") + and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") + and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") + and graph_ind = + match Nametab.locate (make_short_qualid (mk_rel_id f_id)) + with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" + in + let finfos = + { function_constant = f; + equation_lemma = equation_lemma; + completeness_lemma = completeness_lemma; + correctness_lemma = correctness_lemma; + rect_lemma = rect_lemma; + rec_lemma = rec_lemma; + prop_lemma = prop_lemma; + graph_ind = graph_ind + } + in + update_Function finfos + +let pr_table () = pr_table !function_table +(*********************************) +(* Debuging *) +let function_debug = ref false +open Goptions + +let function_debug_sig = + { + optsync = false; + optname = "Function debug"; + optkey = PrimaryTable("Function_debug"); + optread = (fun () -> !function_debug); + optwrite = (fun b -> function_debug := b) + } + +let _ = declare_bool_option function_debug_sig + + +let do_observe () = + !function_debug = true + + + diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli index ab5195b0..00e1ce8d 100644 --- a/contrib/funind/indfun_common.mli +++ b/contrib/funind/indfun_common.mli @@ -1,7 +1,15 @@ open Names open Pp +(* + The mk_?_id function build different name w.r.t. a function + Each of their use is justified in the code +*) val mk_rel_id : identifier -> identifier +val mk_correct_id : identifier -> identifier +val mk_complete_id : identifier -> identifier +val mk_equation_id : identifier -> identifier + val msgnl : std_ppcmds -> unit @@ -39,3 +47,59 @@ val refl_equal : Term.constr Lazy.t val const_of_id: identifier -> constant +(* [save_named] is a copy of [Command.save_named] but uses + [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] + + + + DON'T USE IT if you cannot ensure that there is no VMcast in the proof + +*) + +(* val nf_betaiotazeta : Reductionops.reduction_function *) + +val new_save_named : bool -> unit + +val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> + Tacexpr.declaration_hook -> unit + +(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and + abort the proof +*) +val get_proof_clean : bool -> + Names.identifier * + (Entries.definition_entry * Decl_kinds.goal_kind * + Tacexpr.declaration_hook) + + + + +(*****************) + +type function_info = + { + function_constant : constant; + graph_ind : inductive; + equation_lemma : constant option; + correctness_lemma : constant option; + completeness_lemma : constant option; + rect_lemma : constant option; + rec_lemma : constant option; + prop_lemma : constant option; + } + +val find_Function_infos : constant -> function_info +val find_Function_of_graph : inductive -> function_info +(* WARNING: To be used just after the graph definition !!! *) +val add_Function : constant -> unit + +val update_Function : function_info -> unit + + +(** debugging *) +val pr_info : function_info -> Pp.std_ppcmds +val pr_table : unit -> Pp.std_ppcmds + + +val function_debug : bool ref +val do_observe : unit -> bool diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 index 61f26d30..00b5f28c 100644 --- a/contrib/funind/indfun_main.ml4 +++ b/contrib/funind/indfun_main.ml4 @@ -14,6 +14,7 @@ open Indfun_common open Indfun open Genarg open Pcoq +open Tacticals let pr_binding prc = function | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) @@ -36,7 +37,8 @@ let pr_with_bindings prc prlc (c,bl) = let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () - | Some c -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc c) + | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b)) + ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings_opt @@ -47,25 +49,9 @@ END TACTIC EXTEND newfuninv - [ "functional" "inversion" ident(hyp) ident(fname) fun_ind_using(princl)] -> + [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ - fun g -> - let fconst = const_of_id fname in - let princ = - match princl with - | None -> - let f_ind_id = - ( - Indrec.make_elimination_ident - fname - (Tacticals.elimination_sort_of_goal g) - ) - in - let princ = const_of_id f_ind_id in - princ - | Some princ -> destConst (fst princ) - in - Invfun.invfun hyp fconst princ g + Invfun.invfun hyp fname ] END @@ -82,26 +68,11 @@ ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat END -let is_rec scheme_info = - let test_branche min acc (_,_,br) = - acc || - (let new_branche = Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in - let free_rels_in_br = Termops.free_rels new_branche in - let max = min + scheme_info.Tactics.npredicates in - Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br) - in - Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) - - -let choose_dest_or_ind scheme_info = - if is_rec scheme_info - then Tactics.new_induct - else Tactics.new_destruct TACTIC EXTEND newfunind ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ + [ let pat = match pat with | None -> IntroAnonymous @@ -112,77 +83,23 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> applist(c,cl) in - let f,args = decompose_app c in - fun g -> - let princ,bindings = - match princl with - | None -> (* No principle is given let's find the good one *) - let fname = - match kind_of_term f with - | Const c' -> - id_of_label (con_label c') - | _ -> Util.error "Must be used with a function" - in - let princ_name = - ( - Indrec.make_elimination_ident - fname - (Tacticals.elimination_sort_of_goal g) - ) - in - mkConst(const_of_id princ_name ),Rawterm.NoBindings - | Some princ -> princ - in - let princ_type = Tacmach.pf_type_of g princ in - let princ_infos = Tactics.compute_elim_sig princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> - try Idset.add (destVar a) acc - with _ -> acc - ) - args - Idset.empty - in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in - let subst_and_reduce g = - let idl = - Util.map_succeed - (fun id -> - if Idset.mem id old_idl then failwith ""; - id - ) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - } - in - Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) - (Hiddentac.h_reduce flag Tacticals.allClauses) - g - in - Tacticals.tclTHEN - (choose_dest_or_ind - princ_infos - args_as_induction_constr - princ' - pat) - subst_and_reduce - g - ] + functional_induction true c princl pat ] +END +(***** debug only ***) +TACTIC EXTEND snewfunind + ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let pat = + match pat with + | None -> IntroAnonymous + | Some pat -> pat + in + let c = match cl with + | [] -> assert false + | [c] -> c + | c::cl -> applist(c,cl) + in + functional_induction false c princl pat ] END @@ -213,7 +130,10 @@ VERNAC ARGUMENT EXTEND rec_definition2 in let check_exists_args an = try - let id = match an with Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args" in + let id = match an with + | Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id + | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args" + in (try ignore(Util.list_index (Name id) names - 1); annot with Not_found -> Util.user_err_loc (Util.dummy_loc,"Function", @@ -240,12 +160,15 @@ END VERNAC COMMAND EXTEND Function ["Function" rec_definitions2(recsl)] -> - [ do_generate_principle false recsl] + [ + do_generate_principle false recsl; + + ] END VERNAC ARGUMENT EXTEND fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" ident(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] END VERNAC ARGUMENT EXTEND fun_scheme_args @@ -257,29 +180,176 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ["Functional" "Scheme" fun_scheme_args(fas) ] -> [ try - Functional_principles_types.make_scheme fas + Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> match fas with | (_,fun_name,_)::_ -> begin - make_graph fun_name; - try Functional_principles_types.make_scheme fas + make_graph (Nametab.global fun_name); + try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") end | _ -> assert false (* we can only have non empty list *) ] END - +(***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase ["Functional" "Case" fun_scheme_arg(fas) ] -> [ - Functional_principles_types.make_case_scheme fas + Functional_principles_types.build_case_scheme fas ] END - +(***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph -["Generate" "graph" "for" ident(c)] -> [ make_graph c ] +["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] +END + + + + + +(* FINDUCTION *) + +(* comment this line to see debug msgs *) +(* let msg x = () ;; let pr_lconstr c = str "" *) + (* uncomment this to see debugging *) +let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prlistconstr lc = List.iter prconstr lc +let prstr s = msg(str s) + + + +(** Information about an occurrence of a function call (application) + inside a term. *) +type fapp_info = { + fname: constr; (** The function applied *) + largs: constr list; (** List of arguments *) + free: bool; (** [true] if all arguments are debruijn free *) + max_rel: int; (** max debruijn index in the funcall *) + onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) +} + + +(** [constr_head_match(a b c) a] returns true, false otherwise. *) +let constr_head_match u t= + if isApp u + then + let uhd,args= destApp u in + uhd=t + else false + +(** [hdMatchSub inu t] returns the list of occurrences of [t] in + [inu]. DeBruijn are not pushed, so some of them may be unbound in + the result. *) +let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = + let subres = + match kind_of_term inu with + | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> + hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test + | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) + Array.fold_left + (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) + [] bl + | _ -> (* Cofix will be wrong *) + fold_constr + (fun l cstr -> + l @ hdMatchSub cstr test) [] inu in + if not (test inu) then subres + else + let f,args = decompose_app inu in + let freeset = Termops.free_rels inu in + let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in + {fname = f; largs = args; free = Util.Intset.is_empty freeset; + max_rel = max_rel; onlyvars = List.for_all isVar args } + ::subres + + +(** [find_fapp test g] returns the list of [app_info] of all calls to + functions that satisfy [test] in the conclusion of goal g. Trivial + repetition (not modulo conversion) are deleted. *) +let find_fapp (test:constr -> bool) g : fapp_info list = + let pre_res = hdMatchSub (Tacmach.pf_concl g) test in + let res = + List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in + (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); + res) + + + +(** [finduction id filter g] tries to apply functional induction on + an occurence of function [id] in the conclusion of goal [g]. If + [id]=[None] then calls to any function are selected. In any case + [heuristic] is used to select the most pertinent occurrence. *) +let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) + (nexttac:Proof_type.tactic) g = + let test = match oid with + | Some id -> + let idconstr = mkConst (const_of_id id) in + (fun u -> constr_head_match u idconstr) (* select only id *) + | None -> (fun u -> isApp u) in (* select calls to any function *) + let info_list = find_fapp test g in + let ordered_info_list = heuristic info_list in + prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); + if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; + let taclist: Proof_type.tactic list = + List.map + (fun info -> + (tclTHEN + (functional_induction true (applist (info.fname, info.largs)) + None IntroAnonymous) + nexttac)) ordered_info_list in + tclFIRST taclist g + + + + +(** [chose_heuristic oi x] returns the heuristic for reordering + (and/or forgetting some elts of) a list of occurrences of + function calls infos to chose first with functional induction. *) +let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = + match oi with + | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) + | None -> + (* Default heuristic: keep only occurrence where all arguments + are *bound* (meaning already introduced) variables *) + (* TODO: put other funcalls at the end instead of deleting them *) + let ordering x y = + if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) + else if x.free && x.onlyvars then -1 + else if y.free && y.onlyvars then 1 + else 0 (* both not pertinent *) + in + List.sort ordering + + +TACTIC EXTEND finduction + ["finduction" ident(id) natural_opt(oi)] -> + [ + match oi with + | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" + | _ -> + let heuristic = chose_heuristic oi in + finduction (Some id) heuristic tclIDTAC + ] +END + + + +TACTIC EXTEND fauto + [ "fauto" tactic(tac)] -> + [ + let heuristic = chose_heuristic None in + finduction None heuristic (snd tac) + ] + | + [ "fauto" ] -> + [ + let heuristic = chose_heuristic None in + finduction None heuristic tclIDTAC + ] + END + diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index 2e5616f0..084ec7e0 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -1,7 +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 *) +(************************************************************************) +open Tacexpr +open Declarations open Util open Names open Term -open Tacinvutils open Pp open Libnames open Tacticals @@ -9,131 +17,963 @@ open Tactics open Indfun_common open Tacmach open Sign +open Hiddentac +(* Some pretty printing function for debugging purpose *) -let tac_pattern l = - (Hiddentac.h_reduce - (Rawterm.Pattern l) - Tacticals.onConcl - ) +let pr_binding prc = + function + | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) +let pr_bindings prc prlc = function + | Rawterm.ImplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc prc l + | Rawterm.ExplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | Rawterm.NoBindings -> mt () -let 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 -let intro_discr_until n tac : tactic = - let rec intro_discr_until acc : tactic = - fun g -> - if nb_prod (pf_concl g) <= n then tac (List.rev acc) g - else - tclTHEN - intro - (fun g' -> - let id,_,t = pf_last_hyp g' in - tclORELSE - (tclABSTRACT None (Extratactics.h_discrHyp (Rawterm.NamedHyp id))) - (intro_discr_until ((id,t)::acc)) - g' - ) - g +let pr_with_bindings prc prlc (c,bl) = + prc c ++ hv 0 (pr_bindings prc prlc bl) + + + +let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = + pr_with_bindings prc prc (c,bl) + +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in + let msg = + Util.option_fold_right + (fun o msg -> msg ++ fnl () ++ str "indarg := " ++ Printer.pr_rel_context env [o]) + el.indarg + msg + in + let env = Util.option_fold_right (fun o env -> Environ.push_rel_context [o] env) el.indarg env in + msg ++ fnl () ++ str "concl := " ++ Printer.pr_lconstr_env env el.concl + +(* The local debuging mechanism *) +let msgnl = Pp.msgnl + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () + +let observennl strm = + if do_observe () + then begin Pp.msg strm;Pp.pp_flush () end + else () + + +let do_observe_tac s tac g = + try let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v + with e -> + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; + + +let observe_tac s tac g = + if do_observe () + then do_observe_tac (str s) tac g + else tac g + +(* [nf_zeta] $\zeta$-normalization of a term *) +let nf_zeta = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + Environ.empty_env + Evd.empty + + +(* [id_to_constr id] finds the term associated to [id] in the global environment *) +let id_to_constr id = + try + Tacinterp.constr_of_id (Global.env ()) id + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) + +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. + + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion + *) + +let generate_type g_to_f f graph i = + (*i we deduce the number of arguments of the function and its returned type from the graph i*) + let graph_arity = Inductive.type_of_inductive (Global.lookup_inductive (destInd graph)) in + let ctxt,_ = decompose_prod_assum graph_arity in + let fun_ctxt,res_type = + match ctxt with + | [] | [_] -> anomaly "Not a valid context" + | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type in - intro_discr_until [] - - -let rec discr_rew_in_H hypname idl : tactic = - match idl with - | [] -> (Extratactics.h_discrHyp (Rawterm.NamedHyp hypname)) - | ((id,t)::idl') -> - match kind_of_term t with - | App(eq',[| _ ; arg1 ; _ |]) when eq_constr eq' (Lazy.force eq) -> - begin - let constr,_ = decompose_app arg1 in - if isConstruct constr - then - (discr_rew_in_H hypname idl') - else - tclTHEN - (tclTRY (Equality.general_rewrite_in true hypname (mkVar id))) - (discr_rew_in_H hypname idl') - end - | _ -> discr_rew_in_H hypname idl' - -let finalize fname hypname idl : tactic = - tclTRY ( - (tclTHEN - (Hiddentac.h_reduce - (Rawterm.Unfold [[],EvalConstRef fname]) - (Tacticals.onHyp hypname) - ) - (discr_rew_in_H hypname idl) - )) + let nb_args = List.length fun_ctxt in + let args_from_decl i decl = + match decl with + | (_,Some _,_) -> incr i; failwith "args_from_decl" + | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) + in + (*i We need to name the vars [res] and [fv] i*) + let res_id = + Termops.next_global_ident_away + true + (id_of_string "res") + (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) + in + let fv_id = + Termops.next_global_ident_away + true + (id_of_string "fv") + (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) + in + (*i we can then type the argument to be applied to the function [f] i*) + let args_as_rels = + let i = ref 0 in + Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) + in + let args_as_rels = Array.map Termops.pop args_as_rels in + (*i + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let res_eq_f_of_args = + mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + in + (*i + The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let graph_applied = + let args_and_res_as_rels = + let i = ref 0 in + Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) + in + let args_and_res_as_rels = + Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels + in + mkApp(graph,args_and_res_as_rels) + in + (*i The [pre_context] is the defined to be the context corresponding to + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] + i*) + let pre_ctxt = + (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt + in + (*i and we can return the solution depending on which lemma type we are defining i*) + if g_to_f + then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) + else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) -let gen_fargs fargs : tactic = - fun g -> - generalize - (List.map - (fun arg -> - let targ = pf_type_of g arg in - let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in - refl_arg - ) - (Array.to_list fargs) - ) - g - -let invfun (hypname:identifier) fname princ : tactic= - fun g -> - let nprod_goal = nb_prod (pf_concl g) in - let princ_info = - let princ_type = - (try (match (Global.lookup_constant princ) with - {Declarations.const_type=t} -> t - ) - with _ -> assert false) +(* + [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] + + WARNING: while convertible, [type_of body] and [type] can be non equal +*) +let find_induction_principle f = + let f_as_constant = match kind_of_term f with + | Const c' -> c' + | _ -> error "Must be used with a function" + in + let infos = find_Function_infos f_as_constant in + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let rect_lemma = mkConst rect_lemma in + let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in + rect_lemma,typ + + + +(* let fname = *) +(* match kind_of_term f with *) +(* | Const c' -> *) +(* id_of_label (con_label c') *) +(* | _ -> error "Must be used with a function" *) +(* in *) + +(* let princ_name = *) +(* ( *) +(* Indrec.make_elimination_ident *) +(* fname *) +(* InType *) +(* ) *) +(* in *) +(* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *) +(* c,Typing.type_of (Global.env ()) Evd.empty c *) + + +let rec generate_fresh_id x avoid i = + if i == 0 + then [] + else + let id = Termops.next_global_ident_away true x avoid in + id::(generate_fresh_id x (id::avoid) (pred i)) + + +(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + + [functional_induction] is the tactic defined in [indfun] (dependency problem) + [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove correct + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $x_n$ + \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + apply the corresponding constructor of the corresponding graph inductive. + \end{enumerate} + +*) +let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = + fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> + match ctxt with + | [] | [_] | [_;_] -> anomaly "bad context" + | hres::res::(x,_,t)::ctxt -> + Termops.it_mkLambda_or_LetIn + ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res]) + ((x,None,t)::ctxt) + ) + lemmas_types_infos + in + (* we the get the definition of the graphs block *) + let graph_ind = destInd graphs_constr.(i) in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle,princ_type = schemes.(i) in + let princ_type = nf_zeta princ_type in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* The number of args of the function is then easilly computable *) + let nb_fun_args = nb_prod (pf_concl g) - 2 in + let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* Since we cannot ensure that the funcitonnal principle is defined in the + environement and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> Genarg.IntroIdentifier id) + (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + ) + branches + in + (* before building the full intro pattern for the principle *) + let pat = Genarg.IntroOrAndPattern intro_pats in + let eq_ind = Coqlib.build_coq_eq () in + let eq_construct = mkConstruct((destInd eq_ind),1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 + and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branche i g = + (* We get the identifiers of this branch *) + let this_branche_ids = + List.fold_right + (fun pat acc -> + match pat with + | Genarg.IntroIdentifier id -> Idset.add id acc + | _ -> anomaly "Not an identifier" + ) + (List.nth intro_pats (pred i)) + Idset.empty in - Tactics.compute_elim_sig princ_type + (* and get the real args of the branch by unfolding the defined constant *) + let pre_args,pre_tac = + List.fold_right + (fun (id,b,t) (pre_args,pre_tac) -> + if Idset.mem id this_branche_ids + then + match b with + | None -> (id::pre_args,pre_tac) + | Some b -> + (pre_args, + tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac + ) + + else (pre_args,pre_tac) + ) + (pf_hyps g) + ([],tclIDTAC) + in + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + + If [hid] has another type the corresponding argument of the constructor is [hid] + *) + let constructor_args = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_type_of g (mkVar hid) in + match kind_of_term type_of_hid with + | Prod(_,_,t') -> + begin + match kind_of_term t' with + | Prod(_,t'',t''') -> + begin + match kind_of_term t'',kind_of_term t''' with + | App(eq,args), App(graph',_) + when + (eq_constr eq eq_ind) && + array_exists (eq_constr graph') graphs_constr -> + ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::args.(2)::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] + in + (* in fact we must also add the parameters to the constructor args *) + let constructor_args = + let params_id = fst (list_chop princ_infos.nparams args_names) in + (List.map mkVar params_id)@(List.rev constructor_args) + in + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end + in + (* we can then build the final proof term *) + let app_constructor = applist((mkConstruct(constructor)),constructor_args) in + (* an apply the tactic *) + let res,hres = + match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false + in + observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); + ( + tclTHENSEQ + [ + (* unfolding of all the defined variables introduced by this branch *) + observe_tac "unfolding" pre_tac; + (* $zeta$ normalizing of the conclusion *) + h_reduce + (Rawterm.Cbv + { Rawterm.all_flags with + Rawterm.rDelta = false ; + Rawterm.rConst = [] + } + ) + onConcl; + (* introducing the the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP h_intro [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); + (* Conclusion *) + observe_tac "exact" (h_exact app_constructor) + ] + ) + g in - let _,_,typhyp = List.find (fun (id,_,_) -> hypname=id) (pf_hyps g) in - let do_invert fargs appf : tactic = - let frealargs = (snd (array_chop (List.length princ_info.params) fargs)) + (* end of branche proof *) + let param_names = fst (list_chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings,avoid = + List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in + (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid + ) + ([],[]) + princ_infos.params + (List.rev params) in - let pat_args = - (List.map (fun e -> ([Rawterm.ArgArg (-1)],e)) (Array.to_list frealargs)) @ [[],appf] + let lemmas_bindings = + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) (x,_,_) p -> + let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in + (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) in - tclTHENSEQ - [ - gen_fargs frealargs; - tac_pattern pat_args; - Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings); - intro_discr_until nprod_goal (finalize fname hypname) - + Rawterm.ExplicitBindings (params_bindings@lemmas_bindings) + in + tclTHENSEQ + [ observe_tac "intro args_names" (tclMAP h_intro args_names); + observe_tac "principle" (forward + (Some (h_exact f_principle)) + (Genarg.IntroIdentifier principle_id) + princ_type); + tclTHEN_i + (observe_tac "functional_induction" ( + fun g -> + observe + (str "princ" ++ pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); + functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) + (Some (mkVar principle_id,bindings)) + pat g + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + +(* [generalize_depedent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] +*) +let generalize_depedent_of x hyp g = + tclMAP + (function + | (id,None,t) when not (id = hyp) && + (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id] + | _ -> tclIDTAC + ) + (pf_hyps g) + g + +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completness lemma. + + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove complete + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $H:graph\ x_1\ldots x_n\ res$ + \item $elim\ H$ using schemes.(i) + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, + after all intros, the conclusion should be a reflexive equality. + \end{enumerate} + +*) + + +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = + fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) + lemmas_types_infos + in + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = nf_zeta schemes.(i) in + let princ_type = pf_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = nb_prod (pf_concl g) - 2 in + let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res,hres,graph_principle_id = + match generate_fresh_id (id_of_string "z") ids 3 with + | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | _ -> assert false + in + let ids = res::hres::graph_principle_id::ids in + (* we also compute fresh names for each hyptohesis of each branche of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> id) + (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) + ) + branches + in + let eq_ind = Coqlib.build_coq_eq () in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : tactic = + let graph_def = graphs.(j) in + if Rtree.is_infinite graph_def.mind_recargs + then + let eq_lemma = + try out_some (find_Function_infos (destConst funcs.(j))).equation_lemma + with Failure "out_some" | Not_found -> anomaly "Cannot find equation lemma" + in + tclTHENSEQ[ + tclMAP h_intro ids; + Equality.rewriteLR (mkConst eq_lemma); + (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + h_generalize (List.map mkVar ids); + thin ids ] + else unfold_in_concl [([],Names.EvalConstRef (destConst f))] + in + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) + *) + let rec intros_with_rewrite_aux : tactic = + fun g -> + match kind_of_term (pf_concl g) with + | Prod(_,t,t') -> + begin + match kind_of_term t with + | App(eq,args) when (eq_constr eq eq_ind) -> + if isVar args.(1) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; + generalize_depedent_of (destVar args.(1)) id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ[ + h_intro id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] g + end + | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + Tauto.tauto g + | Case(_,_,v,_) -> + tclTHENSEQ[ + h_case (v,Rawterm.NoBindings); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id;intros_with_rewrite] g + end + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g + and intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branche i g = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then !ind_number + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + let this_branche_ids = List.nth intro_pats (pred i) in + tclTHENSEQ[ + (* we expand the definition of the function *) + observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); + (* introduce hypothesis with some rewrite *) + (intros_with_rewrite); + (* The proof is complete *) + observe_tac "reflexivity" (reflexivity) + ] + g + in + let params_names = fst (list_chop princ_infos.nparams args_names) in + let params = List.map mkVar params_names in + tclTHENSEQ + [ tclMAP h_intro (args_names@[res;hres]); + observe_tac "h_generalize" + (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + h_intro graph_principle_id; + observe_tac "" (tclTHEN_i + (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) + (fun i g -> prove_branche i g )) + ] + g + + + + +let do_save () = Command.save_named false + + +(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness + lemmas for each function in [funs] w.r.t. [graphs] + + [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and + [functional_induction] is Indfun.functional_induction (same pb) +*) + +let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + let funs = Array.of_list funs and graphs = Array.of_list graphs in + let funs_constr = Array.map mkConst funs in + try + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + generate_type false const_of_f graph i + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if Array.length funs_constr <> 1 then raise Not_found; + [| find_induction_principle funs_constr.(0) |] + with Not_found -> + Array.of_list + (List.map + (fun entry -> + (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type ) + ) + (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) + ) in - match kind_of_term typhyp with - | App(eq',[| _ ; arg1 ; arg2 |]) when eq_constr eq' (Lazy.force eq) -> -(* let valf = def_of_const (mkConst fname) in *) - let eq_arg1 , eq_arg2 , good_eq_form , fargs = - match kind_of_term arg1 , kind_of_term arg2 with - | App(f, args),_ when eq_constr f (mkConst fname) -> - arg1 , arg2 , tclIDTAC , args - | _,App(f, args) when eq_constr f (mkConst fname) -> - arg2 , arg1 , symmetry_in hypname , args - | _ , _ -> error "inversion impossible" - in - tclTHEN - good_eq_form - (do_invert fargs eq_arg1) - g - | App(f',fargs) when eq_constr f' (mkConst fname) -> - do_invert fargs typhyp g - - - | _ -> error "inversion impossible" + let proving_tac = + prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = id_of_label (con_label f_as_constant) in + Command.start_proof + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_correct_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i)) + (fun _ _ -> ()); + Pfedit.by (observe_tac ("procve correctness ("^(string_of_id f_id)^")") (proving_tac i)); + do_save (); + let finfo = find_Function_infos f_as_constant in + update_Function + {finfo with + correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) + } + + ) + funs; + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + generate_type true const_of_f graph i + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let kn,_ as graph_ind = destInd graphs_constr.(0) in + let mib,mip = Global.lookup_inductive graph_ind in + let schemes = + Array.of_list + (Indrec.build_mutual_indrec (Global.env ()) Evd.empty + (Array.to_list + (Array.mapi + (fun i mip -> (kn,i),mib,mip,true,InType) + mib.Declarations.mind_packets + ) + ) + ) + in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = id_of_label (con_label f_as_constant) in + Command.start_proof + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + (mk_complete_id f_id) + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + (fst lemmas_types_infos.(i)) + (fun _ _ -> ()); + Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); + do_save (); + let finfo = find_Function_infos f_as_constant in + update_Function + {finfo with + completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) + } + ) + funs; + with e -> + (* In case of problem, we reset all the lemmas *) + (*i The next call to mk_correct_id is valid since we are erasing the lemmas + Ensures by: obvious + i*) + let first_lemma_id = + let f_id = id_of_label (con_label funs.(0)) in + + mk_correct_id f_id + in + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); + raise e + + + + + +(***********************************************) + +(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res + when [kn] denotes a graph block into + f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result + + if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing +*) +let revert_graph kn post_tac hid g = + let typ = pf_type_of g (mkVar hid) in + match kind_of_term typ with + | App(i,args) when isInd i -> + let ((kn',num) as ind') = destInd i in + if kn = kn' + then (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + try find_Function_of_graph ind' + with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) + anomaly "Cannot retrieve infos about a mutual block" + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC g + | Some f_complete -> + let f_args,res = array_chop (Array.length args - 1) args in + tclTHENSEQ + [ + h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; + thin [hid]; + h_intro hid; + post_tac hid + ] + g + + else tclIDTAC g + | _ -> tclIDTAC g + + +(* + [functional_inversion hid fconst f_correct ] is the functional version of [inversion] + + [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] + is the correctness lemma for [fconst]. + + The sketch is the follwing~: + \begin{enumerate} + \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ + (fails if it is not possible) + \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] + \item apply [inversion] on [hid] + \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever + such a lemma exists) + \end{enumerate} +*) + +let functional_inversion kn hid fconst f_correct : tactic = + fun g -> + let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let type_of_h = pf_type_of g (mkVar hid) in + match kind_of_term type_of_h with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + let pre_tac,f_args,res = + match kind_of_term args.(1),kind_of_term args.(2) with + | App(f,f_args),_ when eq_constr f fconst -> + ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) + |_,App(f,f_args) when eq_constr f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) + | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) + in + tclTHENSEQ[ + pre_tac hid; + h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; + thin [hid]; + h_intro hid; + Inv.inv FullInversion Genarg.IntroAnonymous (Rawterm.NamedHyp hid); + (fun g -> + let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + tclMAP (revert_graph kn pre_tac) (hid::new_ids) g + ); + ] g + | _ -> tclFAIL 1 (mt ()) g + + + +let invfun qhyp f = + let f = + match f with + | ConstRef f -> f + | _ -> raise (Util.UserError("",str "Not a function")) + in + try + let finfos = find_Function_infos f in + let f_correct = mkConst(out_some finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + with + | Not_found -> error "No graph found" + | Failure "out_some" -> error "Cannot use equivalence with graph!" + +let invfun qhyp f g = + match f with + | Some f -> invfun qhyp f g + | None -> + Tactics.try_intros_until + (fun hid g -> + let hyp_typ = pf_type_of g (mkVar hid) in + match kind_of_term hyp_typ with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + begin + let f1,_ = decompose_app args.(1) in + try + if not (isConst f1) then failwith ""; + let finfos = find_Function_infos (destConst f1) in + let f_correct = mkConst(out_some finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f1 f_correct g + with | Failure "" | Failure "out_some" | Not_found -> + try + let f2,_ = decompose_app args.(2) in + if not (isConst f2) then failwith ""; + let finfos = find_Function_infos (destConst f2) in + let f_correct = mkConst(out_some finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct g + with + | Failure "" -> + errorlabstrm "" (Ppconstr.pr_id hid ++ str " must contain at leat one function") + | Failure "out_some" -> + error "Cannot use equivalence with graph for any side of equality" + | Not_found -> error "No graph found for any side of equality" + end + | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") + ) + qhyp + g diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index b6f26dfd..dbf2f944 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -9,11 +9,11 @@ open Util open Rawtermops let observe strm = - if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false + if do_observe () then Pp.msgnl strm else () let observennl strm = - if Tacinterp.get_debug () <> Tactic_debug.DebugOff &&false + if do_observe () then Pp.msg strm else () @@ -44,12 +44,8 @@ let compose_raw_context = (* The main part deals with building a list of raw constructor expressions from the rhs of a fixpoint equation. - - *) - - type 'a build_entry_pre_return = { context : raw_context; (* the binding context of the result *) @@ -62,7 +58,6 @@ type 'a build_entry_return = to_avoid : identifier list } - (* [combine_results combine_fun res1 res2] combine two results [res1] and [res2] w.r.t. [combine_fun]. @@ -113,8 +108,6 @@ let combine_args arg args = let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] -(* | LetTuple(nal,_) -> *) -(* map_succeed (function Name id -> id | _ -> failwith "ids_of_binder") nal *) let rec change_vars_in_binder mapping = function [] -> [] @@ -216,7 +209,6 @@ let combine_app f args = (* Note that the binding context of [args] MUST be placed before the one of the applied value in order to preserve possible type dependencies *) - context = args.context@new_ctxt; value = new_value; } @@ -245,10 +237,9 @@ let mk_result ctxt value avoid = ; to_avoid = avoid } - - -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) +(************************************************* + Some functions to deal with overlapping patterns +**************************************************) let coq_True_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") @@ -256,6 +247,25 @@ let coq_True_ref = let coq_False_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") +(* + [make_discr_match_el \[e1,...en\]] builds match e1,...,en with + (the list of expresions on which we will do the matching) + *) +let make_discr_match_el = + List.map (fun e -> (e,(Anonymous,None))) + +(* + [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. + that is. + match ?????? with \\ + | pat_1 => False \\ + | pat_{i-1} => False \\ + | pat_i => True \\ + | pat_{i+1} => False \\ + \vdots + | pat_n => False + end +*) let make_discr_match_brl i = list_map_i (fun j (_,idl,patl,_) -> @@ -264,84 +274,28 @@ let make_discr_match_brl i = else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) ) 0 - +(* + [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff + brl_{i} is the first branch matched by [el] + + Used when we want to simulate the coq pattern matching algorithm +*) let make_discr_match brl = fun el i -> mkRCases(None, make_discr_match_el el, make_discr_match_brl i brl) - - - -let rec make_pattern_eq_precond id e pat : identifier * (binder_type * Rawterm.rawconstr) list = - match pat with - | PatVar(_,Anonymous) -> assert false - | PatVar(_,Name x) -> - id,[Prod (Name x),mkRHole ();Prod Anonymous,raw_make_eq (mkRVar x) e] - | PatCstr(_,constr,patternl,_) -> - let new_id,new_patternl,patternl_eq_precond = - List.fold_right - (fun pat' (id,new_patternl,preconds) -> - match pat' with - | PatVar (_,Name id) -> (id,id::new_patternl,preconds) - | _ -> - let new_id = Nameops.lift_ident id in - let new_id',pat'_precond = - make_pattern_eq_precond new_id (mkRVar id) pat' - in - (new_id',id::new_patternl,preconds@pat'_precond) - ) - patternl - (id,[],[]) - in - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkRHole ()) - ) - in - let cst_as_term = - mkRApp(mkRRef(Libnames.ConstructRef constr), - implicit_args@(List.map mkRVar new_patternl) - ) - in - let precond' = - (Prod Anonymous, raw_make_eq cst_as_term e)::patternl_eq_precond - in - let precond'' = - List.fold_right - (fun id acc -> - (Prod (Name id),(mkRHole ()))::acc - ) - new_patternl - precond' - in - new_id,precond'' let pr_name = function | Name id -> Ppconstr.pr_id id | Anonymous -> str "_" -let make_pattern_eq_precond id e pat = - let res = make_pattern_eq_precond id e pat in - observe - (prlist_with_sep spc - (function (Prod na,t) -> - str "forall " ++ pr_name na ++ str ":" ++ pr_rawconstr t - | _ -> assert false - ) - (snd res) - ); - res - +(**********************************************************************) +(* functions used to build case expression from lettuple and if ones *) +(**********************************************************************) -let build_constructors_of_type msg ind' argl = +(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) +let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> @@ -366,21 +320,11 @@ let build_constructors_of_type msg ind' argl = let pat_as_term = mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) in -(* Pp.msgnl (str "new constructor := " ++ Printer.pr_rawconstr pat_as_term); *) cases_pattern_of_rawconstr Anonymous pat_as_term ) ind.Declarations.mind_consnames -let find_constructors_of_raw_type msg t argl : Rawterm.cases_pattern array = - let ind,args = raw_decompose_app t in - match ind with - | RRef(_,IndRef ind') -> -(* let _,ind = Global.lookup_inductive ind' in *) - build_constructors_of_type msg ind' argl - | _ -> error msg - - - +(* [find_type_of] very naive attempts to discover the type of an if or a letin *) let rec find_type_of nb b = let f,_ = raw_decompose_app b in match f with @@ -412,18 +356,145 @@ let rec find_type_of nb b = | _ -> raise (Invalid_argument "not a ref") -let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = -(* Pp.msgnl (str " Entering : " ++ Printer.pr_rawconstr rt); *) + + +(******************) +(* Main functions *) +(******************) + + + +let raw_push_named (na,raw_value,raw_typ) env = + match na with + | Anonymous -> env + | Name id -> + let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in + let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in + Environ.push_named (id,value,typ) env + + +let add_pat_variables pat typ env : Environ.env = + let rec add_pat_variables env pat typ : Environ.env = + observe (str "new rel env := " ++ Printer.pr_rel_context_of env); + + match pat with + | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatCstr(_,c,patl,na) -> + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + in + let new_env = add_pat_variables env pat typ in + let res = + fst ( + Sign.fold_rel_context + (fun (na,v,t) (env,ctxt) -> + match na with + | Anonymous -> assert false + | Name id -> + let new_t = substl ctxt t in + let new_v = option_map (substl ctxt) v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ + option_fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ + option_fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + ); + (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) + ) + (Environ.rel_context new_env) + ~init:(env,[]) + ) + in + observe (str "new var env := " ++ Printer.pr_named_context_of res); + res + + + + +let rec pattern_to_term_and_type env typ = function + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + mkRVar id + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + constr + in + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let _,cstl = Inductiveops.dest_ind_family indf in + let csta = Array.of_list cstl in + let implicit_args = + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) + ) + in + let patl_as_term = + List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + in + mkRApp(mkRRef(Libnames.ConstructRef constr), + implicit_args@patl_as_term + ) + +(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) + of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the + corresponding graphs. + + + The idea to transform a term [t] into a list of constructors [lc] is the following: + \begin{itemize} + \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding + to [body] and add (bind x. _) to each elements of [lc] + \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) + then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], + [g c1 ... cn] is an element of [lc] + \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then + compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] + create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] + \item if the term is a cast just treat its body part + \item + if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case + and concatenate them (informally, each branch of a match produces a new constructor) + \end{itemize} + + WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. + We must wait to have complete all the current calculi to set the recursive calls. + At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by + a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. + We in fact not create a constructor list since then end of each constructor has not the expected form + but only the value of the function +*) + + +let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = + observe (str " Entering : " ++ Printer.pr_rawconstr rt); match rt with | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> - mk_result [] rt avoid + (* do nothing (except changing type of course) *) + mk_result [] rt avoid | RApp(_,_,_) -> let f,args = raw_decompose_app rt in let args_res : (rawconstr list) build_entry_return = - List.fold_right + List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> - let arg_res = build_entry_lc funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl + let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in + combine_results combine_args arg_res ctxt_argsl ) args (mk_result [] [] avoid) @@ -431,6 +502,16 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = begin match f with | RVar(_,id) when Idset.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_typ = Typing.type_of env Evd.empty rt_as_constr in + let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkRVar res in @@ -438,7 +519,7 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = List.map (fun arg_res -> let new_hyps = - [Prod (Name res),mkRHole (); + [Prod (Name res),res_raw_type; Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] in {context = arg_res.context@new_hyps; value = res_rt } @@ -447,6 +528,11 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = in { result = new_result; to_avoid = new_avoid } | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) { args_res with result = @@ -455,8 +541,12 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = {args_res with value = mkRApp(f,args_res.value)}) args_res.result } - | RApp _ -> assert false (* we have collected all the app *) + | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) | RLetIn(_,n,t,b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) let new_n,new_b,new_avoid = match n with | Name id when List.exists (is_free_in id) args -> @@ -473,136 +563,169 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = | _ -> n,b,avoid in build_entry_lc + env funnames avoid (mkRLetIn(new_n,t,mkRApp(new_b,args))) | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> - let f_res = build_entry_lc funnames args_res.to_avoid f in + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) + let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" + | RDynamic _ ->error "Not handled RDynamic" | RCast(_,b,_,_) -> - build_entry_lc funnames avoid (mkRApp(b,args)) + (* for an applied cast we just trash the cast part + and restart the work. + + WARNING: We need to restart since [b] itself should be an application term + *) + build_entry_lc env funnames avoid (mkRApp(b,args)) | RRec _ -> error "Not handled RRec" | RProd _ -> error "Cannot apply a type" - end + end (* end of the application treatement *) + | RLambda(_,n,t,b) -> - let b_res = build_entry_lc funnames avoid b in - let t_res = build_entry_lc funnames avoid t in + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in let new_n = match n with | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in + let new_env = raw_push_named (new_n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res | RProd(_,n,t,b) -> - let b_res = build_entry_lc funnames avoid b in - let t_res = build_entry_lc funnames avoid t in + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in + let new_env = raw_push_named (n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res - | RLetIn(_,n,t,b) -> - let b_res = build_entry_lc funnames avoid b in - let t_res = build_entry_lc funnames avoid t in - combine_results (combine_letin n) t_res b_res + | RLetIn(_,n,v,b) -> + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) + let v_res = build_entry_lc env funnames avoid v in + let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_type = Typing.type_of env Evd.empty v_as_constr in + let new_env = + match n with + Anonymous -> env + | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_letin n) v_res b_res | RCases(_,_,el,brl) -> + (* we create the discrimination function + and treat the case itself + *) let make_discr = make_discr_match brl in - build_entry_lc_from_case funnames make_discr el brl avoid + build_entry_lc_from_case env funnames make_discr el brl avoid | RIf(_,b,(na,e_option),lhs,rhs) -> - begin - match b with - | RCast(_,b,_,t) -> - let msg = "If construction must be used with cast" in - let case_pat = find_constructors_of_raw_type msg t [] in - assert (Array.length case_pat = 2); - let brl = - list_map_i - (fun i x -> (dummy_loc,[],[case_pat.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkRCases(None,[(b,(Anonymous,None))],brl) - in -(* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) - build_entry_lc funnames avoid match_expr - | _ -> - try - let ind = find_type_of 2 b in - let case_pat = build_constructors_of_type (str "") ind [] in - let brl = - list_map_i - (fun i x -> (dummy_loc,[],[case_pat.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkRCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) - build_entry_lc funnames avoid match_expr - with Invalid_argument s -> - let msg = "If construction must be used with cast : "^ s in - error msg - - end + let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ + Printer.pr_rawconstr b ++ str " in " ++ + Printer.pr_rawconstr rt ++ str ". try again with a cast") + in + let case_pats = build_constructors_of_type ind [] in + assert (Array.length case_pats = 2); + let brl = + list_map_i + (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) + 0 + [lhs;rhs] + in + let match_expr = + mkRCases(None,[(b,(Anonymous,None))],brl) + in + (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) + build_entry_lc env funnames avoid match_expr | RLetTuple(_,nal,_,b,e) -> - begin - let nal_as_rawconstr = - List.map - (function - Name id -> mkRVar id + begin + let nal_as_rawconstr = + List.map + (function + Name id -> mkRVar id | Anonymous -> mkRHole () ) - nal + nal in - match b with - | RCast(_,b,_,t) -> - let case_pat = - find_constructors_of_raw_type - "LetTuple construction must be used with cast" t nal_as_rawconstr in - assert (Array.length case_pat = 1); - let br = - (dummy_loc,[],[case_pat.(0)],e) - in - let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc funnames avoid match_expr - | _ -> - try - let ind = find_type_of 1 b in - let case_pat = - build_constructors_of_type - (str "LetTuple construction must be used with cast") ind nal_as_rawconstr in - let br = - (dummy_loc,[],[case_pat.(0)],e) - in - let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc funnames avoid match_expr - with Invalid_argument s -> - let msg = "LetTuple construction must be used with cast : "^ s in - error msg - + let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ + Printer.pr_rawconstr b ++ str " in " ++ + Printer.pr_rawconstr rt ++ str ". try again with a cast") + in + let case_pats = build_constructors_of_type ind nal_as_rawconstr in + assert (Array.length case_pats = 1); + let br = + (dummy_loc,[],[case_pats.(0)],e) + in + let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in + build_entry_lc env funnames avoid match_expr + end | RRec _ -> error "Not handled RRec" | RCast(_,b,_,_) -> - build_entry_lc funnames avoid b + build_entry_lc env funnames avoid b | RDynamic _ -> error "Not handled RDynamic" -and build_entry_lc_from_case funname make_discr +and build_entry_lc_from_case env funname make_discr (el:tomatch_tuple) (brl:Rawterm.cases_clauses) avoid : rawconstr build_entry_return = match el with - | [] -> assert false (* matched on Nothing !*) + | [] -> assert false (* this case correspond to match <nothing> with .... !*) | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each elemeent of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc funname avoid case_arg in + let arg_res = build_entry_lc env funname avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el (mk_result [] [] avoid) in + (****** The next works only if the match is not dependent ****) + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + Typing.type_of env Evd.empty case_arg_as_constr + ) el + in let results = List.map - (build_entry_lc_from_case_term funname (make_discr (List.map fst el)) [] brl case_resl.to_avoid) + (build_entry_lc_from_case_term + env types + funname (make_discr (* (List.map fst el) *)) + [] brl + case_resl.to_avoid) case_resl.result in { @@ -611,36 +734,54 @@ and build_entry_lc_from_case funname make_discr List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results } -and build_entry_lc_from_case_term funname make_discr patterns_to_prevent brl avoid +and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> + (* alpha convertion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in - let new_avoid = idl@avoid in -(* let e_ctxt,el = (matched_expr.context,matched_expr.value) in *) -(* if (List.length patl) <> (List.length el) *) -(* then error ("Pattern matching on product: not yet implemented"); *) + let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 add_pat_variables patl types env in let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = - List.map - (fun pat -> + List.map2 + (fun pat typ -> fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in let pat_ids = get_pattern_id renamed_pat in - List.fold_right - (fun id acc -> mkRProd (Name id,mkRHole (),acc)) + let env_with_pat_ids = add_pat_variables pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id + in + mkRProd (Name id,raw_typ_of_id,acc)) pat_ids (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) ) patl + types in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) let unify_with_those_patterns : (cases_pattern -> bool*bool) list = List.map (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') patl in + (* + we first compute the other branch result (in ordrer to keep the order of the matching + as much as possible) + *) let brl'_res = build_entry_lc_from_case_term + env + types funname make_discr ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) @@ -648,48 +789,63 @@ and build_entry_lc_from_case_term funname make_discr patterns_to_prevent brl avo avoid matched_expr in + (* We know create the precondition of this branch i.e. + + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) let those_pattern_preconds = -( List.flatten + (List.flatten ( - List.map2 - (fun pat e -> + list_map3 + (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in + let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Idset.mem id this_pat_ids - then (Prod (Name id),mkRHole ())::acc + then (Prod (Name id), + let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id + in + raw_typ_of_id + )::acc else acc ) idl - [(Prod Anonymous,raw_make_eq pat_as_term e)] + [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)] ) patl matched_expr.value + types + ) ) -) @ - (if List.exists (function (unifl,neql) -> - let (unif,eqs) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - [(Prod Anonymous,make_discr i )] - else - [] - ) + (if List.exists (function (unifl,_) -> + let (unif,_) = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in + [(Prod Anonymous,make_discr pats_as_constr i )] + else + [] + ) in - let return_res = build_entry_lc funname new_avoid return in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env funname new_avoid return in + (* and combine it with the preconds computed for this branch *) let this_branch_res = List.map (fun res -> - { context = - matched_expr.context@ -(* ids@ *) - those_pattern_preconds@res.context ; + { context = matched_expr.context@those_pattern_preconds@res.context ; value = res.value} ) return_res.result @@ -702,7 +858,9 @@ let is_res id = String.sub (string_of_id id) 0 3 = "res" with Invalid_argument _ -> false -(* rebuild the raw constructors expression. +(* + The second phase which reconstruct the real type of the constructor. + rebuild the raw constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons nb_args relname args crossed_types depth rt = @@ -722,6 +880,10 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = args new_crossed_types (depth + 1) b in + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) + let new_t = mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) in mkRProd(n,new_t,new_b), @@ -730,7 +892,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = assert false end | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref + when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous -> let is_in_b = is_free_in id b in let _keep_eq = @@ -748,9 +910,11 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = (depth + 1) subst_b in mkRProd(n,t,new_b),id_to_exclude -(* if keep_eq then *) -(* mkRProd(n,t,new_b),id_to_exclude *) -(* else new_b, Idset.add id id_to_exclude *) + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkRProd(n,t,new_b),id_to_exclude + else new_b, Idset.add id id_to_exclude + *) | _ -> let new_b,id_to_exclude = rebuild_cons @@ -766,18 +930,8 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = end | RLambda(_,n,t,b) -> begin -(* let not_free_in_t id = not (is_free_in id t) in *) -(* let new_crossed_types = t :: crossed_types in *) -(* let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types b in *) -(* match n with *) -(* | Name id when Idset.mem id id_to_exclude -> *) -(* new_b, *) -(* Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) -(* RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude *) let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in -(* let new_b,id_to_exclude = rebuild_cons relname (args new_crossed_types b in *) match n with | Name id -> let new_b,id_to_exclude = @@ -838,15 +992,24 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt = | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty +(* debuging wrapper *) let rebuild_cons nb_args relname args crossed_types rt = - observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ - str "nb_args := " ++ str (string_of_int nb_args)); +(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) +(* str "nb_args := " ++ str (string_of_int nb_args)); *) let res = rebuild_cons nb_args relname args crossed_types 0 rt in - observe (str " leads to "++ pr_rawconstr (fst res)); +(* observe (str " leads to "++ pr_rawconstr (fst res)); *) res + +(* naive implementation of parameter detection. + + A parameter is an argument which is only preceded by parameters and whose + calls are all syntaxically equal. + + TODO: Find a valid way to deal with implicit arguments here! +*) let rec compute_cst_params relnames params = function | RRef _ | RVar _ | REvar _ | RPatVar _ -> params | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> @@ -900,13 +1063,6 @@ let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) in List.rev !l -(* (Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,Anonymous)],returned_types.(i)], - Topconstr.CSort(dummy_loc, RProp Null ) - ) - ) -*) let rec rebuild_return_type rt = match rt with | Topconstr.CProdN(loc,n,t') -> @@ -915,36 +1071,58 @@ let rec rebuild_return_type rt = Topconstr.CArrow(loc,t,rebuild_return_type t') | Topconstr.CLetIn(loc,na,t,t') -> Topconstr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc, RProp Null)) + | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) -let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) returned_types (rtl:rawconstr list) = +let build_inductive + parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) + returned_types + (rtl:rawconstr list) = let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in + (* alpha_renaming of the body to prevent variable capture during manipulation *) let rtl_alpha = List.map (function rt -> (alpha_rt [] rt) ) rtl in let rta = Array.of_list rtl_alpha in + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in - let resa = Array.map (build_entry_lc funnames_as_set []) rta in + (* Construction of the pseudo constructors *) + let env = + Array.fold_right + (fun id env -> + Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env + ) + funnames + (Global.env ()) + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + (* and of the real constructors*) let constr i res = List.map (function result (* (args',concl') *) -> let rt = compose_raw_context result.context result.value in let nb_args = List.length funsargs.(i) in -(* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *) +(* let old_implicit_args = Impargs.is_implicit_args () *) +(* and old_strict_implicit_args = Impargs.is_strict_implicit_args () *) +(* and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in *) +(* let old_rawprint = !Options.raw_print in *) +(* Options.raw_print := true; *) +(* Impargs.make_implicit_args false; *) +(* Impargs.make_strict_implicit_args false; *) +(* Impargs.make_contextual_implicit_args false; *) +(* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *) +(* Impargs.make_implicit_args old_implicit_args; *) +(* Impargs.make_strict_implicit_args old_strict_implicit_args; *) +(* Impargs.make_contextual_implicit_args old_contextual_implicit_args; *) +(* Options.raw_print := old_rawprint; *) fst ( rebuild_cons nb_args relnames.(i) -(* (List.map *) -(* (function *) -(* (Anonymous,_,_) -> mkRVar(fresh_id res.to_avoid "x__") *) -(* | Name id, _,_ -> mkRVar id *) -(* ) *) -(* funsargs.(i) *) -(* ) *) [] [] rt @@ -952,15 +1130,21 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo ) res.result in - let next_constructor_id = ref (-1) in + (* adding names to constructors *) + let next_constructor_id = ref (-1) in let mk_constructor_id i = incr next_constructor_id; + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in let rel_constructors i rt : (identifier*rawconstr) list = + next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in let rel_constructors = Array.mapi rel_constructors resa in + (* Computing the set of parameters if asked *) let rels_params = if parametrize then @@ -968,12 +1152,12 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo else [] in let nrel_params = List.length rels_params in - let rel_constructors = + let rel_constructors = (* Taking into account the parameters in constructors *) Array.map (List.map (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) rel_constructors in - let rel_arity i funargs = + let rel_arity i funargs = (* Reduilding arities (with parameters) *) let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = (snd (list_chop nrel_params funargs)) in @@ -992,13 +1176,11 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo ) rel_first_args (rebuild_return_type returned_types.(i)) -(* (Topconstr.CProdN *) -(* (dummy_loc, *) -(* [[(dummy_loc,Anonymous)],returned_types.(i)], *) -(* Topconstr.CSort(dummy_loc, RProp Null ) *) -(* ) *) -(* ) *) in + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values + *) let rel_arities = Array.mapi rel_arity funsargs in let old_rawprint = !Options.raw_print in Options.raw_print := true; @@ -1017,9 +1199,9 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo let ext_rels_constructors = Array.map (List.map (fun (id,t) -> - false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty t) + false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty ((* zeta_normalize *) t)) )) - rel_constructors + (rel_constructors) in let rel_ind i ext_rel_constructors = (dummy_loc,relnames.(i)), @@ -1030,26 +1212,26 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in let rel_inds = Array.to_list ext_rel_constructors in - let _ = - observe ( - str "Inductive" ++ spc () ++ - prlist_with_sep - (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) - (function ((_,id),_,params,ar,constr) -> - Ppconstr.pr_id id ++ spc () ++ - Ppconstr.pr_binders params ++ spc () ++ - str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr ar ++ spc () ++ - prlist_with_sep - (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) - (function (_,((_,id),t)) -> - Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr t) - constr - ) - rel_inds - ) - in +(* let _ = *) +(* Pp.msgnl (\* observe *\) ( *) +(* str "Inductive" ++ spc () ++ *) +(* prlist_with_sep *) +(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) +(* (function ((_,id),_,params,ar,constr) -> *) +(* Ppconstr.pr_id id ++ spc () ++ *) +(* Ppconstr.pr_binders params ++ spc () ++ *) +(* str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) +(* prlist_with_sep *) +(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) +(* (function (_,((_,id),t)) -> *) +(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr t) *) +(* constr *) +(* ) *) +(* rel_inds *) +(* ) *) +(* in *) let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli index 0cda56df..9cd04123 100644 --- a/contrib/funind/rawterm_to_relation.mli +++ b/contrib/funind/rawterm_to_relation.mli @@ -1,16 +1,16 @@ -(* val new_build_entry_lc : *) -(* Names.identifier list -> *) -(* (Names.name*Rawterm.rawconstr) list list -> *) -(* Topconstr.constr_expr list -> *) -(* Rawterm.rawconstr list -> *) -(* unit *) + +(* + [build_inductive parametrize funnames funargs returned_types bodies] + constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments + and returning [returned_types] using bodies [bodies] +*) val build_inductive : - bool -> - Names.identifier list -> - (Names.name*Rawterm.rawconstr*bool) list list -> - Topconstr.constr_expr list -> - Rawterm.rawconstr list -> + bool -> (* if true try to detect parameter. Always use it as true except for debug *) + Names.identifier list -> (* The list of function name *) + (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) + Topconstr.constr_expr list -> (* The list of function returned type *) + Rawterm.rawconstr list -> (* the list of body *) unit diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index c6406468..14805cf4 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -18,7 +18,7 @@ let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl) let mkRSort s = RSort(dummy_loc,s) let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) - +let mkRCast(b,t) = RCast(dummy_loc,b,CastCoerce,t) (* Some basic functions to decompose rawconstrs @@ -49,8 +49,8 @@ let raw_decompose_app = (* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[mkRHole ();t2;t1]) +let raw_make_eq ?(typ= mkRHole ()) t1 t2 = + mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) (* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) let raw_make_neq t1 t2 = @@ -321,7 +321,7 @@ let rec alpha_rt excluded rt = List.map (alpha_rt excluded) args ) in - if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false + if Indfun_common.do_observe () && false then Pp.msgnl (str "debug: alpha_rt(" ++ str "[" ++ prlist_with_sep (fun _ -> str";") Ppconstr.pr_id excluded ++ @@ -386,30 +386,32 @@ let is_free_in id = -let rec pattern_to_term = function +let rec pattern_to_term = function | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> + | PatVar(loc,Name id) -> mkRVar id - | PatCstr(loc,constr,patternl,_) -> - let cst_narg = + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) constr in - let implicit_args = - Array.to_list - (Array.init + let implicit_args = + Array.to_list + (Array.init (cst_narg - List.length patternl) (fun _ -> mkRHole ()) ) in - let patl_as_term = + let patl_as_term = List.map pattern_to_term patternl in mkRApp(mkRRef(Libnames.ConstructRef constr), implicit_args@patl_as_term ) + + let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with @@ -539,3 +541,63 @@ let ids_of_pat = in ids_of_pat Idset.empty + + + + +let zeta_normalize = + let rec zeta_normalize_term rt = + match rt with + | RRef _ -> rt + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> + RApp(loc, + zeta_normalize_term rt', + List.map zeta_normalize_term rtl + ) + | RLambda(loc,name,t,b) -> + RLambda(loc, + name, + zeta_normalize_term t, + zeta_normalize_term b + ) + | RProd(loc,name,t,b) -> + RProd(loc, + name, + zeta_normalize_term t, + zeta_normalize_term b + ) + | RLetIn(_,Name id,def,b) -> + zeta_normalize_term (replace_var_by_term id def b) + | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b + | RLetTuple(loc,nal,(na,rto),def,b) -> + RLetTuple(loc, + nal, + (na,option_map zeta_normalize_term rto), + zeta_normalize_term def, + zeta_normalize_term b + ) + | RCases(loc,infos,el,brl) -> + RCases(loc, + infos, + List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, + List.map zeta_normalize_br brl + ) + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, zeta_normalize_term b, + (na,option_map zeta_normalize_term e_option), + zeta_normalize_term lhs, + zeta_normalize_term rhs + ) + | RRec _ -> raise (UserError("",str "Not handled RRec")) + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,k,t) -> + RCast(loc,zeta_normalize_term b,k,zeta_normalize_term t) + | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + and zeta_normalize_br (loc,idl,patl,res) = + (loc,idl,patl,zeta_normalize_term res) + in + zeta_normalize_term diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli index 5dcdb15c..aa355485 100644 --- a/contrib/funind/rawtermops.mli +++ b/contrib/funind/rawtermops.mli @@ -25,7 +25,7 @@ val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr val mkRSort : rawsort -> rawconstr val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) - +val mkRCast : rawconstr* rawconstr -> rawconstr (* Some basic functions to decompose rawconstrs These are analogous to the ones constrs @@ -36,7 +36,7 @@ val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) (* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -val raw_make_eq : rawconstr -> rawconstr -> rawconstr +val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr (* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) val raw_make_neq : rawconstr -> rawconstr -> rawconstr (* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) @@ -106,3 +106,9 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool returns the set of variables appearing in a pattern *) val ids_of_pat : cases_pattern -> Names.Idset.t + + +(* + removing let_in construction in a rawterm +*) +val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 index 2c7e4d33..5d19079b 100644 --- a/contrib/funind/tacinv.ml4 +++ b/contrib/funind/tacinv.ml4 @@ -1,16 +1,10 @@ (*i camlp4deps: "parsing/grammar.cma" i*) (*s FunInv Tactic: inversion following the shape of a function. *) -(* Use: - \begin{itemize} - \item The Tacinv directory must be in the path (-I <path> option) - \item use the bytecode version of coqtop or coqc (-byte option), or make a - coqtop - \item Do [Require Tacinv] to be able to use it. - \item For syntax see Tacinv.v - \end{itemize} -*) +(* Deprecated: see indfun_main.ml4 instead *) + +(* Don't delete this file yet, it may be used for other purposes *) (*i*) open Termops @@ -862,7 +856,6 @@ END (* *** Local Variables: *** *** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" *** -*** tab-width: 1 *** *** tuareg-default-indent:1 *** *** tuareg-begin-indent:1 *** *** tuareg-let-indent:1 *** diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index ecb04e07..024cb599 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -336,8 +336,8 @@ and | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, List.map xlate_match_pattern l) and translate_one_equation = function - (_,lp, a) -> CT_eqn ( xlate_match_pattern_ne_list lp, - xlate_formula a) + (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) + | _ -> xlate_error "TODO: disjunctive multiple patterns" and xlate_binder_ne_list = function [] -> assert false @@ -978,7 +978,7 @@ and xlate_tac = let id_opt = match out_gen Extratactics.rawwit_in_arg_hyp id_opt with | None -> ctv_ID_OPT_NONE - | Some id -> ctf_ID_OPT_SOME (xlate_ident id) + | Some (_,id) -> ctf_ID_OPT_SOME (xlate_ident id) in let tac_opt = match out_gen (Extratactics.rawwit_by_arg_tac) tac_opt with @@ -2035,7 +2035,6 @@ let rec xlate_vernac = | VernacExtend (s, l) -> CT_user_vernac (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacDebug b -> xlate_error "Debug On/Off not supported" | VernacList((_, a)::l) -> CT_coerce_COMMAND_LIST_to_COMMAND (CT_command_list(xlate_vernac a, diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v index 2aa3516f..83ea5b63 100644 --- a/contrib/romega/ReflOmegaCore.v +++ b/contrib/romega/ReflOmegaCore.v @@ -49,6 +49,11 @@ Inductive term : Set := | Tvar : nat -> term. Delimit Scope romega_scope with term. +Arguments Scope Tplus [romega_scope romega_scope]. +Arguments Scope Tmult [romega_scope romega_scope]. +Arguments Scope Tminus [romega_scope romega_scope]. +Arguments Scope Topp [romega_scope romega_scope]. + Infix "+" := Tplus : romega_scope. Infix "*" := Tmult : romega_scope. Infix "-" := Tminus : romega_scope. diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v index bbf722db..ded069bf 100644 --- a/contrib/subtac/FixSub.v +++ b/contrib/subtac/FixSub.v @@ -20,3 +20,27 @@ Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). End FixPoint. End Well_founded. + +Require Import Wf_nat. +Require Import Lt. + +Section Well_founded_measure. +Variable A : Set. +Variable f : A -> nat. +Definition R := fun x y => f x < f y. + +Section FixPoint. + +Variable P : A -> Set. + +Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x. + +Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (f x)) {struct r} : P x := + F_sub x (fun y: { y : A | f y < f x} => Fix_measure_F_sub (proj1_sig y) + (Acc_inv r (f (proj1_sig y)) (proj2_sig y))). + +Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)). + +End FixPoint. + +End Well_founded_measure. diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v index db10cb2a..b1694d7c 100644 --- a/contrib/subtac/Utils.v +++ b/contrib/subtac/Utils.v @@ -34,3 +34,13 @@ induction t. simpl ; auto. Qed. +Ltac destruct_one_pair := + match goal with + | [H : (ex _) |- _] => destruct H + | [H : (ex2 _) |- _] => destruct H + | [H : (sig _) |- _] => destruct H + | [H : (_ /\ _) |- _] => destruct H +end. + +Ltac destruct_exists := repeat (destruct_one_pair) . + diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 382ae2d5..859f9013 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -16,7 +16,7 @@ let reverse_array arr = Array.of_list (List.rev (Array.to_list arr)) let trace s = - if !Options.debug then msgnl s + if !Options.debug then (msgnl s; msgerr s) else () (** Utilities to find indices in lists *) @@ -37,7 +37,9 @@ let list_assoc_index x l = let subst_evars evs n t = let evar_info id = let rec aux i = function - (k, h, v) :: tl -> if k = id then (i, h, v) else aux (succ i) tl + (k, h, v) :: tl -> + trace (str "Searching for " ++ int id ++ str " found: " ++ int k); + if k = id then (i, h, v) else aux (succ i) tl | [] -> raise Not_found in let (idx, hyps, v) = aux 0 evs in @@ -45,29 +47,29 @@ let subst_evars evs n t = in let rec substrec depth c = match kind_of_term c with | Evar (k, args) -> - (try - let index, hyps = evar_info k in - (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses"); with _ -> () ); - - let ex = mkRel (index + depth) in - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let rec aux hyps args acc = - match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> - aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc) - | ((_, Some _, _) :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> failwith "subst_evars: invalid argument" - in aux hyps (Array.to_list args) [] - in - mkApp (ex, Array.of_list args) - with Not_found -> - anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")) + (let index, hyps = + try evar_info k + with Not_found -> + anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") + in + (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ + int (List.length hyps) ++ str " hypotheses"); with _ -> () ); + let ex = mkRel (index + depth) in + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let rec aux hyps args acc = + match hyps, args with + ((_, None, _) :: tlh), (c :: tla) -> + aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc) + | ((_, Some _, _) :: tlh), (_ :: tla) -> + aux tlh tla acc + | [], [] -> acc + | _, _ -> failwith "subst_evars: invalid argument" + in aux hyps (Array.to_list args) [] + in + mkApp (ex, Array.of_list args)) | _ -> map_constr_with_binders succ substrec depth c in substrec 0 t @@ -106,11 +108,13 @@ open Tacticals let eterm_term evm t tycon = (* 'Serialize' the evars, we assume that the types of the existentials refer to previous existentials in the list only *) - let evl = to_list evm in + let evl = List.rev (to_list evm) in + trace (str "Eterm, transformed to list"); let evts = (* Remove existential variables in types and build the corresponding products *) fold_right (fun (id, ev) l -> + trace (str "Eterm: " ++ str "treating evar: " ++ int id); let hyps = Environ.named_context_of_val ev.evar_hyps in let y' = (id, hyps, etype_of_evar l ev hyps) in y' :: l) diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index cd2e7c43..ffb16a19 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 8889 2006-06-01 20:23:56Z msozeau $ *) +(* $Id: subtac.ml 8964 2006-06-20 13:52:21Z msozeau $ *) open Global open Pp @@ -43,7 +43,7 @@ open Eterm let require_library dirpath = let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in Library.require_library [qualid] None - +(* let subtac_one_fixpoint env isevars (f, decl) = let ((id, n, bl, typ, body), decl) = Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl) @@ -53,7 +53,7 @@ let subtac_one_fixpoint env isevars (f, decl) = Ppconstr.pr_constr_expr body) with _ -> () in ((id, n, bl, typ, body), decl) - +*) let subtac_fixpoint isevars l = (* TODO: Copy command.build_recursive *) diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli index a0d2fb2b..25922782 100644 --- a/contrib/subtac/subtac.mli +++ b/contrib/subtac/subtac.mli @@ -1,14 +1,3 @@ val require_library : string -> unit -val subtac_one_fixpoint : - 'a -> - 'b -> - (Names.identifier * (int * Topconstr.recursion_order_expr) * - Topconstr.local_binder list * Topconstr.constr_expr * - Topconstr.constr_expr) * - 'c -> - (Names.identifier * (int * Topconstr.recursion_order_expr) * - Topconstr.local_binder list * Topconstr.constr_expr * - Topconstr.constr_expr) * - 'c val subtac_fixpoint : 'a -> 'b -> unit val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 7428e1ed..78c3c70b 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 8889 2006-06-01 20:23:56Z msozeau $ *) +(* $Id: subtac_coercion.ml 8964 2006-06-20 13:52:21Z msozeau $ *) open Util open Names @@ -106,25 +106,25 @@ module Coercion = struct : (Term.constr -> Term.constr) option = let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in - (try trace (str "Coerce called for " ++ (my_print_constr env x) ++ + (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++ str " and "++ my_print_constr env y ++ str " with evars: " ++ spc () ++ my_print_evardefs !isevars); with _ -> ()); let rec coerce_unify env x y = - (try trace (str "coerce_unify from " ++ (my_print_constr env x) ++ + (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ str " to "++ my_print_constr env y) with _ -> ()); try isevars := the_conv_x_leq env x y !isevars; - (try (trace (str "Unified " ++ (my_print_constr env x) ++ - str " and "++ my_print_constr env y)); + (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ + str " and "++ my_print_constr env y); with _ -> ()); None with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in - (try trace (str "coerce' from " ++ (my_print_constr env x) ++ + (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ str " to "++ my_print_constr env y); with _ -> ()); match (kind_of_term x, kind_of_term y) with @@ -370,7 +370,7 @@ module Coercion = struct let rec inh_conv_coerce_to_fail loc env isevars v t c1 = (try - trace (str "inh_conv_coerce_to_fail called for " ++ + debug 1 (str "inh_conv_coerce_to_fail called for " ++ Termops.print_constr_env env t ++ str " and "++ spc () ++ Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ @@ -436,7 +436,7 @@ module Coercion = struct (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to loc env isevars cj ((n, t) as tycon) = (try - trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ + debug 1 (str "Subtac_coercion.inh_conv_coerce_to called for " ++ Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ @@ -461,7 +461,7 @@ module Coercion = struct let inh_conv_coerces_to loc env isevars t ((abs, t') as tycon) = (try - trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ + debug 1 (str "Subtac_coercion.inh_conv_coerces_to called for " ++ Termops.print_constr_env env t ++ str " and "++ spc () ++ Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index b09228c0..c738d7a6 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -117,7 +117,8 @@ let interp_context sigma env params = let list_chop_hd i l = match list_chop i l with | (l1,x::l2) -> (l1,x,l2) - | _ -> assert false + | (x :: [], l2) -> ([], x, []) + | _ -> assert(false) let collect_non_rec env = let rec searchrec lnonrec lnamerec ldefrec larrec nrec = @@ -173,82 +174,189 @@ let list_of_local_binders l = | [] -> List.rev acc in aux [] l -let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed = +let lift_binders k n l = + let rec aux n = function + | (id, t, c) :: tl -> (id, option_map (liftn k n) t, liftn k n c) :: aux (pred n) tl + | [] -> [] + in aux n l + +let rec gen_rels = function + 0 -> [] + | n -> mkRel n :: gen_rels (pred n) + +let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = + let sigma = Evd.empty in + let isevars = ref (Evd.create_evar_defs sigma) in + let env = Global.env() in + let pr c = my_print_constr env c in + let prr = Printer.pr_rel_context env in + let pr_rel env = Printer.pr_rel_context env in + let _ = + try debug 2 (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ + Ppconstr.pr_binders bl ++ str " : " ++ + Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ + Ppconstr.pr_constr_expr body) + with _ -> () + in + let env', binders_rel = interp_context isevars env bl in + let after, ((argname, _, argtyp) as arg), before = list_chop_hd (succ n) binders_rel in + let before_length, after_length = List.length before, List.length after in + let argid = match argname with Name n -> n | _ -> assert(false) in + let _liftafter = lift_binders 1 after_length after in + let envwf = push_rel_context before env in + let wf_rel, measure_fn = + let rconstr = interp_constr isevars envwf r in + if measure then + let lt_rel = constr_of_global (Lazy.force lt_ref) in + let name s = Name (id_of_string s) in + mkLambda (name "x", argtyp, + mkLambda (name "y", argtyp, + mkApp (lt_rel, + [| mkApp (rconstr, [| mkRel 2 |]) ; + mkApp (rconstr, [| mkRel 1 |]) |]))), + Some rconstr + else rconstr, None + in + let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) + in + let argid' = id_of_string (string_of_id argid ^ "'") in + let wfarg len = (Name argid', None, + mkSubset (Name argid') argtyp + (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|]))) + in + let top_bl = after @ (arg :: before) in + let intern_bl = after @ (wfarg 1 :: arg :: before) in + let top_env = push_rel_context top_bl env in + let intern_env = push_rel_context intern_bl env in + let top_arity = interp_type isevars top_env arityc in + (try debug 2 (str "Intern bl: " ++ prr intern_bl) with _ -> ()); + let proj = (Lazy.force sig_).Coqlib.proj1 in + let projection = + mkApp (proj, [| argtyp ; + (mkLambda (Name argid', argtyp, + (mkApp (wf_rel, [|mkRel 1; mkRel 3|])))) ; + mkRel 1 + |]) + in + (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); + let intern_arity = substnl [projection] after_length top_arity in + (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); + let intern_before_env = push_rel_context before env in + let intern_fun_bl = after @ [wfarg 1] in + (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); + let intern_fun_arity = intern_arity in + (try debug 2 (str "Intern fun arity: " ++ + my_print_constr intern_env intern_fun_arity) with _ -> ()); + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in + let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in + let fun_bl = after @ (intern_fun_binder :: [arg]) in + (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); + let fun_env = push_rel_context fun_bl intern_before_env in + let fun_arity = interp_type isevars fun_env arityc in + let intern_body = interp_casted_constr isevars fun_env body fun_arity in + let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in + let _ = + try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ + str "Intern bl" ++ prr intern_bl ++ spc () ++ + str "Top bl" ++ prr top_bl ++ spc () ++ + str "Intern arity: " ++ pr intern_arity ++ + str "Top arity: " ++ pr top_arity ++ spc () ++ + str "Intern body " ++ pr intern_body_lam) + with _ -> () + in + let _impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits top_env top_arity + else [] + in + let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in + let fix_def = + match measure_fn with + None -> + mkApp (constr_of_reference (Lazy.force fix_sub_ref), + [| argtyp ; + wf_rel ; + make_existential dummy_loc intern_before_env isevars wf_proof ; + prop ; + intern_body_lam |]) + | Some f -> + mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), + [| argtyp ; f ; prop ; + intern_body_lam |]) + in + let def_appl = applist (fix_def, gen_rels (after_length + 1)) in + let def = it_mkLambda_or_LetIn def_appl binders_rel in + let typ = it_mkProd_or_LetIn top_arity binders_rel in + debug 2 (str "Constructed def"); + debug 2 (my_print_constr intern_before_env def); + debug 2 (str "Type: " ++ my_print_constr env typ); + let fullcoqc = Evarutil.nf_isevar !isevars def in + let fullctyp = Evarutil.nf_isevar !isevars typ in + let _ = try trace (str "After evar normalization: " ++ spc () ++ + str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () + ++ str "Coq type: " ++ my_print_constr env fullctyp) + with _ -> () + in + let evm = non_instanciated_map env isevars in + let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in + let evars_def, evars_typ, evars = Eterm.eterm_term evm fullcoqc (Some fullctyp) in + let evars_typ = out_some evars_typ in + (try trace (str "Building evars sum for : "); + List.iter + (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) + evars; + with _ -> ()); + let (sum_tac, sumg) = Subtac_utils.build_dependent_sum evars in + (try trace (str "Evars sum: " ++ my_print_constr env sumg); + trace (str "Evars type: " ++ my_print_constr env evars_typ); + with _ -> ()); + let proofid = id_of_string (string_of_id recname ^ "_evars_proof") in + Command.start_proof proofid goal_proof_kind sumg + (fun strength gr -> + debug 2 (str "Proof finished"); + let def = constr_of_global gr in + let args = Subtac_utils.destruct_ex def sumg in + let _, newdef = decompose_lam_n (List.length args) evars_def in + let constr = Term.substl (List.rev args) newdef in + debug 2 (str "Applied existentials : " ++ my_print_constr env constr); + let ce = + { const_entry_body = constr; + const_entry_type = Some fullctyp; + const_entry_opaque = false; + const_entry_boxed = boxed} + in + let _constant = Declare.declare_constant + recname (DefinitionEntry ce,IsDefinition Definition) + in + definition_message recname); + trace (str "Started existentials proof"); + Pfedit.by sum_tac; + trace (str "Applied sum tac") + +let build_mutrec l boxed = let sigma = Evd.empty and env0 = Global.env() in let lnameargsardef = (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env0 protos (f, d))*) - lnameargsardef + l in let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef in - (* Build the recursive context and notations for the recursive types *) + (* Build the recursive context and notations for the recursive types *) let (rec_sign,rec_impls,arityl) = List.fold_left - (fun (env,impls,arl) ((recname,(n, ro),bl,arityc,body),_) -> - let isevars = ref (Evd.create_evar_defs sigma) in - match ro with - CStructRec -> - let arityc = Command.generalize_constr_expr arityc bl in - let arity = interp_type isevars env0 arityc in - let impl = - if Impargs.is_implicit_args() - then Impargs.compute_implicits env0 arity - else [] in - let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in - (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl) - | CWfRec r -> - let n = out_some n in - let _ = - try trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ - Ppconstr.pr_binders bl ++ str " : " ++ - Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ - Ppconstr.pr_constr_expr body) - with _ -> () - in - let env', binders_rel = interp_context isevars env0 bl in - let after, ((argname, _, argtyp) as arg), before = list_chop_hd n binders_rel in - let argid = match argname with Name n -> n | _ -> assert(false) in - let after' = List.map (fun (n, c, t) -> (n, option_map (lift 1) c, lift 1 t)) after in - let envwf = push_rel_context before env0 in - let wf_rel = interp_constr isevars envwf r in - let accarg_id = id_of_string ("Acc_" ^ string_of_id argid) in - let accarg = (Name accarg_id, None, mkApp (Lazy.force acc_inv, [| argtyp; wf_rel; mkRel 1 |])) in - let argid' = id_of_string (string_of_id argid ^ "'") in - let before_length, after_length = List.length before, List.length after in - let full_length = before_length + 1 + after_length in - let wfarg len = (Name argid, None, - mkSubset (Name argid') argtyp - (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|]))) - in - let new_bl = after' @ (accarg :: arg :: before) - and intern_bl = after @ (wfarg (before_length + 1) :: before) - in - let intern_env = push_rel_context intern_bl env0 in - let env' = push_rel_context new_bl env0 in - let arity = interp_type isevars intern_env arityc in - let intern_arity = it_mkProd_or_LetIn arity intern_bl in - let arity' = interp_type isevars env' arityc in - let arity' = it_mkProd_or_LetIn arity' new_bl in - let fun_bl = after @ ((Name recname, None, intern_arity) :: arg :: before) in - let _ = - let pr c = my_print_constr env c in - let prr = Printer.pr_rel_context env in - try trace (str "Fun bl: " ++ prr fun_bl ++ spc () ++ - str "Intern bl" ++ prr intern_bl ++ spc () ++ - str "Extern bl" ++ prr new_bl ++ spc () ++ - str "Intern arity: " ++ pr intern_arity) - with _ -> () - in - let impl = - if Impargs.is_implicit_args() - then Impargs.compute_implicits intern_env arity' - else [] in - let impls' = (recname,([],impl,compute_arguments_scope arity'))::impls in - (Environ.push_named (recname,None,arity') env, impls', - (isevars, Some (full_length - n, argtyp, wf_rel, fun_bl, intern_bl, intern_arity), arity')::arl)) + (fun (env,impls,arl) ((recname, n, bl,arityc,body),_) -> + let isevars = ref (Evd.create_evar_defs sigma) in + let arityc = Command.generalize_constr_expr arityc bl in + let arity = interp_type isevars env0 arityc in + let impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits env0 arity + else [] in + let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in + (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl)) (env0,[],[]) lnameargsardef in let arityl = List.rev arityl in let notations = @@ -283,7 +391,6 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed let (lnonrec,(namerec,defrec,arrec,nvrec)) = collect_non_rec env0 lrecnames recdef arityl nv in - let nvrec' = Array.map (function (Some n,_) -> n | _ -> 0) nvrec in(* ignore rec order *) let declare arrec defrec = let recvec = Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in @@ -293,7 +400,7 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed my_print_constr env0 (recvec.(i))); with _ -> ()); let ce = - { const_entry_body = mkFix ((nvrec',i),recdecls); + { const_entry_body = mkFix ((nvrec,i),recdecls); const_entry_type = Some arrec.(i); const_entry_opaque = false; const_entry_boxed = boxed} in @@ -384,6 +491,11 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed match sum with Some (sumtac, sumg) -> Some (id, kn, sumg, sumtac) | None -> None) defs in + match real_evars with + [] -> declare (List.rev_map (fun (id, c, _) -> + snd (decompose_lam_n recdefs c)) defs) + | l -> + Subtac_utils.and_tac real_evars (fun f _ gr -> let _ = trace (str "Got a proof of: " ++ pr_global gr ++ @@ -431,5 +543,28 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed Environ.NoBody -> trace (str "Constant has no body") | Environ.Opaque -> trace (str "Constant is opaque") ) + +let out_n = function + Some n -> n + | None -> 0 + +let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed = + match lnameargsardef with + | ((id, (n, CWfRec r), bl, typ, body), no) :: [] -> + build_wellfounded (id, out_n n, bl, typ, body) r false no boxed + | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] -> + build_wellfounded (id, out_n n, bl, typ, body) r true no boxed + | l -> + let lnameargsardef = + List.map (fun ((id, (n, ro), bl, typ, body), no) -> + match ro with + CStructRec -> (id, out_n n, bl, typ, body), no + | CWfRec _ | CMeasureRec _ -> + errorlabstrm "Subtac_command.build_recursive" + (str "Well-founded fixpoints not allowed in mutually recursive blocks")) + lnameargsardef + in + build_mutrec lnameargsardef boxed; + assert(false) diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli index e1bbbbb5..90ffb892 100644 --- a/contrib/subtac/subtac_command.mli +++ b/contrib/subtac/subtac_command.mli @@ -38,5 +38,6 @@ val interp_constr_judgment : constr_expr -> unsafe_judgment val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list val recursive_message : global_reference array -> std_ppcmds + val build_recursive : (fixpoint_expr * decl_notation) list -> bool -> unit diff --git a/contrib/subtac/subtac_interp_fixpoint.ml b/contrib/subtac/subtac_interp_fixpoint.ml index 858fad1a..bb35833f 100644 --- a/contrib/subtac/subtac_interp_fixpoint.ml +++ b/contrib/subtac/subtac_interp_fixpoint.ml @@ -60,7 +60,7 @@ let pr_binder_list b = let rec rewrite_rec_calls l c = c - +(* let rewrite_fixpoint env l (f, decl) = let (id, (n, ro), bl, typ, body) = f in let body = rewrite_rec_calls l body in @@ -151,3 +151,4 @@ let rewrite_fixpoint env l (f, decl) = Ppconstr.pr_constr_expr body') in (id, (succ n, ro), bl', typ, body'), decl +*) diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli index fafbb2da..149e7580 100644 --- a/contrib/subtac/subtac_interp_fixpoint.mli +++ b/contrib/subtac/subtac_interp_fixpoint.mli @@ -15,14 +15,3 @@ val list_of_local_binders : val pr_binder_list : (('a * Names.name) * Topconstr.constr_expr) list -> Pp.std_ppcmds val rewrite_rec_calls : 'a -> 'b -> 'b -val rewrite_fixpoint : - 'a -> - 'b -> - (Names.identifier * (int * Topconstr.recursion_order_expr) * - Topconstr.local_binder list * Topconstr.constr_expr * - Topconstr.constr_expr) * - 'c -> - (Names.identifier * (int * Topconstr.recursion_order_expr) * - Topconstr.local_binder list * Topconstr.constr_expr * - Topconstr.constr_expr) * - 'c diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index 59c858a6..d4db7c27 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -22,12 +22,16 @@ let fixsub = lazy (init_constant fixsub_module "Fix_sub") let ex_pi1 = lazy (init_constant utils_module "ex_pi1") let ex_pi2 = lazy (init_constant utils_module "ex_pi2") -let make_ref s = Qualid (dummy_loc, (qualid_of_string s)) -let well_founded_ref = make_ref "Init.Wf.Well_founded" -let acc_ref = make_ref "Init.Wf.Acc" -let acc_inv_ref = make_ref "Init.Wf.Acc_inv" -let fix_sub_ref = make_ref "Coq.subtac.FixSub.Fix_sub" -let lt_wf_ref = make_ref "Coq.Wf_nat.lt_wf" +let make_ref l s = lazy (init_reference l s) +let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" +let acc_ref = make_ref ["Init";"Wf"] "Acc" +let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" +let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub" +let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub" +let lt_ref = make_ref ["Init";"Peano"] "lt" +let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf" + +let make_ref s = Qualid (dummy_loc, qualid_of_string s) let sig_ref = make_ref "Init.Specif.sig" let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" @@ -82,18 +86,19 @@ let my_print_evardefs = Evd.pr_evar_defs let my_print_tycon_type = Evarutil.pr_tycon_type +let debug_level = 2 let debug n s = - if !Options.debug then + if !Options.debug && n >= debug_level then msgnl s else () let debug_msg n s = - if !Options.debug then s + if !Options.debug && n >= debug_level then s else mt () let trace s = - if !Options.debug then msgnl s + if !Options.debug && debug_level > 0 then msgnl s else () let wf_relations = Hashtbl.create 10 @@ -153,6 +158,9 @@ let non_instanciated_map env evd = let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition +let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma +let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma + let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint @@ -164,7 +172,7 @@ let build_dependent_sum l = (n, t) :: tl -> let t' = mkLambda (Name n, t, typ) in trace (spc () ++ str ("treating evar " ^ string_of_id n)); - (try trace (str " assert: " ++ my_print_constr (Global.env ()) t) + (try trace (str " assert: " ++ my_print_constr (Global.env ()) t) with _ -> ()); let tac' = tclTHENS (assert_tac true (Name n) t) @@ -183,6 +191,39 @@ let build_dependent_sum l = (_, hd) :: tl -> aux (intros, hd) tl | [] -> raise (Invalid_argument "build_dependent_sum") +let id x = x + +let build_dependent_sum l = + let rec aux names conttac conttype = function + (n, t) :: ((_ :: _) as tl) -> + let hyptype = substl names t in + trace (spc () ++ str ("treating evar " ^ string_of_id n)); + (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) + with _ -> ()); + let tac = assert_tac true (Name n) hyptype in + let conttac = + (fun cont -> + conttac + (tclTHENS tac + ([intros; + (tclTHENSEQ + [constructor_tac (Some 1) 1 + (Rawterm.ImplicitBindings [mkVar n]); + cont]); + ]))) + in + let conttype = + (fun typ -> + let tex = mkLambda (Name n, t, typ) in + conttype + (mkApp (Lazy.force ex_ind, [| t; tex |]))) + in + aux (mkVar n :: names) conttac conttype tl + | (n, t) :: [] -> + (conttac intros, conttype t) + | [] -> raise (Invalid_argument "build_dependent_sum") + in aux [] id id (List.rev l) + open Proof_type open Tacexpr @@ -251,6 +292,75 @@ let destruct_ex ext ex = | _ -> [acc] in aux ex ext +open Rawterm + + +let list_mapi f = + let rec aux i = function + hd :: tl -> f i hd :: aux (succ i) tl + | [] -> [] + in aux 0 + +let rewrite_cases_aux (loc, po, tml, eqns) = + let tml = list_mapi (fun i (c, (n, opt)) -> c, + ((match n with + Name id -> (match c with + | RVar (_, id') when id = id' -> + Name (id_of_string (string_of_id id ^ "'")) + | _ -> n) + | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), + opt)) tml + in + let mkHole = RHole (dummy_loc, InternalHole) in + let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), + [mkHole; c; n]) + in + let eqs_types = + List.map + (fun (c, (n, _)) -> + let id = match n with Name id -> id | _ -> assert false in + let heqid = id_of_string ("Heq" ^ string_of_id id) in + Name heqid, mkeq c (RVar (dummy_loc, id))) + tml + in + let po = + List.fold_right + (fun (n,t) acc -> + RProd (dummy_loc, Anonymous, t, acc)) + eqs_types (match po with + Some e -> e + | None -> mkHole) + in + let eqns = + List.map (fun (loc, idl, cpl, c) -> + let c' = + List.fold_left + (fun acc (n, t) -> + RLambda (dummy_loc, n, mkHole, acc)) + c eqs_types + in (loc, idl, cpl, c')) + eqns + in + let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), + [mkHole; c]) + in + let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in + let case = RCases (loc,Some po,tml,eqns) in + let app = RApp (dummy_loc, case, refls) in + app + +let rec rewrite_cases c = + match c with + RCases _ -> let c' = map_rawconstr rewrite_cases c in + (match c' with + | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) + | _ -> assert(false)) + | _ -> map_rawconstr rewrite_cases c + +let rewrite_cases env c = + let c' = rewrite_cases c in + let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in + c' let list_mapi f = let rec aux i = function diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index a90f281f..4a7e8177 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -18,12 +18,13 @@ val fixsub_module : string list val init_constant : string list -> string -> constr val init_reference : string list -> string -> global_reference val fixsub : constr lazy_t -val make_ref : string -> reference -val well_founded_ref : reference -val acc_ref : reference -val acc_inv_ref : reference -val fix_sub_ref : reference -val lt_wf_ref : reference +val well_founded_ref : global_reference lazy_t +val acc_ref : global_reference lazy_t +val acc_inv_ref : global_reference lazy_t +val fix_sub_ref : global_reference lazy_t +val fix_measure_sub_ref : global_reference lazy_t +val lt_ref : global_reference lazy_t +val lt_wf_ref : global_reference lazy_t val sig_ref : reference val proj1_sig_ref : reference val proj2_sig_ref : reference @@ -69,6 +70,8 @@ val string_of_hole_kind : hole_kind -> string val non_instanciated_map : env -> evar_defs ref -> evar_map val global_kind : logical_kind val goal_kind : locality_flag * goal_object_kind +val global_proof_kind : logical_kind +val goal_proof_kind : locality_flag * goal_object_kind val global_fix_kind : logical_kind val goal_fix_kind : locality_flag * goal_object_kind diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v index a29cd039..8429c267 100644 --- a/contrib/subtac/test/ListsTest.v +++ b/contrib/subtac/test/ListsTest.v @@ -5,12 +5,13 @@ Variable A : Set. Program Definition myhd : forall { l : list A | length l <> 0 }, A := fun l => - match l with + match `l with | nil => _ | hd :: tl => hd end. Proof. - destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition. + destruct l ; simpl ; intro H. + rewrite H in n ; intuition. Defined. @@ -24,7 +25,7 @@ Program Definition mytail : forall { l : list A | length l <> 0 }, list A := | hd :: tl => tl end. Proof. -destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition. +destruct l ; simpl ; intro H ; rewrite H in n ; intuition. Defined. Extraction mytail. @@ -50,7 +51,6 @@ Program Fixpoint append (l : list A) (l' : list A) { struct l } : | nil => l' | hd :: tl => hd :: (append tl l') end. -simpl. subst ; auto. simpl ; rewrite (subset_simpl (append tl0 l')). simpl ; subst. diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v index ab200354..0b40ef82 100644 --- a/contrib/subtac/test/Mutind.v +++ b/contrib/subtac/test/Mutind.v @@ -1,7 +1,13 @@ -Fixpoint f (a : nat) : nat := match a with 0 => 0 -| S a' => g a a' +Program Fixpoint f (a : nat) : nat := + match a with + | 0 => 0 + | S a' => g a a' end with g (a b : nat) { struct b } : nat := - match b with 0 => 0 + match b with + | 0 => 0 | S b' => f b' - end.
\ No newline at end of file + end. + +Check f. +Check g.
\ No newline at end of file diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v index 481b6708..ba5bdf23 100644 --- a/contrib/subtac/test/euclid.v +++ b/contrib/subtac/test/euclid.v @@ -12,8 +12,8 @@ reflexivity. Defined. Extraction testsig. -Extraction sigS. -Extract Inductive sigS => "" [ "" ]. +Extraction sig. +Extract Inductive sig => "" [ "" ]. Extraction testsig. Require Import Coq.Arith.Compare_dec. diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v new file mode 100644 index 00000000..4764037d --- /dev/null +++ b/contrib/subtac/test/measure.v @@ -0,0 +1,24 @@ +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. +Require Import Coq.Arith.Compare_dec. + +Require Import Coq.subtac.Utils. + +Fixpoint size (a : nat) : nat := + match a with + 0 => 1 + | S n => S (size n) + end. + +Program Fixpoint test_measure (a : nat) {measure a size} : nat := + match a with + | S (S n) => S (test_measure n) + | x => x + end. +subst. +unfold n0. +auto with arith. +Qed. + +Check test_measure. +Print test_measure.
\ No newline at end of file diff --git a/contrib/subtac/test/wf.v b/contrib/subtac/test/wf.v new file mode 100644 index 00000000..49fec2b8 --- /dev/null +++ b/contrib/subtac/test/wf.v @@ -0,0 +1,48 @@ +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. +Require Import Coq.Arith.Compare_dec. + +Require Import Coq.subtac.Utils. + +Ltac one_simpl_hyp := + match goal with + | [H : (`exist _ _ _) = _ |- _] => simpl in H + | [H : _ = (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) < _ |- _] => simpl in H + | [H : _ < (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) <= _ |- _] => simpl in H + | [H : _ <= (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) > _ |- _] => simpl in H + | [H : _ > (`exist _ _ _) |- _] => simpl in H + | [H : (`exist _ _ _) >= _ |- _] => simpl in H + | [H : _ >= (`exist _ _ _) |- _] => simpl in H + end. + +Ltac one_simpl_subtac := + destruct_exists ; + repeat one_simpl_hyp ; simpl. + +Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl. + +Require Import Omega. +Require Import Wf_nat. + +Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : + { q : nat & { r : nat | a = b * q + r /\ r < b } } := + if le_lt_dec b a then let (q', r) := euclid (a - b) b in + (S q' & r) + else (O & a). +destruct b ; simpl_subtac. +omega. +simpl_subtac. +assert(x0 * S q' = x0 + x0 * q'). +rewrite <- mult_n_Sm. +omega. +rewrite H2 ; omega. +simpl_subtac. +split ; auto with arith. +omega. +apply lt_wf. +Defined. + +Check euclid_evars_proof.
\ No newline at end of file diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 2235be4a..b6b1c7b6 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -474,7 +474,7 @@ let kind_of_global r = match r with | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> let isrecord = - try let _ = Recordops.lookup_structure kn in true + try let _ = Recordops.lookup_projections kn in true with Not_found -> false in kind_of_inductive isrecord (fst kn) | Ln.VarRef id -> kind_of_variable id diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index f60e3203..90e29496 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -13,11 +13,23 @@ Lib: library_part -> remove_section_part Printer: prterm -> pr_lconstr Printer: prterm_env -> pr_lconstr_env Ppconstr: pr_sort -> pr_rawsort +Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) +Pretyping: + - understand_gen_tcc and understand_gen_ltac merged into understand_ltac + - type_constraints can now say typed by a sort (use OfType to get the + previous behavior) +Library: import_library -> import_module ** Constructors Declarations: mind_consnrealargs -> mind_consnrealdecls NoRedun -> NoDup +Cast and RCast have an extra argument: you can recover the previous + behavior by setting the extra argument to "CastConv DEFAULTcast" and + "DEFAULTcast" respectively +Names: "kernel_name" is now "constant" when argument of Term.Const +Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert +Tacexpr: TacForward(true,_,_) branched to TacLetTac ** Modules @@ -27,11 +39,20 @@ module Tacred spawned module Redexpr module Symbols -> Notation module Coqast, Ast, Esyntax, Termast, and all other modules related to old syntax are removed +module Instantiate: integrated to Evd +module Pretyping now a functor: use Pretyping.Default instead ** Internal names OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE +** Tactic extensions + +- printers have an extra parameter which is a constr printer at high precedence +- the tactic printers have an extra arg which is the expected precedence +- level is now a precedence in declare_extra_tactic_pprule +- "interp" functions now of types the actual arg type, not its encapsulation + as a generic_argument ========================================= = CHANGES BETWEEN COQ V7.4 AND COQ V8.0 = diff --git a/doc/Makefile b/doc/Makefile index fd508e07..6209b0c8 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -110,7 +110,7 @@ REFMANCOQTEXFILES=\ refman/RefMan-mod.v.tex refman/RefMan-tac.v.tex \ refman/RefMan-cic.v.tex refman/RefMan-lib.v.tex \ refman/RefMan-tacex.v.tex refman/RefMan-syn.v.tex \ - refman/RefMan-oth.v.tex \ + refman/RefMan-oth.v.tex refman/RefMan-ltac.v.tex \ refman/Cases.v.tex refman/Coercion.v.tex refman/Extraction.v.tex \ refman/Program.v.tex refman/Omega.v.tex refman/Polynom.v.tex \ refman/Setoid.v.tex refman/Helm.tex # refman/Natural.v.tex @@ -119,7 +119,7 @@ REFMANTEXFILES=\ refman/headers.tex \ refman/Reference-Manual.tex refman/RefMan-pre.tex \ refman/RefMan-int.tex refman/RefMan-pro.tex \ - refman/RefMan-com.tex refman/RefMan-ltac.tex \ + refman/RefMan-com.tex \ refman/RefMan-uti.tex refman/RefMan-ide.tex \ refman/RefMan-add.tex refman/RefMan-modr.tex \ $(REFMANCOQTEXFILES) \ @@ -161,9 +161,15 @@ refman/html/index.html: refman/Reference-Manual.html $(REFMANPNGFILES) \ mkdir refman/html cp $(REFMANPNGFILES) refman/html (cd refman/html; hacha -o toc.html ../Reference-Manual.html) - cp refman/cover.html refman/html + cp refman/cover.html refman/menu.html refman/html cp refman/index.html refman/html +refman-quick: + (cd refman; \ + $(PDFLATEX) Reference-Manual.tex; \ + hevea -fix -exec xxdate.exe ./Reference-Manual.tex) + + ###################################################################### # Tutorial ###################################################################### diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 393b8547..2465d70f 100755 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -161,6 +161,7 @@ \newcommand{\form}{\textrm{\textsl{form}}} \newcommand{\entry}{\textrm{\textsl{entry}}} \newcommand{\proditem}{\textrm{\textsl{production\_item}}} +\newcommand{\taclevel}{\textrm{\textsl{tactic\_level}}} \newcommand{\tacargtype}{\textrm{\textsl{tactic\_argument\_type}}} \newcommand{\scope}{\textrm{\textsl{scope}}} \newcommand{\optscope}{\textrm{\textsl{opt\_scope}}} @@ -182,6 +183,7 @@ \newcommand{\name}{\textrm{\textsl{name}}} \newcommand{\num}{\textrm{\textsl{num}}} \newcommand{\pattern}{\textrm{\textsl{pattern}}} +\newcommand{\orpattern}{\textrm{\textsl{or\_pattern}}} \newcommand{\intropattern}{\textrm{\textsl{intro\_pattern}}} \newcommand{\pat}{\textrm{\textsl{pat}}} \newcommand{\pgs}{\textrm{\textsl{pgms}}} @@ -200,6 +202,7 @@ \newcommand{\str}{\textrm{\textsl{string}}} \newcommand{\subsequentletter}{\textrm{\textsl{subsequent\_letter}}} \newcommand{\switch}{\textrm{\textsl{switch}}} +\newcommand{\messagetoken}{\textrm{\textsl{message\_token}}} \newcommand{\tac}{\textrm{\textsl{tactic}}} \newcommand{\terms}{\textrm{\textsl{terms}}} \newcommand{\term}{\textrm{\textsl{term}}} @@ -488,7 +491,7 @@ {\begin{center}\begin{rulebox}} {\end{rulebox}\end{center}} -% $Id: macros.tex 8606 2006-02-23 13:58:10Z herbelin $ +% $Id: macros.tex 9038 2006-07-11 13:53:53Z herbelin $ %%% Local Variables: diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index a05231cd..dfe9e94c 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -1,5 +1,5 @@ \achapter{Extended pattern-matching}\defaultheaders -\aauthor{Cristina Cornes} +\aauthor{Cristina Cornes and Hugo Herbelin} \label{Mult-match-full} \ttindex{Cases} @@ -17,32 +17,38 @@ pattern. It is recommended to start variable names by a lowercase letter. If a pattern has the form $(c~\vec{x})$ where $c$ is a constructor -symbol and $\vec{x}$ is a linear vector of variables, it is called -{\em simple}: it is the kind of pattern recognized by the basic -version of {\tt match}. If a pattern is -not simple we call it {\em nested}. +symbol and $\vec{x}$ is a linear vector of (distinct) variables, it is +called {\em simple}: it is the kind of pattern recognized by the basic +version of {\tt match}. On the opposite, if it is a variable $x$ or +has the form $(c~\vec{p})$ with $p$ not only made of variables, the +pattern is called {\em nested}. A variable pattern matches any value, and the identifier is bound to that value. The pattern ``\texttt{\_}'' (called ``don't care'' or -``wildcard'' symbol) also matches any value, but does not bind anything. It -may occur an arbitrary number of times in a pattern. Alias patterns -written \texttt{(}{\sl pattern} \texttt{as} {\sl identifier}\texttt{)} are -also accepted. This pattern matches the same values as {\sl pattern} -does and {\sl identifier} is bound to the matched value. A list of -patterns separated with commas -is also considered as a pattern and is called {\em multiple -pattern}. +``wildcard'' symbol) also matches any value, but does not bind +anything. It may occur an arbitrary number of times in a +pattern. Alias patterns written \texttt{(}{\sl pattern} \texttt{as} +{\sl identifier}\texttt{)} are also accepted. This pattern matches the +same values as {\sl pattern} does and {\sl identifier} is bound to the +matched value. +A pattern of the form {\pattern}{\tt |}{\pattern} is called +disjunctive. A list of patterns separated with commas is also +considered as a pattern and is called {\em multiple pattern}. However +multiple patterns can only occur at the root of pattern-matching +equations. Disjunctions of {\em multiple pattern} are allowed though. Since extended {\tt match} expressions are compiled into the primitive ones, the expressiveness of the theory remains the same. Once the -stage of parsing has finished only simple patterns remain. An easy way -to see the result of the expansion is by printing the term with -\texttt{Print} if the term is a constant, or using the command +stage of parsing has finished only simple patterns remain. Re-nesting +of pattern is performed at printing time. An easy way to see the +result of the expansion is to toggle off the nesting performed at +printing (use here {\tt Set Printing Matching}), then by printing the term +with \texttt{Print} if the term is a constant, or using the command \texttt{Check}. The extended \texttt{match} still accepts an optional {\em elimination predicate} given after the keyword \texttt{return}. Given a pattern -matching expression, if all the right hand sides of \texttt{=>} ({\em +matching expression, if all the right-hand-sides of \texttt{=>} ({\em rhs} in short) have the same type, then this type can be sometimes synthesized, and so we can omit the \texttt{return} part. Otherwise the predicate after \texttt{return} has to be provided, like for the basic @@ -64,7 +70,9 @@ Fixpoint max (n m:nat) {struct m} : nat := end. \end{coq_example} -Using multiple patterns in the definition allows to write: +\paragraph{Multiple patterns} + +Using multiple patterns in the definition of {\tt max} allows to write: \begin{coq_example} Reset max. @@ -89,7 +97,9 @@ Check (fun x:nat => match x return nat with end). \end{coq_example} -We can also use ``\texttt{as} patterns'' to associate a name to a +\paragraph{Aliasing subpatterns} + +We can also use ``\texttt{as} {\ident}'' to associate a name to a sub-pattern: \begin{coq_example} @@ -102,6 +112,8 @@ Fixpoint max (n m:nat) {struct n} : nat := end. \end{coq_example} +\paragraph{Nested patterns} + Here is now an example of nested patterns: \begin{coq_example} @@ -157,7 +169,6 @@ Fixpoint lef (n m:nat) {struct m} : bool := end. \end{coq_example} - Here the last pattern superposes with the first two. Because of the priority rule, the last pattern will be used only for values that do not match neither the first nor @@ -180,12 +191,50 @@ Check (fun x:nat => end). \end{coq_example} +\paragraph{Disjunctive patterns} + +Multiple patterns that share the same right-hand-side can be +factorized using the notation \nelist{\multpattern}{\tt |}. For instance, +{\tt max} can be rewritten as follows: + +\begin{coq_eval} +Reset max. +\end{coq_eval} +\begin{coq_example} +Fixpoint max (n m:nat) {struct m} : nat := + match n, m with + | S n', S m' => S (max n' m') + | 0, p | p, 0 => p + end. +\end{coq_example} + +Similarly, factorization of (non necessary multiple) patterns +that share the same variables is possible by using the notation +\nelist{\pattern}{\tt |}. Here is an example: + +\begin{coq_example} +Definition filter_2_4 (n:nat) : nat := + match n with + | 2 as m | 4 as m => m + | _ => 0 + end. +\end{coq_example} + +Here is another example using disjunctive subpatterns. + +\begin{coq_example} +Definition filter_some_square_corners (p:nat*nat) : nat*nat := + match p with + | ((2 as m | 4 as m), (3 as n | 5 as n)) => (m,n) + | _ => (0,0) + end. +\end{coq_example} + \asection{About patterns of parametric types} When matching objects of a parametric type, constructors in patterns {\em do not expect} the parameter arguments. Their value is deduced during expansion. - -Consider for example the polymorphic lists: +Consider for example the type of polymorphic lists: \begin{coq_example} Inductive List (A:Set) : Set := diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index e288cdfb..0a2f5904 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -218,10 +218,10 @@ either an assumption, written $x:T$ ($T$ is a type) or a definition, written $x:=t:T$. We use brackets to write contexts. A typical example is $[x:T;y:=u:U;z:V]$. Notice that the variables declared in a context must be distinct. If $\Gamma$ declares some $x$, -we write $x \in\Gamma$. By writing $(x:T)\in\Gamma$ we mean that +we write $x \in \Gamma$. By writing $(x:T) \in \Gamma$ we mean that either $x:T$ is an assumption in $\Gamma$ or that there exists some $t$ such that $x:=t:T$ is a definition in $\Gamma$. If $\Gamma$ defines some -$x:=t:T$, we also write $(x:=t:T)\in\Gamma$. Contexts must be +$x:=t:T$, we also write $(x:=t:T) \in \Gamma$. Contexts must be themselves {\em well formed}. For the rest of the chapter, the notation $\Gamma::(y:T)$ (resp. $\Gamma::(y:=t:T)$) denotes the context $\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The @@ -233,8 +233,8 @@ notation $[]$ denotes the empty context. \index{Context} We define the inclusion of two contexts $\Gamma$ and $\Delta$ (written as $\Gamma \subset \Delta$) as the property, for all variable $x$, -type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T)\in \Delta$ -and if $(x:=t:T) \in \Gamma$ then $(x:=t:T)\in \Delta$. +type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T) \in \Delta$ +and if $(x:=t:T) \in \Gamma$ then $(x:=t:T) \in \Delta$. %We write % $|\Delta|$ for the length of the context $\Delta$, that is for the number % of declarations (assumptions or definitions) in $\Delta$. @@ -288,28 +288,30 @@ be derived from the following rules. \begin{description} \item[W-E] \inference{\WF{[]}{[]}} \item[W-S] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma -\inference{\frac{\WTEG{T}{s}~~~~s\in \Sort~~~~x \not\in +\inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in \Gamma % \cup E } {\WFE{\Gamma::(x:T)}}~~~~~ \frac{\WTEG{t}{T}~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:=t:T)}}} -\item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E\cup \Gamma} +\item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E \cup \Gamma} {\WF{E;\Def{\Gamma}{c}{t}{T}}{\Gamma}}} +\item[Assum] \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~c \notin E \cup \Gamma} + {\WF{E;\Assum{\Gamma}{c}{T}}{\Gamma}}} \item[Ax] \index{Typing rules!Ax} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(p)}}~~~~~ \frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(q)}}} \inference{\frac{\WFE{\Gamma}~~~~i<j}{\WTEG{\Type(i)}{\Type(j)}}} \item[Var]\index{Typing rules!Var} - \inference{\frac{ \WFE{\Gamma}~~~~~(x:T)\in\Gamma~~\mbox{or}~~(x:=t:T)\in\Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}} + \inference{\frac{ \WFE{\Gamma}~~~~~(x:T) \in \Gamma~~\mbox{or}~~(x:=t:T) \in \Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}} \item[Const] \index{Typing rules!Const} -\inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E}{\WTEG{c}{T}}} +\inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E~~\mbox{or}~~(c:=t:T) \in E~\mbox{for some $t$} }{\WTEG{c}{T}}} \item[Prod] \index{Typing rules!Prod} \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~ \WTE{\Gamma::(x:T)}{U}{\Prop}} { \WTEG{\forall~x:T,U}{\Prop}}} -\inference{\frac{\WTEG{T}{s}~~~~s\in\{\Prop, \Set\}~~~~~~ +\inference{\frac{\WTEG{T}{s}~~~~s \in\{\Prop, \Set\}~~~~~~ \WTE{\Gamma::(x:T)}{U}{\Set}} { \WTEG{\forall~x:T,U}{\Set}}} \inference{\frac{\WTEG{T}{\Type(i)}~~~~i\leq k~~~ @@ -373,7 +375,7 @@ environment. It is legal to identify such a reference with its value, that is to expand (or unfold) it into its value. This reduction is called $\delta$-reduction and shows as follows. -$$\WTEGRED{x}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(x:=t:T)\in\Gamma$}~~~~~~~~~\WTEGRED{c}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(c:=t:T)\in E$}$$ +$$\WTEGRED{x}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(x:=t:T) \in \Gamma$}~~~~~~~~~\WTEGRED{c}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(c:=t:T) \in E$}$$ \paragraph{$\zeta$-reduction.} @@ -553,15 +555,13 @@ represented by: \List}\] Assuming $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is - $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are: + $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are, + for $1\leq j\leq k$ and $1\leq i\leq n$: \bigskip -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E - ~~j=1\ldots k}{(I_j:A_j) \in E}} +\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E - ~~~~i=1.. n} - {(c_i:C_i)\in E}} +\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} \subsubsection{Inductive definitions with parameters} @@ -593,11 +593,11 @@ p_1:P_1,\ldots,\forall p_r:P_r,\forall a_1:A_1, \ldots \forall a_n:A_n, with $I$ one of the inductive definitions in $\Gamma_I$. We say that $n$ is the number of real arguments of the constructor $c$. -\paragraph{Context of parameters} +\paragraph{Context of parameters.} If an inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits $r$ inductive parameters, then there exists a context $\Gamma_P$ of -size $r$, such that $\Gamma_P=p_1:P_1;\ldots;\forall p_r:P_r$ and -if $(t:A)\in\Gamma_I,\Gamma_C$ then $A$ can be written as +size $r$, such that $\Gamma_P=p_1:P_1;\ldots;p_r:P_r$ and +if $(t:A) \in \Gamma_I,\Gamma_C$ then $A$ can be written as $\forall p_1:P_1,\ldots \forall p_r:P_r,A'$. We call $\Gamma_P$ the context of parameters of the inductive definition and use the notation $\forall \Gamma_P,A'$ for the term $A$. @@ -741,7 +741,7 @@ contains an inductive declaration. \inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E ~~~~i=1.. n} - {(c_i:C_i)\in E}} + {(c_i:C_i) \in E}} \end{description} \paragraph{Example.} @@ -848,16 +848,16 @@ inductive definition. \begin{description} \item[W-Ind] Let $E$ be an environment and $\Gamma,\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that - $\Gamma_I$ is $[I_1:\forall \Gamma_p,A_1;\ldots;I_k:\forall + $\Gamma_I$ is $[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ and $\Gamma_C$ is - $[c_1:\forall \Gamma_p,C_1;\ldots;c_n:\forall \Gamma_p,C_n]$. + $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$. \inference{ \frac{ (\WTE{\Gamma;\Gamma_P}{A_j}{s'_j})_{j=1\ldots k} ~~ (\WTE{\Gamma;\Gamma_I;\Gamma_P}{C_i}{s_{p_i}})_{i=1\ldots n} } {\WF{E;\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}} -providing the following side conditions hold: +provided that the following side conditions hold: \begin{itemize} \item $k>0$, $I_j$, $c_i$ are different names for $j=1\ldots k$ and $i=1\ldots n$, \item $p$ is the number of parameters of \NInd{\Gamma}{\Gamma_I}{\Gamma_C} @@ -874,7 +874,7 @@ arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative sort (\Prop) but may fail to define inductive definition on sort \Set{} and generate constraints between universes for -inductive definitions in types. +inductive definitions in the {\Type} hierarchy. \paragraph{Examples.} It is well known that existential quantifier can be encoded as an @@ -907,6 +907,135 @@ Inductive exType (P:Type->Prop) : Type %is recursive or not. We shall write the type $(x:_R T)C$ if it is %a recursive argument and $(x:_P T)C$ if the argument is not recursive. +\paragraph{Sort-polymorphism of inductive families.} +\index{Sort-polymorphism of inductive families} + +From {\Coq} version 8.1, inductive families declared in {\Type} are +polymorphic over their arguments in {\Type}. + +If $A$ is an arity and $s$ a sort, we write $A_{/s}$ for the arity +obtained from $A$ by replacing its sort with $s$. Especially, if $A$ +is well-typed in some environment and context, then $A_{/s}$ is typable +by typability of all products in the Calculus of Inductive Constructions. +The following typing rule is added to the theory. + +\begin{description} +\item[Ind-Family] Let $\Gamma_P$ be a context of parameters +$[p_1:P_1;\ldots;p_{m'}:P_{m'}]$ and $m\leq m'$ be the length of the +initial prefix of parameters that occur unchanged in the recursive +occurrences of the constructor types. Assume that $\Gamma_I$ is +$[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ and +$\Gamma_C$ is $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall +\Gamma_P,C_n]$. + +Let $q_1$, \ldots, $q_r$, with $0\leq r\leq m$, be a possibly partial +instantiation of the parameters in $\Gamma_P$. We have: + +\inference{\frac +{\left\{\begin{array}{l} +\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E\\ +(E[\Gamma] \vdash q_s : P'_s)_{s=1\ldots r}\\ +(E[\Gamma] \vdash \WTEGLECONV{P'_s}{\subst{P_s}{x_u}{q_u}_{u=1\ldots s-1}})_{s=1\ldots r}\\ +1 \leq j \leq k +\end{array} +\right.} +{(I_j\,q_1\,\ldots\,q_r:\forall \Gamma^{r+1}_p, (A_j)_{/s})} +} + +provided that the following side conditions hold: + +\begin{itemize} +\item $\Gamma_{P'}$ is the context obtained from $\Gamma_P$ by +replacing, each $P_s$ that is an arity with the +sort of $P'_s$, as soon as $1\leq s \leq r$ (notice that +$P_s$ arity implies $P'_s$ arity since $E[\Gamma] +\vdash \WTEGLECONV{P'_s}{ \subst{P_s}{x_u}{q_u}_{u=1\ldots s-1}}$); +\item there are sorts $s_i$, for $1 \leq i \leq k$ such that, for + $\Gamma_{I'}$ obtained from $\Gamma_I$ by changing each $A_i$ by $(A_i)_{/s_i}$, +we have $(\WTE{\Gamma;\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{p_i}})_{i=1\ldots n}$; +\item the sorts are such that all elimination are allowed (see +section~\ref{elimdep}). +\end{itemize} +\end{description} + +Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf +Ind-Const} and {\bf App}, then it is typable using the rule {\bf +Ind-Family}. Conversely, the extended theory is not stronger than the +theory without {\bf Ind-Family}. We get an equiconsistency result by +mapping each $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ occurring into a +given derivation into as many fresh inductive types and constructors +as the number of different (partial) replacements of sorts, needed for +this derivation, in the parameters that are arities. That is, the +changes in the types of each partial instance $q_1\,\ldots\,q_r$ can +be characterized by the ordered sets of arity sorts among the types of +parameters, and to each signature is associated a new inductive +definition with fresh names. Conversion is preserved as any (partial) +instance $I_j\,q_1\,\ldots\,q_r$ or $C_i\,q_1\,\ldots\,q_r$ is mapped +to the names chosen in the specific instance of +$\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$. + +\newcommand{\Single}{\mbox{\textsf{Set}}} + +In practice, the rule is used by {\Coq} only with in case the +inductive type is declared with an arity of a sort in the $\Type$ +hierarchy, and, then, the polymorphism is over the parameters whose +type is an arity in the {\Type} hierarchy. The sort $s_j$ are then +chosen canonically so that each $s_j$ is minimal with respect to the +hierarchy ${\Prop_u}\subset{\Set_p}\subset\Type$ where $\Set_p$ is +predicative {\Set}, and ${\Prop_u}$ is the sort of small singleton +inductive types (i.e. of inductive types with one single constructor +and that contains either proofs or inhabitants of singleton types +only). More precisely, a small singleton inductive family is set in +{\Prop}, a small non singleton inductive family is set in {\Set} (even +in case {\Set} is impredicative -- see section~\ref{impredicativity}), +and otherwise in the {\Type} hierarchy. +% TODO: clarify the case of a partial application ?? + +Note that the side-condition about allowed elimination sorts in the +rule~{\bf Ind-Family} is just to avoid to recompute the allowed +elimination sorts at each instance of a pattern-matching (see +section~\ref{elimdep}). + +As an example, let us consider the following definition: +\begin{coq_example*} +Inductive option (A:Type) : Type := +| None : option A +| Some : A -> option A. +\end{coq_example*} + +As the definition is set in the {\Type} hierarchy, it is used +polymorphically over its parameters whose types are arities of a sort +in the {\Type} hierarchy. Here, the parameter $A$ has this property, +hence, if \texttt{option} is applied to a type in {\Set}, the result is +in {\Set}. Note that if \texttt{option} is applied to a type in {\Prop}, +then, the result is not set in \texttt{Prop} but in \texttt{Set} +still. This is because \texttt{option} is not a singleton type (see +section~\ref{singleton}) and it would loose the elimination to {\Set} and +{\Type} if set in {\Prop}. + +\begin{coq_example} +Check (fun A:Set => option A). +Check (fun A:Prop => option A). +\end{coq_example} + +Here is another example. + +\begin{coq_example*} +Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. +\end{coq_example*} + +As \texttt{prod} is a singleton type, it will be in {\Prop} if applied +twice to propositions, in {\Set} if applied twice to at least one type +in {\Set} and none in {\Type}, and in {\Type} otherwise. In all cases, +the three kind of eliminations schemes are allowed. + +\begin{coq_example} +Check (fun A:Set => prod A). +Check (fun A:Prop => prod A A). +Check (fun (A:Prop) (B:Set) => prod A B). +Check (fun (A:Type) (B:Prop) => prod A B). +\end{coq_example} + \subsection{Destructors} The specification of inductive definitions with arities and constructors is quite natural. But we still have to say how to use an @@ -1049,6 +1178,7 @@ compact notation~: % \mbox{\tt =>}~ \false} \paragraph{Allowed elimination sorts.} + \index{Elimination sorts} An important question for building the typing rule for \kw{match} is @@ -1158,6 +1288,7 @@ the two projections on this type. %{\tt Program} tactic or when extracting ML programs. \paragraph{Empty and singleton elimination} +\label{singleton} \index{Elimination!Singleton elimination} \index{Elimination!Empty elimination} @@ -1167,7 +1298,7 @@ eliminations are allowed. \item[\Prop-extended] \inference{ \frac{I \mbox{~is an empty or singleton - definition}~~~s\in\Sort}{\compat{I:\Prop}{I\ra s}} + definition}~~~s \in \Sort}{\compat{I:\Prop}{I\ra s}} } \end{description} @@ -1530,7 +1661,7 @@ The major change in the theory concerns the rule for product formation in the sort \Set, which is extended to a domain in any sort~: \begin{description} \item [Prod] \index{Typing rules!Prod (impredicative Set)} -\inference{\frac{\WTEG{T}{s}~~~~s\in\Sort~~~~~~ +\inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~~~ \WTE{\Gamma::(x:T)}{U}{\Set}} { \WTEG{\forall~x:T,U}{\Set}}} \end{description} @@ -1553,7 +1684,7 @@ impredicative system for sort \Set{} become~: -% $Id: RefMan-cic.tex 8914 2006-06-07 14:57:22Z cpaulin $ +% $Id: RefMan-cic.tex 9001 2006-07-04 13:50:15Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index f8a7546f..8c54e0ed 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -86,6 +86,7 @@ you move the \Coq\ binaries and library after installation. \section{Options} \index{Options of the command line} +\label{vmoption} The following command-line options are recognized by the commands {\tt coqc} and {\tt coqtop}, unless stated otherwise: @@ -239,6 +240,11 @@ The following command-line options are recognized by the commands {\tt resulting in a smaller memory requirement and faster compilation; warning: this invalidates some features such as the extraction tool. +\item[{\tt -vm}]\ + + This activates the use of the bytecode-based conversion algorithm + for the current session (see section~\ref{SetVirtualMachine}). + \item[{\tt -image} {\em file}]\ This option sets the binary image to be used to be {\em file} @@ -272,7 +278,7 @@ The following command-line options are recognized by the commands {\tt % (see section~\ref{coqsearchisos}, page~\pageref{coqsearchisos}). % \end{description} -% $Id: RefMan-com.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $ +% $Id: RefMan-com.tex 9044 2006-07-12 13:22:17Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 503d7571..37660aa3 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -223,13 +223,14 @@ To deactivate the printing of projections, use \label{Mult-match}} The basic version of \verb+match+ allows pattern-matching on simple -patterns. As an extension, multiple and nested patterns are -allowed, as in ML-like languages. +patterns. As an extension, multiple nested patterns or disjunction of +patterns are allowed, as in ML-like languages. The extension just acts as a macro that is expanded during parsing into a sequence of {\tt match} on simple patterns. Especially, a -construction defined using the extended {\tt match} is printed under -its expanded form. +construction defined using the extended {\tt match} is generally +printed under its expanded form (see~\texttt{Set Printing Matching} in +section~\ref{SetPrintingMatching}). \SeeAlso chapter \ref{Mult-match-full}. @@ -330,11 +331,40 @@ The general equivalence for an inductive type with one constructors {\tt C} is $\equiv$~ {\tt match {\term} \zeroone{\ifitem} with C {\ident}$_1$ {\ldots} {\ident}$_n$ \verb!=>! {\term}' end} -\subsection{Options for pretty-printing of {\tt match} +\subsection{Controlling pretty-printing of {\tt match} expressions \label{printing-options}} -There are three options controlling the pretty-printing of {\tt match} -expressions. +The following commands give some control over the pretty-printing of +{\tt match} expressions. + +\subsubsection{Printing nested patterns +\label{SetPrintingMatching} +\comindex{Set Printing Matching} +\comindex{Unset Printing Matching} +\comindex{Test Printing Matching}} + +The Calculus of Inductive Constructions knows pattern-matching only +over simple patterns. It is however convenient to re-factorize nested +pattern-matching into a single pattern-matching over a nested pattern. +{\Coq}'s printer try to do such limited re-factorization. + +\begin{quote} +{\tt Set Printing Matching.} +\end{quote} +This tells {\Coq} to try to use nested patterns. This is the default +behavior. + +\begin{quote} +{\tt Unset Printing Matching.} +\end{quote} +This tells {\Coq} to print only simple pattern-matching problems in +the same way as the {\Coq} kernel handles them. + +\begin{quote} +{\tt Test Printing Matching.} +\end{quote} +This tells if the printing matching mode is on or off. The default is +on. \subsubsection{Printing of wildcard pattern \comindex{Set Printing Wildcard} @@ -1088,6 +1118,18 @@ the declaration \SeeAlso more examples in user contribution \texttt{category} (\texttt{Rocq/ALGEBRA}). +\subsubsection{Print Canonical Projections. +\comindex{Print Canonical Projections}} + +This displays the list of global names that are components of some +canonical structure. For each of them, the canonical structure of +which it is a projection is indicated. For instance, the above example +gives the following output: + +\begin{coq_example} +Print Canonical Projections. +\end{coq_example} + \subsection{Implicit types of variables} It is possible to bind variable names to a given type (e.g. in a diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 2214864a..e7b825d7 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -64,15 +64,24 @@ That is, they are recognized by the following lexical class: \begin{center} \begin{tabular}{rcl} {\firstletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt \_} -% $\mid$ {\tt unicode-letter} +$\mid$ {\tt unicode-letter} \\ {\subsequentletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt 0..9} $\mid$ {\tt \_} % $\mid$ {\tt \$} -$\mid$ {\tt '} \\ +$\mid$ {\tt '} +$\mid$ {\tt unicode-letter} +$\mid$ {\tt unicode-id-part} \\ {\ident} & ::= & {\firstletter} \sequencewithoutblank{\subsequentletter}{} \end{tabular} \end{center} -All characters are meaningful. In particular, identifiers are case-sensitive. +All characters are meaningful. In particular, identifiers are +case-sensitive. The entry {\tt unicode-letter} non-exhaustively +includes Latin, Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, +Hangul, Hiragana and Katakana characters, CJK ideographs, mathematical +letter-like symbols, hyphens, non-breaking space, {\ldots} The entry +{\tt unicode-id-part} non-exhaustively includes symbols for prime +letters and subscripts. + Access identifiers, written {\accessident}, are identifiers prefixed by \verb!.! (dot) without blank. They are used in the syntax of qualified identifiers. @@ -308,7 +317,9 @@ chapter \ref{Addoc-syntax}. &&\\ {\returntype} & ::= & {\tt return} {\term} \\ &&\\ -{\eqn} & ::= & \nelist{\pattern}{\tt ,} {\tt =>} {\term}\\ +{\eqn} & ::= & \nelist{\multpattern}{\tt |} {\tt =>} {\term}\\ +&&\\ +{\multpattern} & ::= & \nelist{\pattern}{\tt ,}\\ &&\\ {\pattern} & ::= & {\qualid} \nelist{\pattern}{} \\ & $|$ & {\pattern} {\tt as} {\ident} \\ @@ -316,7 +327,9 @@ chapter \ref{Addoc-syntax}. & $|$ & {\qualid} \\ & $|$ & {\tt \_} \\ & $|$ & {\num} \\ - & $|$ & {\tt (} \nelist{\pattern}{,} {\tt )} + & $|$ & {\tt (} \nelist{\orpattern}{,} {\tt )} \\ +\\ +{\orpattern} & ::= & \nelist{\pattern}{\tt |}\\ \end{tabular} \end{centerframe} \caption{Syntax of terms (continued)} @@ -515,10 +528,11 @@ The expression {\tt match} {\term$_0$} {\returntype} {\tt with} {\pattern$_1$} {\tt =>} {\term$_1$} {\tt $|$} {\ldots} {\tt $|$} {\pattern$_n$} {\tt =>} {\term$_n$} {\tt end}, denotes a {\em pattern-matching} over the term {\term$_0$} (expected to be of an -inductive type $I$). {\term$_1$}\ldots{\term$_n$} are called branches. In +inductive type $I$). +The terms {\term$_1$}\ldots{\term$_n$} are called branches. In a simple pattern \qualid~\nelist{\ident}{}, the qualified identifier {\qualid} is intended to -be a constructor. There should be a branch for every constructor of +be a constructor. There should be one branch for every constructor of $I$. The {\returntype} is used to compute the resulting type of the whole @@ -530,9 +544,8 @@ annotation has to be given when the resulting type of the whole {\tt match} depends on the actual {\term$_0$} matched. There are specific notations for case analysis on types with one or -two constructors: {\tt if / then / else} and -{\tt let (}\ldots{\tt ) :=} \ldots {\tt in}\ldots. \SeeAlso -section~\ref{Mult-match} for details and examples. +two constructors: {\tt if {\ldots} then {\ldots} else {\ldots}} and +{\tt let (}\nelist{\ldots}{,}{\tt ) :=} {\ldots} {\tt in} {\ldots}. \SeeAlso Section~\ref{Mult-match} for details and examples. @@ -761,12 +774,17 @@ environment, provided that {\term} is well-typed. {\binder$_1$}\ldots{\binder$_n$}{\tt ,}\,\term$_1$\,{\tt :=}}\,% {\tt fun}\,{\binder$_1$}\ldots{\binder$_n$}\,{\tt =>}\,{\term$_2$}\,% {\tt .} + +\item {\tt Example {\ident} := {\term}.}\\ +{\tt Example {\ident} {\tt :}{\term$_1$} := {\term$_2$}.}\\ +{\tt Example {\ident} {\binder$_1$}\ldots{\binder$_n$} + {\tt :}\term$_1$ {\tt :=} {\term$_2$}.}\\ +\comindex{Example} +These are synonyms of the {\tt Definition} forms. \end{Variants} \begin{ErrMsgs} -\item \errindex{In environment {\dots} the term: {\term$_2$} does not have type - {\term$_1$}}.\\ - \texttt{Actually, it has type {\term$_3$}}. +\item \errindex{Error: The term ``{\term}'' has type "{\type}" while it is expected to have type ``{\type}''} \end{ErrMsgs} \SeeAlso Sections \ref{Opaque}, \ref{Transparent}, \ref{unfold} @@ -1062,17 +1080,23 @@ inductive types The extended syntax is: \medskip {\tt -Inductive {{\ident$_1$} {\params} : {\type$_1$} := \\ -\mbox{}\hspace{0.4cm} {\ident$_1^1$} : {\type$_1^1$} \\ -\mbox{}\hspace{0.1cm}| .. \\ -\mbox{}\hspace{0.1cm}| {\ident$_{n_1}^1$} : {\type$_{n_1}^1$} \\ +\begin{tabular}{l} +Inductive {\ident$_1$} {\params} : {\type$_1$} := \\ +\begin{tabular}{clcl} + & {\ident$_1^1$} &:& {\type$_1^1$} \\ + | & {\ldots} && \\ + | & {\ident$_{n_1}^1$} &:& {\type$_{n_1}^1$} +\end{tabular} \\ with\\ -\mbox{}\hspace{0.1cm} .. \\ +~{\ldots} \\ with {\ident$_m$} {\params} : {\type$_m$} := \\ -\mbox{}\hspace{0.4cm}{\ident$_1^m$} : {\type$_1^m$} \\ -\mbox{}\hspace{0.1cm}| .. \\ -\mbox{}\hspace{0.1cm}| {\ident$_{n_m}^m$} : {\type$_{n_m}^m$}. -}} +\begin{tabular}{clcl} + & {\ident$_1^m$} &:& {\type$_1^m$} \\ + | & {\ldots} \\ + | & {\ident$_{n_m}^m$} &:& {\type$_{n_m}^m$}. +\end{tabular} +\end{tabular} +} \medskip \Example @@ -1184,20 +1208,22 @@ how to introduce infinite objects in Section~\ref{CoFixpoint}. %% \subsection{Definition of recursive functions} -\subsubsection{\tt Fixpoint {\ident} {\params} {\tt \{struct} +\subsubsection{Recursive functions over a inductive type} + +The command: +\begin{center} + \texttt{Fixpoint {\ident} {\params} {\tt \{struct} \ident$_0$ {\tt \}} : type$_0$ := \term$_0$ -\comindex{Fixpoint} -\label{Fixpoint}} - -This command allows to define inductive objects using a fixed point -construction. The meaning of this declaration is to define {\it ident} -a recursive function with arguments specified by the binders in -\params{} % {\binder$_1$}\ldots{\binder$_n$} -such that {\it ident} applied to -arguments corresponding to these binders has type \type$_0$, and is -equivalent to the expression \term$_0$. The type of the {\ident} is -consequently {\tt forall {\params} {\tt,} \type$_0$} -and the value is equivalent to {\tt fun {\params} {\tt =>} \term$_0$}. + \comindex{Fixpoint}\label{Fixpoint}} +\end{center} +allows to define inductive objects using a fixed point construction. +The meaning of this declaration is to define {\it ident} a recursive +function with arguments specified by the binders in {\params} such +that {\it ident} applied to arguments corresponding to these binders +has type \type$_0$, and is equivalent to the expression \term$_0$. The +type of the {\ident} is consequently {\tt forall {\params} {\tt,} + \type$_0$} and the value is equivalent to {\tt fun {\params} {\tt + =>} \term$_0$}. To be accepted, a {\tt Fixpoint} definition has to satisfy some syntactical constraints on a special argument called the decreasing @@ -1205,8 +1231,8 @@ argument. They are needed to ensure that the {\tt Fixpoint} definition always terminates. The point of the {\tt \{struct \ident {\tt \}}} annotation is to let the user tell the system which argument decreases along the recursive calls. This annotation may be left implicit for -fixpoints with one argument. For instance, one can define the addition -function as : +fixpoints where only one argument has an inductive type. For instance, +one can define the addition function as : \begin{coq_example} Fixpoint add (n m:nat) {struct n} : nat := @@ -1323,23 +1349,25 @@ Fixpoint tree_size (t:tree) : nat := A generic command {\tt Scheme} is useful to build automatically various mutual induction principles. It is described in Section~\ref{Scheme}. -\subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$} - {\tt \{}decrease\_annot{\tt\}} : type$_0$ := \term$_0$. -} -\comindex{Function} -\label{Function} - -This \emph{experimental} command can be seen as a generalization of -{\tt Fixpoint}. It is actually a wrapper for several ways of defining -a function \emph{and other useful related objects}, namely: an -induction principle that reflects the recursive structure of the -function (see \ref{FunInduction}), and its fixpoint equality (not -always, see below). The meaning of this declaration is to define a -function {\it ident}, similarly to {\tt Fixpoint}. Like in {\tt -Fixpoint}, the decreasing argument must be given (unless the function -is not recursive), but it must not necessary be \emph{structurally} -decreasing. The point of the {\tt -\{\}} annotation is to name the decreasing argument \emph{and} to +\subsubsection{A more complex definition of recursive functions} + +The \emph{experimental} command +\begin{center} + \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} + \{decrease\_annot\} : type$_0$ := \term$_0$} + \comindex{Function} + \label{Function} +\end{center} +can be seen as a generalization of {\tt Fixpoint}. It is actually a +wrapper for several ways of defining a function \emph{and other useful + related objects}, namely: an induction principle that reflects the +recursive structure of the function (see \ref{FunInduction}), and its +fixpoint equality (not always, see below). The meaning of this +declaration is to define a function {\it ident}, similarly to {\tt + Fixpoint}. Like in {\tt Fixpoint}, the decreasing argument must be +given (unless the function is not recursive), but it must not +necessary be \emph{structurally} decreasing. The point of the {\tt + \{\}} annotation is to name the decreasing argument \emph{and} to describe which kind of decreasing criteria must be used to ensure termination of recursive calls. @@ -1416,43 +1444,35 @@ This error happens generally when: \SeeAlso{\ref{FunScheme},\ref{FunScheme-examples},\ref{FunInduction}} -Depending on the {\tt \{\}} annotation, different definition +Depending on the {\tt \{$\ldots$\}} annotation, different definition mechanisms are used by {\tt Function}. More precise description given below. - - -\subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$} - : type$_0$ := \term$_0$. -\comindex{Function} -} - -Defines the not recursive function \ident\ as if declared with -\texttt{Definition}. Three elimination schemes {\tt\ident\_rect}, -{\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the -documentation of {\tt Inductive} \ref{Inductive}), which reflect the -pattern matching structure of \term$_0$. - - -\subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$} - {\tt \{}{\tt struct} \ident$_0${\tt\}} : type$_0$ := \term$_0$. -\comindex{Function} -} - -Defines the structural recursive function \ident\ as if declared with -\texttt{Fixpoint} . Three induction schemes {\tt\ident\_rect}, -{\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the -documentation of {\tt Inductive} \ref{Inductive}), which reflect the -recursive structure of \term$_0$. When there is only one parameter, -{\tt \{struct} \ident$_0${\tt\}} can be omitted. - -\subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$} - {\tt \{}{\tt measure \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$. -\comindex{Function}} - -\subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$} - {\tt \{}{\tt wf \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$. -\comindex{Function}} +\begin{Variants} +\item \texttt{ Function {\ident} {\binder$_1$}\ldots{\binder$_n$} + : type$_0$ := \term$_0$} + + Defines the not recursive function \ident\ as if declared with + \texttt{Definition}. Three elimination schemes {\tt\ident\_rect}, + {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the + documentation of {\tt Inductive} \ref{Inductive}), which reflect the + pattern matching structure of \term$_0$. + +\item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} + {\tt \{}{\tt struct} \ident$_0${\tt\}} : type$_0$ := \term$_0$} + + Defines the structural recursive function \ident\ as if declared + with \texttt{Fixpoint}. Three induction schemes {\tt\ident\_rect}, + {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the + documentation of {\tt Inductive} \ref{Inductive}), which reflect the + recursive structure of \term$_0$. When there is only one parameter, + {\tt \{struct} \ident$_0${\tt\}} can be omitted. + +\item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} {\tt + \{}{\tt measure \term$_1$} \ident$_0${\tt\}} : type$_0$ := + \term$_0$} +\item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} + {\tt \{}{\tt wf \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$} Defines a recursive function by well founded recursion. \textbf{The module \texttt{Recdef} of the standard library must be loaded for this @@ -1508,21 +1528,21 @@ subgoals belonging to a Lemma {\ident}{\tt\_tcc}. % These subgoals are independe %The decreasing argument cannot be dependent of another?? %Exemples faux ici +\end{Variants} +\subsubsection{Recursive functions over co-indcutive types} - - -\subsubsection{\tt CoFixpoint {\ident} : \type$_0$ := \term$_0$. -\comindex{CoFixpoint} -\label{CoFixpoint}} - -The {\tt CoFixpoint} command introduces a method for constructing an -infinite object of a coinduc\-tive type. For example, the stream -containing all natural numbers can be introduced applying the -following method to the number \texttt{O} (see -Section~\ref{CoInductiveTypes} for the definition of {\tt Stream}, -{\tt hd} and {\tt tl}): +The command: +\begin{center} + \texttt{CoFixpoint {\ident} : \type$_0$ := \term$_0$} + \comindex{CoFixpoint}\label{CoFixpoint} +\end{center} +introduces a method for constructing an infinite object of a +coinduc\-tive type. For example, the stream containing all natural +numbers can be introduced applying the following method to the number +\texttt{O} (see Section~\ref{CoInductiveTypes} for the definition of +{\tt Stream}, {\tt hd} and {\tt tl}): \begin{coq_eval} Reset Initial. CoInductive Stream : Set := @@ -1606,9 +1626,13 @@ After a statement, {\Coq} needs a proof. \begin{Variants} \item {\tt Lemma {\ident} : {\type}.}\\ -It is a synonymous of \texttt{Theorem} -\item {\tt Remark {\ident} : {\type}.}\\ -It is a synonymous of \texttt{Theorem} + {\tt Remark {\ident} : {\type}.}\\ + {\tt Fact {\ident} : {\type}.}\\ + {\tt Corollary {\ident} : {\type}.}\\ + {\tt Proposition {\ident} : {\type}.}\\ +\comindex{Proposition} +\comindex{Corollary} +All these commands are synonymous of \texttt{Theorem} % Same as {\tt Theorem} except % that if this statement is in one or more levels of sections then the % name {\ident} will be accessible only prefixed by the sections names @@ -1616,8 +1640,6 @@ It is a synonymous of \texttt{Theorem} % closed. % %All proofs of persistent objects (such as theorems) referring to {\ident} % %within the section will be replaced by the proof of {\ident}. - \item {\tt Fact {\ident} : {\type}.}\\ -It is a synonymous of \texttt{Theorem} % Same as {\tt Remark} except % that the innermost section name is dropped from the full name. \item {\tt Definition {\ident} : {\type}.} \\ @@ -1684,4 +1706,4 @@ To be able to unfold a proof, you should end the proof by {\tt Defined} % TeX-master: "Reference-Manual" % End: -% $Id: RefMan-gal.tex 8915 2006-06-07 15:17:13Z courtieu $ +% $Id: RefMan-gal.tex 9040 2006-07-11 18:06:49Z notin $ diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex index 3c73c141..104338ea 100644 --- a/doc/refman/RefMan-ide.tex +++ b/doc/refman/RefMan-ide.tex @@ -11,9 +11,10 @@ them respectively. % CREDITS ? Proof general, lablgtk, ... \CoqIDE{} is run by typing the command \verb|coqide| on the command line. Without argument, the main screen is displayed with an ``unnamed buffer'', and with a file name as argument, another buffer displaying -the contents of that file. Additionally, coqide accepts the same -options as coqtop, given in Chapter~\ref{Addoc-coqc}, the ones having -obviously no meaning for \CoqIDE{} being ignored. +the contents of that file. Additionally, \verb|coqide| accepts the same +options as \verb|coqtop|, given in Chapter~\ref{Addoc-coqc}, the ones having +obviously no meaning for \CoqIDE{} being ignored. Additionally, \verb|coqide| accepts the option \verb|-enable-geoproof| to enable the support for \emph{GeoProof} \footnote{\emph{GeoProof} is dynamic geometry software which can be used in conjunction with \CoqIDE{} to interactively build a Coq statement corresponding to a geometric figure. More information about \emph{GeoProof} can be found here: \url{http://home.gna.org/geoproof/} }. + \begin{figure}[t] \begin{center} @@ -319,7 +320,7 @@ or -% $Id: RefMan-ide.tex 8626 2006-03-14 15:01:00Z notin $ +% $Id: RefMan-ide.tex 8945 2006-06-10 12:04:14Z jnarboux $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index de9897c4..e7400232 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -103,16 +103,23 @@ is understood as {\tt match reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ & | & {\tt match} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\ +& | & +{\tt lazymatch goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ +& | & +{\tt lazymatch reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ +& | & +{\tt lazymatch} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\ & | & {\tt abstract} {\atom}\\ & | & {\tt abstract} {\atom} {\tt using} {\ident} \\ & | & {\tt first [} \nelist{\tacexpr}{\tt |} {\tt ]}\\ & | & {\tt solve [} \nelist{\tacexpr}{\tt |} {\tt ]}\\ -& | & {\tt idtac} ~|~ {\tt idtac} {\qstring}\\ -& | & {\tt fail} ~|~ {\tt fail} {\naturalnumber} {\qstring}\\ +& | & {\tt idtac} \sequence{\messagetoken}{}\\ +& | & {\tt fail} \zeroone{\naturalnumber} \sequence{\messagetoken}{}\\ & | & {\tt fresh} ~|~ {\tt fresh} {\qstring}\\ & | & {\tt context} {\ident} {\tt [} {\term} {\tt ]}\\ & | & {\tt eval} {\nterm{redexpr}} {\tt in} {\term}\\ & | & {\tt type of} {\term}\\ +& | & {\tt external} {\qstring} {\qstring} \nelist{\tacarg}{}\\ & | & {\tt constr :} {\term}\\ & | & \atomictac\\ & | & {\qualid} \nelist{\tacarg}{}\\ @@ -122,6 +129,8 @@ is understood as {\qualid} \\ & | & ()\\ & | & {\tt (} {\tacexpr} {\tt )}\\ +\\ +{\messagetoken}\!\!\!\!\!\! & ::= & {\qstring} ~|~ {\term} ~|~ {\integer} \\ \end{tabular} \end{centerframe} \caption{Syntax of the tactic language} @@ -266,6 +275,12 @@ applied and $v_i$ is applied to the $i$-th generated subgoal by the application of $v_0$, for $=1,...,n$. It fails if the application of $v_0$ does not generate exactly $n$ subgoals. +\variant If no tactic is given for the $i$-th generated subgoal, it +behaves as if the tactic {\tt idtac} were given. For instance, {\tt +split ; [ | auto ]} is a shortcut for +{\tt split ; [ idtac | auto ]}. + + \subsubsection{For loop} \tacindex{do} \index{Tacticals!do@{\tt do}} @@ -369,10 +384,13 @@ tries to apply $v_2$ and so on. It fails if there is no solving tactic. The constant {\tt idtac} is the identity tactic: it leaves any goal unchanged but it appears in the proof script. -\begin{quote} -{\tt idtac} and {\tt idtac "message"} -\end{quote} -The latter variant prints the string on the standard output. + +\variant {\tt idtac \nelist{\messagetoken}{}} + +This prints the given tokens. Strings and integers are printed +literally. If a term is given, it is printed, its variables being +interpreted in the current environment. In particular, if a variable +is given, its value is printed. \subsubsection{Failing} @@ -381,17 +399,24 @@ The latter variant prints the string on the standard output. The tactic {\tt fail} is the always-failing tactic: it does not solve any goal. It is useful for defining other tacticals since it can be -catched by {\tt try} or {\tt match goal}. There are three variants: -\begin{quote} -{\tt fail $n$}, {\tt fail "message"} and {\tt fail $n$ "message"} -\end{quote} +catched by {\tt try} or {\tt match goal}. + +\begin{Variants} +\item {\tt fail $n$}\\ The number $n$ is the failure level. If no level is specified, it defaults to $0$. The level is used by {\tt try} and {\tt match goal}. If $0$, it makes {\tt match goal} considering the next clause (backtracking). If non zero, the current {\tt match goal} block or {\tt try} command is aborted and the level is decremented. -\ErrMsg \errindex{Tactic Failure "message" (level $n$)}. +\item {\tt fail \nelist{\messagetoken}{}}\\ +The given tokens are used for printing the failure message. + +\item {\tt fail $n$ \nelist{\messagetoken}{}}\\ +This is a combination of the previous variants. +\end{Variants} + +\ErrMsg \errindex{Tactic Failure {\it message} (level $n$)}. \subsubsection{Local definitions} \index{Ltac!let} @@ -464,10 +489,13 @@ The {\tacexpr} is evaluated and should yield a term which is matched pattern matching instantiations to the metavariables. If the matching with {\cpattern}$_1$ fails, {\cpattern}$_2$ is used and so on. The pattern {\_} matches any term and shunts all remaining patterns if -any. If {\tacexpr}$_1$ evaluates to a tactic, this tactic is not -immediately applied to the current goal (in contrast with {\tt match -goal}). If all clauses fail (in particular, there is no pattern {\_}) -then a no-matching error is raised. +any. If {\tacexpr}$_1$ evaluates to a tactic and the {\tt match} +expression is in position to be applied to a goal (e.g. it is not +bound to a variable by a {\tt let in}, then this tactic is applied. If +the tactic succeeds, the list of resulting subgoals is the result of +the {\tt match} expression. On the opposite, if it fails, the next +pattern is tried. If all clauses fail (in particular, there is no +pattern {\_}) then a no-matching error is raised. \begin{ErrMsgs} @@ -481,7 +509,8 @@ then a no-matching error is raised. \end{ErrMsgs} -\index{context!in pattern} +\begin{Variants} +\item \index{context!in pattern} There is a special form of patterns to match a subterm against the pattern: \begin{quote} @@ -493,11 +522,36 @@ is the initial term where the matched subterm is replaced by a hole. The definition of {\tt context} in expressions below will show how to use such term contexts. -This operator never makes backtracking. If there are several subterms -matching the pattern, only the first match is considered. Note that -the order of matching is left unspecified. -%% TODO: clarify this point! It *should* be specified +If the evaluation of the right-hand-side of a valid match fails, the +next matching subterm is tried. If no further subterm matches, the +next clause is tried. Matching subterms are considered top-bottom and +from left to right (with respect to the raw printing obtained by +setting option {\tt Printing All}, see section~\ref{SetPrintingAll}). + +\begin{coq_example} +Ltac f x := + match x with + context f [S ?X] => + idtac X; (* To display the evaluation order *) + assert (p := refl_equal 1 : X=1); (* To filter the case X=1 *) + let x:= context f[O] in assert (x=O) (* To observe the context *) + end. +Goal True. +f (3+4). +\end{coq_example} + +\item \index{lazymatch!in Ltac} +\index{Ltac!lazymatch} +Using {\tt lazymatch} instead of {\tt match} has an effect if the +right-hand-side of a clause returns a tactic. With {\tt match}, the +tactic is applied to the current goal (and the next clause is tried if +it fails). With {\tt lazymatch}, the tactic is directly returned as +the result of the whole {\tt lazymatch} block without being first +tried to be applied to the goal. Typically, if the {\tt lazymatch} +block is bound to some variable $x$ in a {\tt let in}, then tactic +expression gets bound to the variable $x$. +\end{Variants} \subsubsection{Pattern matching on goals} \index{Ltac!match goal} @@ -521,8 +575,6 @@ We can make pattern matching on goals using the following expression: \end{tabbing} \end{quote} -% TODO: specify order of hypothesis and explain reverse... - If each hypothesis pattern $hyp_{1,i}$, with $i=1,...,m_1$ is matched (non-linear first order unification) by an hypothesis of the goal and if {\cpattern}$_1$ is matched by the conclusion of the @@ -535,7 +587,9 @@ hypotheses is tried with the same proof context pattern. If there is no other combination of hypotheses then the second proof context pattern is tried and so on. If the next to last proof context pattern fails then {\tacexpr}$_{n+1}$ is evaluated to $v_{n+1}$ and $v_{n+1}$ -is applied. +is applied. Note also that matching against subterms (using the {\tt +context} {\ident} {\tt [} {\cpattern} {\tt ]}) is available and may +itself induce extra backtrackings. \ErrMsg \errindex{No matching clauses for match goal} @@ -552,6 +606,36 @@ pattern, the goal hypothesis are matched in order (fresher hypothesis first), but it possible to reverse this order (older first) with the {\tt match reverse goal with} variant. +\variant +\index{lazymatch goal!in Ltac} +\index{Ltac!lazymatch goal} +\index{lazymatch reverse goal!in Ltac} +\index{Ltac!lazymatch reverse goal} +Using {\tt lazymatch} instead of {\tt match} has an effect if the +right-hand-side of a clause returns a tactic. With {\tt match}, the +tactic is applied to the current goal (and the next clause is tried if +it fails). With {\tt lazymatch}, the tactic is directly returned as +the result of the whole {\tt lazymatch} block without being first +tried to be applied to the goal. Typically, if the {\tt lazymatch} +block is bound to some variable $x$ in a {\tt let in}, then tactic +expression gets bound to the variable $x$. + +\begin{coq_example} +Ltac test_lazy := + lazymatch goal with + | _ => idtac "here"; fail + | _ => idtac "wasn't lazy"; trivial + end. +Ltac test_eager := + match goal with + | _ => idtac "here"; fail + | _ => idtac "wasn't lazy"; trivial + end. +Goal True. +test_lazy || idtac "was lazy". +test_eager || idtac "was lazy". +\end{coq_example} + \subsubsection{Filling a term context} \index{context!in expression} @@ -585,13 +669,6 @@ It evaluates to an identifier unbound in the goal, which is obtained by padding {\qstring} with a number if necessary. If no name is given, the prefix is {\tt H}. -\subsubsection{{\tt type of} {\term}} -%\tacindex{type of} -\index{Ltac!type of} -\index{type of!in Ltac} - -This tactic computes the type of {\term}. - \subsubsection{Computing in a constr} \index{Ltac!eval} \index{eval!in Ltac} @@ -604,6 +681,16 @@ where \nterm{redexpr} is a reduction tactic among {\tt red}, {\tt hnf}, {\tt compute}, {\tt simpl}, {\tt cbv}, {\tt lazy}, {\tt unfold}, {\tt fold}, {\tt pattern}. +\subsubsection{Type-checking a term} +%\tacindex{type of} +\index{Ltac!type of} +\index{type of!in Ltac} + +The following returns the type of {\term}: + +\begin{quote} +{\tt type of} {\term} +\end{quote} \subsubsection{Accessing tactic decomposition} \tacindex{info} @@ -635,10 +722,76 @@ without having to cut manually the proof in smaller lemmas. \ErrMsg \errindex{Proof is not complete} +\subsubsection{Calling an external tactic} +\index{Ltac!external} + +The tactic {\tt external} allows to run an executable outside the +{\Coq} executable. The communication is done via an XML encoding of +constructions. The syntax of the command is + +\begin{quote} +{\tt external} "\textsl{command}" "\textsl{request}" \nelist{\tacarg}{} +\end{quote} + +The string \textsl{command}, to be interpreted in the default +execution path of the operating system, is the name of the external +command. The string \textsl{request} is the name of a request to be +sent to the external command. Finally the list of tactic arguments +have to evaluate to terms. An XML tree of the following form is sent +to the standard input of the external command. +\medskip + +\begin{tabular}{l} +\texttt{<REQUEST req="}\textsl{request}\texttt{">}\\ +the XML tree of the first argument\\ +{\ldots}\\ +the XML tree of the last argument\\ +\texttt{</REQUEST>}\\ +\end{tabular} +\medskip + +Conversely, the external command must send on its standard output an +XML tree of the following forms: + +\medskip +\begin{tabular}{l} +\texttt{<TERM>}\\ +the XML tree of a term\\ +\texttt{</TERM>}\\ +\end{tabular} +\medskip + +\noindent or + +\medskip +\begin{tabular}{l} +\texttt{<CALL uri="}\textsl{ltac\_qualified\_ident}\texttt{">}\\ +the XML tree of a first argument\\ +{\ldots}\\ +the XML tree of a last argument\\ +\texttt{</CALL>}\\ +\end{tabular} + +\medskip +\noindent where \textsl{ltac\_qualified\_ident} is the name of a +defined {\ltac} function and each subsequent XML tree is recursively a +\texttt{CALL} or a \texttt{TERM} node. + +The Document Type Definition (DTD) for terms of the Calculus of +Inductive Constructions is the one developed as part of the MoWGLI +European project. It can be found in the file {\tt dev/doc/cic.dtd} of +the {\Coq} source archive. + +An example of parser for this DTD, written in the Objective Caml - +Camlp4 language, can be found in the file {\tt parsing/g\_xml.ml4} of +the {\Coq} source archive. + \section{Tactic toplevel definitions} \comindex{Ltac} -Basically, tactics toplevel definitions are made as follows: +\subsection{Defining {\ltac} functions} + +Basically, {\ltac} toplevel definitions are made as follows: %{\tt Tactic Definition} {\ident} {\tt :=} {\tacexpr}\\ % %{\tacexpr} is evaluated to $v$ and $v$ is associated to {\ident}. Next, every @@ -649,8 +802,8 @@ Basically, tactics toplevel definitions are made as follows: {\tt Ltac} {\ident} {\ident}$_1$ ... {\ident}$_n$ {\tt :=} {\tacexpr} \end{quote} -This defines a new tactic that can be used in any tactic script or new -tactic toplevel definition. +This defines a new {\ltac} function that can be used in any tactic +script or new {\ltac} toplevel definition. \Rem The preceding definition can equivalently be written: \begin{quote} @@ -674,8 +827,49 @@ possible with the syntax: %usual except that the substitutions are lazily carried out (when an identifier %to be evaluated is the name of a recursive definition). -\endinput +\subsection{Printing {\ltac} tactics} +\comindex{Print Ltac} + +Defined {\ltac} functions can be displayed using the command + +\begin{quote} +{\tt Print Ltac {\qualid}.} +\end{quote} + +\section{Debugging {\ltac} tactics} +\comindex{Set Ltac Debug} +\comindex{Unset Ltac Debug} +\comindex{Test Ltac Debug} + +The {\ltac} interpreter comes with a step-by-step debugger. The +debugger can be activated using the command + +\begin{quote} +{\tt Set Ltac Debug.} +\end{quote} + +\noindent and deactivated using the command + +\begin{quote} +{\tt Unset Ltac Debug.} +\end{quote} + +To know if the debugger is on, use the command \texttt{Test Ltac Debug}. +When the debugger is activated, it stops at every step of the +evaluation of the current {\ltac} expression and it prints information +on what it is doing. The debugger stops, prompting for a command which +can be one of the following: + +\medskip +\begin{tabular}{ll} +simple newline: & go to the next step\\ +h: & get help\\ +x: & exit current evaluation\\ +s: & continue current evaluation without stopping\\ +r$n$: & advance $n$ steps further\\ +\end{tabular} +\endinput \subsection{Permutation on closed lists} diff --git a/doc/refman/RefMan-mod.tex b/doc/refman/RefMan-mod.tex index 9f6f2abc..44a88034 100644 --- a/doc/refman/RefMan-mod.tex +++ b/doc/refman/RefMan-mod.tex @@ -55,6 +55,11 @@ This command is used to start an interactive module named {\ident}. {\modbindings}. The output module type is verified against the module type {\modtype}. +\item\texttt{Module [Import|Export]} + + Behaves like \texttt{Module}, but automatically imports or exports + the module. + \end{Variants} \subsection{\tt End {\ident} @@ -139,38 +144,9 @@ Defines a module type {\ident} equal to {\modtype}. {\modbindings} and returning {\modtype}. \end{Variants} -\subsection{\tt Declare Module {\ident}} - -Starts an interactive module declaration. This command is available -only in module types. - -\begin{Variants} - -\item{\tt Declare Module {\ident} {\modbindings}} - - Starts an interactive declaration of a functor with parameters given - by {\modbindings}. - -% Particular case of the next item -%\item{\tt Declare Module {\ident} \verb.<:. {\modtype}} -% -% Starts an interactive declaration of a module satisfying {\modtype}. - -\item{\tt Declare Module {\ident} {\modbindings} \verb.<:. {\modtype}} - - Starts an interactive declaration of a functor with parameters given - by {\modbindings} (possibly none). The declared output module type is - verified against the module type {\modtype}. - -\end{Variants} - -\subsection{\tt End {\ident}} - -This command closes the interactive declaration of module {\ident}. - \subsection{\tt Declare Module {\ident} : {\modtype}} -Declares a module of {\ident} of type {\modtype}. This command is available +Declares a module {\ident} of type {\modtype}. This command is available only in module types. \begin{Variants} @@ -189,6 +165,11 @@ only in module types. Declares a module equal to the module {\qualid}, verifying that the module type of the latter is a subtype of {\modtype}. +\item\texttt{Declare Module [Import|Export] {\ident} := {\qualid}} + + Declares a modules {\ident} of type {\modtype}, and imports or + exports it directly. + \end{Variants} @@ -389,6 +370,11 @@ Prints the module type and (optionally) the body of the module {\ident}. Prints the module type corresponding to {\ident}. +\subsection{\texttt{Locate Module {\qualid}} +\comindex{Locate Module}} + +Prints the full name of the module {\qualid}. + %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index e92cde74..1d2057a9 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -334,6 +334,72 @@ Locate I.Dont.Exist. \SeeAlso Section \ref{LocateSymbol} +\subsection{The {\sc Whelp} searching tool +\label{Whelp}} + +{\sc Whelp} is an experimental searching and browsing tool for the +whole {\Coq} library and the whole set of {\Coq} user contributions. +{\sc Whelp} requires a browser to work. {\sc Whelp} has been developed +at the University of Bologna as part of the HELM\footnote{Hypertextual +Electronic Library of Mathematics} and MoWGLI\footnote{Mathematics on +the Web, Get it by Logics and Interfaces} projects. It can be invoked +directly from the {\Coq} toplevel or from {\CoqIDE}, assuming a +graphical environment is also running. The browser to use can be +selected by setting the environment variable {\tt +COQREMOTEBROWSER}. If not explicitly set, it defaults to +\verb!netscape -remote "OpenURL(%s)"! or +\verb!C:\\PROGRA~1\\INTERN~1\\IEXPLORE %s!, depending on the +underlying operating system (in the command, the string \verb!%s! +serves as metavariable for the url to open). + +The {\sc Whelp} commands are: + +\subsubsection{\tt Whelp Locate "{\sl reg\_expr}". +\comindex{Whelp Locate}} + +This command opens a browser window and displays the result of seeking +for all names that match the regular expression {\sl reg\_expr} in the +{\Coq} library and user contributions. The regular expression can +contain the special operators are * and ? that respectively stand for +an arbitrary substring and for exactly one character. + +\variant {\tt Whelp Locate {\ident}.}\\ +This is equivalent to {\tt Whelp Locate "{\ident}"}. + +\subsubsection{\tt Whelp Match {\pattern}. +\comindex{Whelp Match}} + +This command opens a browser window and displays the result of seeking +for all statements that match the pattern {\pattern}. Holes in the +pattern are represented by the wildcard character ``\_''. + +\subsubsection{\tt Whelp Instance {\pattern}.} +\comindex{Whelp Instance} + +This command opens a browser window and displays the result of seeking +for all statements that are instances of the pattern {\pattern}. The +pattern is here assumed to be an universally quantified expression. + +\subsubsection{\tt Whelp Elim {\qualid}.} +\comindex{Whelp Elim} + +This command opens a browser window and displays the result of seeking +for all statements that have the ``form'' of an elimination scheme +over the type denoted by {\qualid}. + +\subsubsection{\tt Whelp Hint {\term}.} +\comindex{Whelp Hint} + +This command opens a browser window and displays the result of seeking +for all statements that can be instantiated so that to prove the +statement {\term}. + +\variant {\tt Whelp Hint.}\\ This is equivalent to {\tt Whelp Hint +{\sl goal}} where {\sl goal} is the current goal to prove. Notice that +{\Coq} does not send the local environment of definitions to the {\sc +Whelp} tool so that it only works on requests strictly based on, only, +definitions of the standard library and user contributions. + \section{Loading files} \Coq\ offers the possibility of loading different @@ -765,7 +831,39 @@ This command displays the current nesting depth used for display. %\subsection{\tt Abstraction ...} %Not yet documented. -% $Id: RefMan-oth.tex 8606 2006-02-23 13:58:10Z herbelin $ +\section{Controlling the conversion algorithm} + +{\Coq} comes with two algorithms to check the convertibility of types +(see section~\ref{convertibility}). The first algorithm lazily +compares applicative terms while the other is a brute-force but efficient +algorithm that first normalizes the terms before comparing them. The +second algorithm is based on a bytecode representation of terms +similar to the bytecode representation used in the ZINC virtual +machine~\cite{Leroy90}. It is specially useful for intensive +computation of algebraic values, such as numbers, and for reflexion-based +tactics. + +\subsection{\tt Set Virtual Machine +\label{SetVirtualMachine} +\comindex{Set Virtual Machine}} + +This activates the bytecode-based conversion algorithm. + +\subsection{\tt Unset Virtual Machine +\comindex{Unset Virtual Machine}} + +This deactivates the bytecode-based conversion algorithm. + +\subsection{\tt Test Virtual Machine +\comindex{Test Virtual Machine}} + +This tells if the bytecode-based conversion algorithm is +activated. The default behavior is to have the bytecode-based +conversion algorithm deactivated. + +\SeeAlso sections~\ref{vmcompute} and~\ref{vmoption}. + +% $Id: RefMan-oth.tex 9044 2006-07-12 13:22:17Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index 2f79e5f0..43216ed0 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -556,19 +556,19 @@ unresolved implicit has been implemented by Hugo Herbelin. Laurent Théry's contribution on strings and Pierre Letouzey and Jean-Christophe Filliâtre's contribution on finite maps have been integrated to the {\Coq} standard library. Pierre Letouzey developed a -library about finite sets ``à la Objective Caml'' and extended the -lists library. Pierre Letouzey's contribution on rational numbers -has been integrated too. +library about finite sets ``à la Objective Caml''. With Jean-Marc +Notin, he extended the library on lists. Pierre Letouzey's +contribution on rational numbers has been integrated and extended.. Pierre Corbineau extended his tactic for solving first-order -statements. He wrote a reflexion-based intuitionistic tautology +statements. He wrote a reflection-based intuitionistic tautology solver. -Jean-Marc Notin took care of {\textsf{coqdoc}} and of the general -maintenance of the system. +Jean-Marc Notin significantly contributed to the general maintenance +of the system. He also took care of {\textsf{coqdoc}}. \begin{flushright} -Palaiseau, Apr. 2006\\ +Palaiseau, July 2006\\ Hugo Herbelin \end{flushright} @@ -577,7 +577,7 @@ Hugo Herbelin % Integration of ZArith lemmas from Sophia and Nijmegen. -% $Id: RefMan-pre.tex 8941 2006-06-09 16:43:42Z herbelin $ +% $Id: RefMan-pre.tex 9030 2006-07-07 15:37:23Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 739ca6b5..8c1a7824 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -163,28 +163,21 @@ as a {\tt Theorem}, the name {\ident} is known at all section levels: current section. \end{Variants} -\subsection{\tt Proof {\term}.}\comindex{Proof} +\subsection{\tt Proof {\term}.} +\comindex{Proof} +\label{BeginProof} This command applies in proof editing mode. It is equivalent to {\tt exact {\term}; Save.} That is, you have to give the full proof in one gulp, as a proof term (see section \ref{exact}). -\begin{Variants} - -\item{\tt Proof.} +\variant {\tt Proof.} Is a noop which is useful to delimit the sequence of tactic commands which start a proof, after a {\tt Theorem} command. It is a good practice to use {\tt Proof.} as an opening parenthesis, closed in the script with a closing {\tt Qed.} -\item{\tt Proof with {\tac}.} - - This command may be used to start a proof. It defines a default - tactic to be used each time a tactic command is ended by - ``\verb#...#''. In this case the tactic command typed by the user is - equivalent to \emph{command};{\tac}. - -\end{Variants} +\SeeAlso {\tt Proof with {\tac}.} in section~\ref{ProofWith}. \subsection{\tt Abort.} \comindex{Abort} @@ -381,7 +374,7 @@ All the hypotheses remains usable in the proof development. This command goes back to the default mode which is to print all available hypotheses. -% $Id: RefMan-pro.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $ +% $Id: RefMan-pro.tex 9030 2006-07-07 15:37:23Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 341e766e..e41983dc 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -221,6 +221,14 @@ The command to display the current state of the {\Coq} term parser is \tt Print Grammar constr. \end{quote} +\variant + +\comindex{Print Grammar pattern} +{\tt Print Grammar pattern.}\\ + +This displays the state of the subparser of patterns (the parser +used in the grammar of the {\tt match} {\tt with} constructions). + \subsection{Displaying symbolic notations} The command \texttt{Notation} has an effect both on the {\Coq} parser and @@ -436,9 +444,10 @@ Locate "'exists' _ , _". \SeeAlso Section \ref{Locate}. \begin{figure} +\begin{small} \begin{centerframe} \begin{tabular}{lcl} -{\sentence} & ::= & +{\sentence} & ::= & \texttt{Notation} \zeroone{\tt Local} {\str} \texttt{:=} {\term} \zeroone{\modifiers} \zeroone{:{\scope}} .\\ & $|$ & @@ -474,6 +483,7 @@ Locate "'exists' _ , _". & $|$ & {\tt format} {\str} \end{tabular} \end{centerframe} +\end{small} \caption{Syntax of the variants of {\tt Notation}} \label{notation-syntax} \end{figure} @@ -633,7 +643,8 @@ instance the infix symbol \verb=+= can be used to denote distinct definitions of an additive operator. Depending on which interpretation scopes is currently open, the interpretation is different. Interpretation scopes can include an interpretation for -numerals. However, this is only made possible at the {\ocaml} level. +numerals and strings. However, this is only made possible at the +{\ocaml} level. See Figure \ref{notation-syntax} for the syntax of notations including the possibility to declare them in a given scope. Here is a typical @@ -824,6 +835,21 @@ type {\tt positive} (binary strictly positive numbers). It is delimited by key {\tt positive} and comes with an interpretation for numerals as closed term of type {\tt positive}. +\subsubsection{\tt Q\_scope} + +This includes the standard arithmetical operators and relations on +type {\tt Q} (rational numbers defined as fractions of an integer and +a strictly positive integer modulo the equality of the +numerator-denominator cross-product). As for numerals, only $0$ and +$1$ have an interpretation in scope {\tt Q\_scope} (their +interpretations are $\frac{0}{1}$ and $\frac{1}{1}$ respectively). + +\subsubsection{\tt Qc\_scope} + +This includes the standard arithmetical operators and relations on the +type {\tt Qc} of rational numbers defined as the type of irreducible +fractions of an integer and a strictly positive integer. + \subsubsection{\tt real\_scope} This includes the standard arithmetical operators and relations on @@ -853,6 +879,25 @@ delimited by key {\tt list}. This includes the notation for pairs. It is delimited by key {\tt core}. +\subsubsection{\tt string\_scope} + +This includes notation for strings as elements of the type {\tt +string}. Special characters and escaping follow {\Coq} conventions +on strings (see page~\pageref{strings}). Especially, there is no +convention to visualize non printable characters of a string. The +file {\tt String.v} shows an example that contains quotes, a newline +and a beep (i.e. the ascii character of code 7). + +\subsubsection{\tt char\_scope} + +This includes interpretation for all strings of the form +\verb!"!$c$\verb!"! where $c$ is an ascii character, or of the form +\verb!"!$nnn$\verb!"! where $nnn$ is a three-digits number (possibly +with leading 0's), or of the form \verb!""""!. Their respective +denotations are the ascii code of $c$, the decimal ascii code $nnn$, +or the ascii code of the character \verb!"! (i.e. the ascii code +34), all of them being represented in the type {\tt ascii}. + \subsection{Displaying informations about scopes} \subsubsection{\tt Print Visibility} @@ -948,11 +993,14 @@ tactic language\footnote{Tactic notations are just a simplification of the {\tt Grammar tactic simple\_tactic} command that existed in versions prior to version 8.0.}. Tactic notations obey the following syntax +\medskip +\noindent \begin{tabular}{lcl} -{\sentence} & ::= & \texttt{Tactic Notation} {\str} \sequence{\proditem}{} \\ +{\sentence} & ::= & \texttt{Tactic Notation} {\taclevel} \sequence{\proditem}{} \\ & & \texttt{:= {\tac} .}\\ {\proditem} & ::= & {\str} $|$ {\tacargtype}{\tt ({\ident})} \\ +{\taclevel} & ::= & $|$ {\tt (at level} {\naturalnumber}{\tt )} \\ {\tacargtype} & ::= & %{\tt preident} $|$ {\tt ident} $|$ @@ -966,14 +1014,18 @@ syntax {\tt int\_or\_var} $|$ {\tt tactic} $|$ \end{tabular} +\medskip -A tactic notation {\tt Tactic Notation {\str} {\sequence{\proditem}{}} -:= {\tac}} extends the parser and pretty-printer of tactics with a -new rule made of the juxtaposition of the head name of the tactic -{\str} and the list of its production items (in the syntax of -production items, {\str} stands for a terminal symbol and {\tt -\tacargtype({\ident}) for non terminal entries}. It then evaluates -into the tactic expression {\tac}. +A tactic notation {\tt Tactic Notation {\taclevel} +{\sequence{\proditem}{}} := {\tac}} extends the parser and +pretty-printer of tactics with a new rule made of the list of +production items. It then evaluates into the tactic expression +{\tac}. For simple tactics, it is recommended to use a terminal +symbol, i.e. a {\str}, for the first production item. The tactic +level indicates the parsing precedence of the tactic notation. This +information is particularly relevant for notations of tacticals. +Levels 0 to 5 are available. To know the parsing precedences of the +existing tacticals, use the command {\tt Print Grammar tactic.} Each type of tactic argument has a specific semantic regarding how it is parsed and how it is interpreted. The semantic is described in the @@ -1008,7 +1060,7 @@ for {\tt integer}. This is the reason for introducing a special entry syntactically includes identifiers in order to be usable in tactic definitions. -% $Id: RefMan-syn.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $ +% $Id: RefMan-syn.tex 9012 2006-07-05 16:03:16Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index f034df41..24699873 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -69,6 +69,13 @@ convertible (see Section~\ref{conv-rules}). \item \errindex{Not an exact proof} \end{ErrMsgs} +\begin{Variants} + \item \texttt{eexact \term}\tacindex{eexact} + + This tactic behaves like \texttt{exact} but is able to handle terms with meta-variables. + +\end{Variants} + \subsection{\tt refine \term \tacindex{refine} @@ -112,6 +119,15 @@ subgoal is proved. Otherwise, it fails. \item \errindex{No such assumption} \end{ErrMsgs} +\begin{Variants} + \item \texttt{eassumption} + + This tactic behaves like \texttt{assumption} but is able to handle + goals with meta-variables. + +\end{Variants} + + \subsection{\tt clear {\ident} \tacindex{clear} \label{clear}} @@ -133,6 +149,10 @@ usable in the proof development. its body. Otherwise said, this tactic turns a definition into an assumption. +\item \texttt{clear - {\ident}.} + + This tactic clears all hypotheses except the ones depending in {\ident}. + \end{Variants} \begin{ErrMsgs} @@ -506,6 +526,20 @@ in the list of subgoals remaining to prove. following subgoals: {\tt U -> T} and \texttt{U}. The subgoal {\tt U -> T} comes first in the list of remaining subgoal to prove. +\item \texttt{assert {\form} by {\tac}}\tacindex{assert by} + + This tactic behaves like \texttt{assert} but tries to apply {\tac} + to any subgoals generated by \texttt{assert}. + +\item \texttt{assert {\form} as {\ident}\tacindex{assert as}} + + This tactic behaves like \texttt{assert ({\ident} : {\form})}. + +\item \texttt{pose proof {\term} as {\ident}} + + This tactic behaves like \texttt{assert ({\ident:T} by exact {\term}} where + \texttt{T} is the type of {\term}. + \end{Variants} % PAS CLAIR; @@ -721,6 +755,7 @@ performs the conversion in hypotheses $H_1\ldots H_n$. \tacindex{cbv} \tacindex{lazy} \tacindex{compute}} +\label{vmcompute} These parameterized reduction tactics apply to any goal and perform the normalization of the goal according to the specified flags. Since @@ -764,6 +799,16 @@ computational expressions (i.e. with few dead code). \item {\tt compute} \tacindex{compute} This tactic is an alias for {\tt cbv beta delta evar iota zeta}. + +\item {\tt vm\_compute} \tacindex{vm\_compute} + + This tactic evaluates the goal using the optimized call-by-value + evaluation bytecode-based virtual machine. This algorithm is + dramatically more efficient than the algorithm used for the {\tt + cbv} tactic, but it cannot be fine-tuned. It is specially + interesting for full evaluation of algebraic objects. This includes + the case of reflexion-based tactics. + \end{Variants} \begin{ErrMsgs} @@ -1012,6 +1057,14 @@ equivalent to {\tt intros; apply ci}. these expressions are equivalent to the corresponding {\tt constructor $i$ with \bindinglist}. +\item \texttt{econstructor} + + This tactic behaves like \texttt{constructor} but is able to + introduce existential variables if an instanciation for a variable + cannot be found (cf \texttt{eapply}). The tactics \texttt{eexists}, + \texttt{esplit}, \texttt{eleft} and \texttt{eright} follows the same + behaviour. + \end{Variants} \section{Eliminations (Induction and Case Analysis)} @@ -1096,6 +1149,11 @@ induction n. scheme of name {\qualid}. It does not expect that the type of {\term} is inductive. +\item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}} + + where {\qualid} is an induction principle with complex predicates + (like the ones generated by function induction). + \item {\tt induction {\term} using {\qualid} as {\intropattern}} This combines {\tt induction {\term} using {\qualid}} @@ -1233,6 +1291,10 @@ last introduced hypothesis. {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of {\tt [} $p_{1} $\ldots $p_{n}$ {\tt ]}. +\item \texttt{pose proof {\term} as {\intropattern}} + + This tactic behaves like \texttt{destruct {\term} as {\intropattern}}. + \item{\tt destruct {\term} using {\qualid}} This is a synonym of {\tt induction {\term} using {\qualid}}. @@ -1279,6 +1341,7 @@ components of an hypothesis. An introduction pattern is either: \begin{itemize} \item the wildcard: {\tt \_} +\item the pattern \texttt{?} \item a variable \item a disjunction of lists of patterns: {\tt [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} $p_{nm_n}$]} @@ -1290,6 +1353,8 @@ structure of the pattern given as argument: \begin{itemize} \item introduction on the wildcard do the introduction and then immediately clear (cf~\ref{clear}) the corresponding hypothesis; +\item introduction on \texttt{?} do the introduction, and let Coq + choose a fresh name for the variable; \item introduction on a variable behaves like described in~\ref{intro}; \item introduction over a list of patterns $p_1~\ldots~p_n$ is equivalent to the sequence of @@ -1323,7 +1388,8 @@ inductive type with a single constructor. Lemma intros_test : forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. intros A B C [a| [_ c]] f. apply (f a). -Proof c. +exact c. +Qed. \end{coq_example} %\subsection{\tt FixPoint \dots}\tacindex{Fixpoint} @@ -1479,7 +1545,10 @@ implicit type of $t$ and $u$. This tactic applies to any goal. The type of {\term} must have the form -\texttt{(x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\term$_1${\tt =}\term$_2$. +\texttt{(x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq}\term$_1$ \term$_2$. + +\noindent where \texttt{eq} is the Leibniz equality or a registered +setoid equality. \noindent Then {\tt rewrite \term} replaces every occurrence of \term$_1$ by \term$_2$ in the goal. Some of the variables x$_1$ are @@ -1506,10 +1575,14 @@ This happens if \term$_1$ does not occur in the goal. \item {\tt rewrite <- {\term}}\tacindex{rewrite <-}\\ Uses the equality \term$_1${\tt=}\term$_2$ from right to left -\item {\tt rewrite {\term} in {\ident}} +\item {\tt rewrite {\term} in \textit{clause}} \tacindex{rewrite \dots\ in}\\ - Analogous to {\tt rewrite {\term}} but rewriting is done in the - hypothesis named {\ident}. + Analogous to {\tt rewrite {\term}} but rewriting is done following + \textit{clause} (similarly to \ref{Conversion-tactics}). For instance: + \texttt{rewrite H in H1,H2 |- *} means \texttt{rewrite H in H1; + rewrite H in H2; rewrite H} and \texttt{rewrite H in * |-} will do + \texttt{try rewrite H in H$_i$} for all hypothesis \texttt{H$_i$ <> + H}. \item {\tt rewrite -> {\term} in {\ident}} \tacindex{rewrite -> \dots\ in}\\ @@ -1540,17 +1613,26 @@ symmetric form occurs. It is equivalent to {\tt cut \term$_2$=\term$_1$; [intro H{\sl n}; rewrite <- H{\sl n}; clear H{\sl n}| assumption || symmetry; try assumption]}. +\begin{ErrMsgs} +\item \errindex{terms do not have convertible types} +\end{ErrMsgs} + \begin{Variants} \item {\tt replace {\term$_1$} with {\term$_2$} in \ident}\\ This replaces {\term$_1$} with {\term$_2$} in the hypothesis named {\ident}, and generates the subgoal {\term$_2$}{\tt =}{\term$_1$}. - \begin{ErrMsgs} - \item \errindex{No such hypothesis} : {\ident} - \item \errindex{Nothing to rewrite in {\ident}} - \end{ErrMsgs} +% \begin{ErrMsgs} +% \item \errindex{No such hypothesis} : {\ident} +% \item \errindex{Nothing to rewrite in {\ident}} +% \end{ErrMsgs} +\item {\tt replace {\term$_1$} with {\term$_2$} by \tac}\\ This acts as + {\tt replace {\term$_1$} with {\term$_2$}} but try to solve the + generated subgoal {\tt \term$_2$=\term$_1$} using {\tt \tac}. +\item {\tt replace {\term$_1$} with {\term$_2$} in \ident by \tac}\\ + This acts as {\tt replace {\term$_1$} with {\term$_2$} in \ident} but try to solve the generated subgoal {\tt \term$_2$=\term$_1$} using {\tt \tac}. \end{Variants} \subsection{\tt reflexivity @@ -1617,12 +1699,12 @@ goal stating ``$eq$ {\term} {\term}$_1$''. Lemmas are added to the database using the command \comindex{Declare Left Step} \begin{quote} -{\tt Declare Left Step {\qualid}.} +{\tt Declare Left Step {\term}.} \end{quote} -where {\qualid} is the name of the lemma. The tactic is especially useful for parametric setoids which are not -accepted as regular setoids for {\tt rewrite} and {\tt setoid\_replace} (see chapter \ref{setoid_replace}). +accepted as regular setoids for {\tt rewrite} and {\tt + setoid\_replace} (see chapter \ref{setoid_replace}). \tacindex{stepr} \comindex{Declare Right Step} @@ -1638,7 +1720,7 @@ Lemmas are expected to be of the form $z$, $R$ $x$ $y$ {\tt ->} $eq$ $y$ $z$ {\tt ->} $R$ $x$ $z$'' and are registered using the command \begin{quote} -{\tt Declare Right Step {\qualid}.} +{\tt Declare Right Step {\term}.} \end{quote} \end{Variants} @@ -2157,6 +2239,11 @@ hints of the database named {\tt core}. Uses all existing hint databases, minus the special database {\tt v62}. See Section~\ref{Hints-databases} +\item \texttt{auto using $lemma_1, \ldots, lemma_n$} + + Uses $lemma_1, \ldots, lemma_n$ in addition to hints (can be conbined + with the \texttt{with \ident} option). + \item {\tt trivial}\tacindex{trivial} This tactic is a restriction of {\tt auto} that is not recursive and @@ -2306,6 +2393,15 @@ incompatibilities. % En attente d'un moyen de valoriser les fichiers de demos %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_tauto.v} + +\subsection{\tt rtauto +\tacindex{rtauto} +\label{rtauto}} + +The {\tt rtauto} tactic solves propositional tautologies similarly to what {\tt tauto} does. The main difference is that the proof term is built using a reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. + +Users should be aware that this difference may result in faster proof-search but slower proof-checking, and {\tt rtauto} might not solve goals that {\tt tauto} would be able to solve (e.g. goals involving universal quantifiers). + \subsection{{\tt firstorder} \tacindex{firstorder} \label{firstorder}} @@ -2459,7 +2555,7 @@ equalities with uninterpreted symbols. It also include the constructor theory (see \ref{injection} and \ref{discriminate}). If the goal is a non-quantified equality, {\tt congruence} tries to prove it with non-quantified equalities in the context. Otherwise it -tries to infer a discriminable equality from those in the context. +tries to infer a discriminable equality from those in the context. Alternatively, congruence tries to prove that an hypothesis is equal to the goal or to the negation of another hypothesis. \begin{coq_eval} Reset Initial. @@ -2489,14 +2585,28 @@ intros. congruence. \end{coq_example} +\begin{Variants} +\item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\ + Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by + {\tt congruence}. This helps in case you have partially applied + constructors in your goal. +\end{Variants} + \begin{ErrMsgs} \item \errindex{I don't know how to handle dependent equality} \\ The decision procedure managed to find a proof of the goal or of a discriminable equality but this proof couldn't be built in Coq because of dependently-typed functions. \item \errindex{I couldn't solve goal} \\ - The decision procedure didn't managed to find a proof of the goal or of - a discriminable equality. + The decision procedure didn't find any way to solve the goal. + \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\ + The decision procedure could solve the goal with the provision + that additional arguments are supplied for some partially applied + constructors. Any term of an appropriate type will allow the + tactic to successfully solve the goal. Those additional arguments + can be given to {\tt congruence} by filling in the holes in the + terms given in the error message, using the {\tt with} variant + described below. \end{ErrMsgs} \subsection{\tt omega @@ -2679,7 +2789,7 @@ of the reengineering of the code, this tactic has also been completely revised to get a very compact and readable version.} carries out rewritings according the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}. - Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until +Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until it fails. Once all the rules have been processed, if the main subgoal has progressed (e.g., if it is distinct from the initial main goal) then the rules of this base are processed again. If the main subgoal has not progressed then @@ -2695,58 +2805,24 @@ command. \item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\ Performs, in the same way, all the rewritings of the bases {\tt $ident_1$ $...$ $ident_n$} applying {\tt \tac} to the main subgoal after each rewriting step. -%\item{\tt autorewrite [ \ident$_1$ \dots \ident$_n$ ]}\\ -%{\tt autorewrite [ \ident$_1$ \dots \ident$_n$ ] using \tac}\\ -%These are deprecated syntactic variants for -%{\tt autorewrite with \ident$_1$ \dots \ident$_n$} -%and -%{\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}. -\end{Variant} -\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident -\comindex{Hint Rewrite}} +\item \texttt{autorewrite with {\ident} in {\qualid}} -This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} -(their types must be equalities) in the rewriting base {\tt \ident} -with the default orientation (left to right). Notice that the -rewriting bases are distinct from the {\tt auto} hint bases and that -{\tt auto} does not take them into account. - -This command is synchronous with the section mechanism (see \ref{Section}): -when closing a section, all aliases created by \texttt{Hint Rewrite} in that -section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} -declarations at the global level of that module are loaded. - -\begin{Variants} -\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ -This is strictly equivalent to the command above (we only make explicit the -orientation which otherwise defaults to {\tt ->}). - -\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ -Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left -orientation in the base {\tt \ident}. + Performs all the rewritings in hypothesis {\qualid}. -\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ -When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will -be used, the tactic {\tt \tac} will be applied to the generated subgoals, the -main subgoal excluded. - -%% \item -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ -%% These are deprecated syntactic variants for -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. +\end{Variant} -\end{Variants} +\SeeAlso section \ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}. -\SeeAlso \ref{autorewrite-example} for examples showing the use of +\SeeAlso section \ref{autorewrite-example} for examples showing the use of this tactic. % En attente d'un moyen de valoriser les fichiers de demos %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} -\section{The hints databases for {\tt auto} and {\tt eauto} +\section{Controlling automation} + +\subsection{The hints databases for {\tt auto} and {\tt eauto} \index{Hints databases} \label{Hints-databases} \comindex{Hint}} @@ -3036,6 +3112,47 @@ every moment. \end{Variants} +\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident +\label{HintRewrite} +\comindex{Hint Rewrite}} + +This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} +(their types must be equalities) in the rewriting base {\tt \ident} +with the default orientation (left to right). Notice that the +rewriting bases are distinct from the {\tt auto} hint bases and that +{\tt auto} does not take them into account. + +This command is synchronous with the section mechanism (see \ref{Section}): +when closing a section, all aliases created by \texttt{Hint Rewrite} in that +section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} +declarations at the global level of that module are loaded. + +\begin{Variants} +\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ +This is strictly equivalent to the command above (we only make explicit the +orientation which otherwise defaults to {\tt ->}). + +\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ +Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left +orientation in the base {\tt \ident}. + +\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ +When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will +be used, the tactic {\tt \tac} will be applied to the generated subgoals, the +main subgoal excluded. + +%% \item +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ +%% These are deprecated syntactic variants for +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. + +\item \texttt{Print Rewrite HintDb {\ident}} + + This command displays all rewrite hints contained in {\ident}. + +\end{Variants} \subsection{Hints and sections \label{Hint-and-Section}} @@ -3046,6 +3163,42 @@ defined inside a section (and not defined with option {\tt Local}) become available when the module {\tt A} is imported (using e.g. \texttt{Require Import A.}). +\subsection{Setting implicit automation tactics} + +\subsubsection{\tt Proof with {\tac}.} +\label{ProofWith} +\comindex{Proof with} + + This command may be used to start a proof. It defines a default + tactic to be used each time a tactic command {\tac$_1$} is ended by + ``\verb#...#''. In this case the tactic command typed by the user is + equivalent to \tac$_1$;{\tac}. + +\SeeAlso {\tt Proof.} in section~\ref{BeginProof}. + +\subsubsection{\tt Declare Implicit Tactic {\tac}.} +\comindex{Declare Implicit Tactic} + +This command declares a tactic to be used to solve implicit arguments +that {\Coq} does not know how to solve by unification. It is used +every time the term argument of a tactic has one of its holes not +fully resolved. + +Here is an example: + +\begin{coq_example} +Parameter quo : nat -> forall n:nat, n<>0 -> nat. +Notation "x // y" := (quo x y _) (at level 40). + +Declare Implicit Tactic assumption. +Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. +intros. +exists (n // m). +\end{coq_example} + +The tactic {\tt exists (n // m)} did not fail. The hole was solved by +{\tt assumption} so that it behaved as {\tt exists (quo n m H)}. + \section{Generation of induction principles with {\tt Scheme} \label{Scheme} \comindex{Scheme}} @@ -3139,7 +3292,7 @@ The chapter~\ref{TacticLanguage} gives examples of more complex user-defined tactics. -% $Id: RefMan-tac.tex 8938 2006-06-09 16:29:01Z jnarboux $ +% $Id: RefMan-tac.tex 9044 2006-07-12 13:22:17Z herbelin $ %%% Local Variables: %%% mode: latex diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index 4542e730..14fbff47 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -68,7 +68,7 @@ \include{RefMan-oth.v}% Vernacular commands \include{RefMan-pro}% Proof handling \include{RefMan-tac.v}% Tactics and tacticals -\include{RefMan-ltac}% Writing tactics +\include{RefMan-ltac.v}% Writing tactics \include{RefMan-tacex.v}% Detailed Examples of tactics \part{User extensions} @@ -122,4 +122,4 @@ \end{document} -% $Id: Reference-Manual.tex 8688 2006-04-07 15:08:12Z msozeau $ +% $Id: Reference-Manual.tex 9038 2006-07-11 13:53:53Z herbelin $ diff --git a/doc/refman/cover.html b/doc/refman/cover.html index 1d2700b1..a3ec2516 100644 --- a/doc/refman/cover.html +++ b/doc/refman/cover.html @@ -13,7 +13,7 @@ The Coq Proof Assistant<BR> Reference Manual<BR></B></FONT><FONT SIZE=7> </FONT> -<BR><BR><FONT SIZE=5><B><BR></B></FONT><FONT SIZE=5><B>Version 8.0</B></FONT><FONT SIZE=5><B> +<BR><BR><FONT SIZE=5><B><BR></B></FONT><FONT SIZE=5><B>Version 8.1</B></FONT><FONT SIZE=5><B> </B></FONT><A NAME="text1"></A><A HREF="#note1"><SUP><FONT SIZE=2>1</FONT></SUP></A><FONT SIZE=5><B><BR><BR><BR><BR><BR><BR> </B></FONT><FONT SIZE=5><B>The Coq Development Team</B></FONT><FONT SIZE=5><B><BR></B></FONT><FONT SIZE=5><B>LogiCal Project</B></FONT><FONT SIZE=5><B><BR><BR><BR> </B></FONT></DIV><BR> @@ -22,6 +22,7 @@ The Coq Proof Assistant<BR> <DIV ALIGN=left> <FONT SIZE=4>V7.x © INRIA 1999-2004</FONT><BR> <FONT SIZE=4>V8.0 © INRIA 2004-2006</FONT><BR> +<FONT SIZE=4>V8.1 © INRIA 2006</FONT><BR> This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <A HREF="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</A>). Options A and B are not elected. </DIV> <BR> diff --git a/doc/refman/index.html b/doc/refman/index.html index db19678f..9b5250ab 100644 --- a/doc/refman/index.html +++ b/doc/refman/index.html @@ -1,29 +1,14 @@ <HTML> -<BODY> +<HEAD> -<CENTER> +<TITLE>The Coq Proof Assistant Reference Manual</TITLE> -<TABLE BORDER="0" CELLPADDING=10> -<TR> -<TD><CENTER><A HREF="cover.html" TARGET="UP"><FONT SIZE=2>Cover page</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="toc.html" TARGET="UP"><FONT SIZE=2>Table of contents</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="biblio.html" TARGET="UP"><FONT SIZE=2> -Bibliography</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="general-index.html" TARGET="UP"><FONT SIZE=2> -Global Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="tactic-index.html" TARGET="UP"><FONT SIZE=2> -Tactics Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="command-index.html" TARGET="UP"><FONT SIZE=2> -Vernacular Commands Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="error-index.html" TARGET="UP"><FONT SIZE=2> -Index of Error Messages -</FONT></A></CENTER></TD> -</TABLE> +</HEAD> -</CENTER> +<FRAMESET ROWS=90%,*> + <FRAME SRC="cover.html" NAME="UP"> + <FRAME SRC="menu.html"> +</FRAMESET> -</BODY></HTML>
\ No newline at end of file +</HTML>
\ No newline at end of file diff --git a/doc/refman/menu.html b/doc/refman/menu.html new file mode 100644 index 00000000..db19678f --- /dev/null +++ b/doc/refman/menu.html @@ -0,0 +1,29 @@ +<HTML> + +<BODY> + +<CENTER> + +<TABLE BORDER="0" CELLPADDING=10> +<TR> +<TD><CENTER><A HREF="cover.html" TARGET="UP"><FONT SIZE=2>Cover page</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="toc.html" TARGET="UP"><FONT SIZE=2>Table of contents</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="biblio.html" TARGET="UP"><FONT SIZE=2> +Bibliography</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="general-index.html" TARGET="UP"><FONT SIZE=2> +Global Index +</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="tactic-index.html" TARGET="UP"><FONT SIZE=2> +Tactics Index +</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="command-index.html" TARGET="UP"><FONT SIZE=2> +Vernacular Commands Index +</FONT></A></CENTER></TD> +<TD><CENTER><A HREF="error-index.html" TARGET="UP"><FONT SIZE=2> +Index of Error Messages +</FONT></A></CENTER></TD> +</TABLE> + +</CENTER> + +</BODY></HTML>
\ No newline at end of file diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 73d833c4..d5523f1f 100755 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -31,20 +31,29 @@ proof tools. For more advanced information, the reader could refer to the \Coq{} Reference Manual or the \textit{Coq'Art}, a new book by Y. Bertot and P. Castéran on practical uses of the \Coq{} system. -We assume here that the potential user has installed \Coq~ on his workstation, -that he calls \Coq~ from a standard teletype-like shell window, and that -he does not use any special interface. +Coq can be used from a standard teletype-like shell window but +preferably through the graphical user interface +CoqIde\footnote{Alternative graphical interfaces exist: Proof General +and Pcoq.}. + Instructions on installation procedures, as well as more comprehensive documentation, may be found in the standard distribution of \Coq, which may be obtained from \Coq{} web site \texttt{http://coq.inria.fr}. -In the following, all examples preceded by the prompting sequence -\verb:Coq < : represent user input, terminated by a period. The -following lines usually show \Coq's answer as it appears on the users -screen. The sequence of such examples is a valid \Coq~ session, unless -otherwise specified. This version of the tutorial has been prepared -on a PC workstation running Linux. -The standard invocation of \Coq\ delivers a message such as: +In the following, we assume that \Coq~ is called from a standard +teletype-like shell window. All examples preceded by the prompting +sequence \verb:Coq < : represent user input, terminated by a +period. + +The following lines usually show \Coq's answer as it appears on the +users screen. When used from a graphical user interface such as +CoqIde, the prompt is not displayed: user input is given in one window +and \Coq's answers are displayed in a different window. + +The sequence of such examples is a valid \Coq~ +session, unless otherwise specified. This version of the tutorial has +been prepared on a PC workstation running Linux. The standard +invocation of \Coq\ delivers a message such as: \begin{small} \begin{flushleft} @@ -1552,4 +1561,4 @@ with \Coq, in order to acquaint yourself with various proof techniques. \end{document} -% $Id: Tutorial.tex 8715 2006-04-14 12:43:23Z cpaulin $ +% $Id: Tutorial.tex 8978 2006-06-23 10:15:57Z herbelin $ @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coq.ml 8912 2006-06-07 11:20:58Z notin $ *) +(* $Id: coq.ml 9024 2006-07-06 10:38:15Z herbelin $ *) open Vernac open Vernacexpr @@ -124,7 +124,7 @@ let interp verbosely s = | VernacDeclareTacticDefinition _ when is_in_proof_mode () -> user_error_loc loc (str "CoqIDE do not support nested goals") - | VernacDebug _ -> + | VernacSetOption (Goptions.SecondaryTable ("Ltac","Debug"), _) -> user_error_loc loc (str "Debug mode not available within CoqIDE") | VernacResetName _ | VernacResetInitial diff --git a/interp/constrextern.ml b/interp/constrextern.ml index daa57b77..570d113d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrextern.ml 8831 2006-05-19 09:29:54Z herbelin $ *) +(* $Id: constrextern.ml 8997 2006-07-03 16:40:20Z herbelin $ *) (*i*) open Pp @@ -186,7 +186,7 @@ let rec check_same_type ty1 ty2 = | CCases(_,_,a1,brl1), CCases(_,_,a2,brl2) -> List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2; List.iter2 (fun (_,pl1,r1) (_,pl2,r2) -> - List.iter2 check_same_pattern pl1 pl2; + List.iter2 (List.iter2 check_same_pattern) pl1 pl2; check_same_type r1 r2) brl1 brl2 | CHole _, CHole _ -> () | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> () @@ -797,7 +797,7 @@ and extern_local_binder scopes vars = function LocalRawAssum([(dummy_loc,na)],ty) :: l)) and extern_eqn inctx scopes vars (loc,ids,pl,c) = - (loc,List.map (extern_cases_pattern_in_scope scopes vars) pl, + (loc,[List.map (extern_cases_pattern_in_scope scopes vars) pl], extern inctx scopes vars c) and extern_symbol (tmp_scope,scopes as allscopes) vars t = function @@ -843,6 +843,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function and extern_recursion_order scopes vars = function RStructRec -> CStructRec | RWfRec c -> CWfRec (extern true scopes vars c) + | RMeasureRec c -> CMeasureRec (extern true scopes vars c) let extern_rawconstr vars c = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 678fb87b..355bac1d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrintern.ml 8924 2006-06-08 17:49:01Z notin $ *) +(* $Id: constrintern.ml 8997 2006-07-03 16:40:20Z herbelin $ *) open Pp open Util @@ -81,9 +81,8 @@ let explain_non_linear_pattern id = str "The variable " ++ pr_id id ++ str " is bound several times in pattern" let explain_bad_patterns_number n1 n2 = - let s = if n1 > 1 then "s" else "" in - str "Expecting " ++ int n1 ++ str " pattern" ++ str s ++ str " but found " - ++ int n2 + str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++ + str " but found " ++ int n2 let explain_bad_explicitation_number n po = match n with @@ -357,7 +356,8 @@ let rec has_duplicate = function | x::l -> if List.mem x l then (Some x) else has_duplicate l let loc_of_lhs lhs = - join_loc (cases_pattern_loc (List.hd lhs)) (cases_pattern_loc (list_last lhs)) + join_loc (cases_pattern_loc (List.hd (List.hd lhs))) + (cases_pattern_loc (list_last (list_last lhs))) let check_linearity lhs ids = match has_duplicate ids with @@ -775,17 +775,22 @@ let internalise sigma globalenv env allow_soapp lvar c = in let idl = Array.map (fun (id,(n,order),bl,ty,bd) -> - let ro, ((ids',_,_),rbl) = - (match order with - CStructRec -> - RStructRec, - List.fold_left intern_local_binder (env,[]) bl - | CWfRec c -> - let before, after = list_chop (succ (out_some n)) bl in - let ((ids',_,_),rafter) = - List.fold_left intern_local_binder (env,[]) after in - let ro = RWfRec (intern (ids', tmp_scope, scopes) c) in - ro, List.fold_left intern_local_binder (env,rafter) before) + let intern_ro_arg c f = + let before, after = list_chop (succ (out_some n)) bl in + let ((ids',_,_),rafter) = + List.fold_left intern_local_binder (env,[]) after in + let ro = (intern (ids', tmp_scope, scopes) c) in + f ro, List.fold_left intern_local_binder (env,rafter) before + in + let ro, ((ids',_,_),rbl) = + (match order with + CStructRec -> + RStructRec, + List.fold_left intern_local_binder (env,[]) bl + | CWfRec c -> + intern_ro_arg c (fun r -> RWfRec r) + | CMeasureRec c -> + intern_ro_arg c (fun r -> RMeasureRec r)) in let ids'' = List.fold_right Idset.add lf ids' in ((n, ro), List.rev rbl, @@ -924,11 +929,24 @@ let internalise sigma globalenv env allow_soapp lvar c = ((name_fold Idset.add na ids,ts,sc), (na,Some(intern env def),RHole(loc,Evd.BinderType na))::bl) - and intern_eqn n (ids,tmp_scope,scopes as _env) (loc,lhs,rhs) = + (* Expands a multiple pattern into a disjunction of multiple patterns *) + and intern_multiple_pattern scopes pl = let idsl_pll = - List.map (intern_cases_pattern globalenv scopes ([],[]) None) lhs in - - let eqn_ids,pll = product_of_cases_patterns [] idsl_pll in + List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in + product_of_cases_patterns [] idsl_pll + + (* Expands a disjunction of multiple pattern *) + and intern_disjunctive_multiple_pattern scopes loc mpl = + assert (mpl <> []); + let mpl' = List.map (intern_multiple_pattern scopes) mpl in + let (idsl,mpl') = List.split mpl' in + let ids = List.hd idsl in + check_or_pat_variables loc ids (List.tl idsl); + (ids,List.flatten mpl') + + (* Expands a pattern-matching clause [lhs => rhs] *) + and intern_eqn n (ids,tmp_scope,scopes) (loc,lhs,rhs) = + let eqn_ids,pll = intern_disjunctive_multiple_pattern scopes loc lhs in (* Linearity implies the order in ids is irrelevant *) check_linearity lhs eqn_ids; check_number_of_pattern loc n (snd (List.hd pll)); diff --git a/interp/genarg.mli b/interp/genarg.mli index 37b30927..c4275589 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: genarg.mli 8926 2006-06-08 20:23:17Z herbelin $ i*) +(*i $Id: genarg.mli 8983 2006-06-23 13:21:49Z herbelin $ i*) open Util open Names @@ -60,20 +60,21 @@ Transformation for each type : \begin{verbatim} tag raw open type cooked closed type -BoolArgType bool bool -IntArgType int int -IntOrVarArgType int or_var int -StringArgType string (parsed w/ "") string -PreIdentArgType string (parsed w/o "") (vernac only) -IdentArgType identifier identifier -IntroPatternArgType intro_pattern_expr intro_pattern_expr -VarArgType identifier constr -RefArgType reference global_reference -ConstrArgType constr_expr constr -ConstrMayEvalArgType constr_expr may_eval constr -QuantHypArgType quantified_hypothesis quantified_hypothesis -OpenConstrArgType constr_expr open_constr -ConstrBindingsArgType constr_expr with_bindings constr with_bindings +BoolArgType bool bool +IntArgType int int +IntOrVarArgType int or_var int +StringArgType string (parsed w/ "") string +PreIdentArgType string (parsed w/o "") (vernac only) +IdentArgType identifier identifier +IntroPatternArgType intro_pattern_expr intro_pattern_expr +VarArgType identifier located identifier +RefArgType reference global_reference +QuantHypArgType quantified_hypothesis quantified_hypothesis +ConstrArgType constr_expr constr +ConstrMayEvalArgType constr_expr may_eval constr +OpenConstrArgType open_constr_expr open_constr +ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings +BindingsArgType constr_expr bindings constr bindings List0ArgType of argument_type List1ArgType of argument_type OptArgType of argument_type diff --git a/interp/topconstr.ml b/interp/topconstr.ml index f7256026..f3099346 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: topconstr.ml 8875 2006-05-29 19:59:11Z msozeau $ *) +(* $Id: topconstr.ml 9032 2006-07-07 16:30:34Z herbelin $ *) (*i*) open Pp @@ -515,7 +515,7 @@ type constr_expr = (constr_expr * explicitation located option) list | CCases of loc * constr_expr option * (constr_expr * (name option * constr_expr option)) list * - (loc * cases_pattern_expr list * constr_expr) list + (loc * cases_pattern_expr list list * constr_expr) list | CLetTuple of loc * name list * (name option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name option * constr_expr option) @@ -544,6 +544,7 @@ and cofixpoint_expr = and recursion_order_expr = | CStructRec | CWfRec of constr_expr + | CMeasureRec of constr_expr (***********************) (* For binders parsing *) @@ -553,6 +554,11 @@ let rec local_binders_length = function | LocalRawDef _::bl -> 1 + local_binders_length bl | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl +let rec local_assums_length = function + | [] -> 0 + | LocalRawDef _::bl -> local_binders_length bl + | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl + let names_of_local_assums bl = List.flatten (List.map (function LocalRawAssum(l,_)->l|_->[]) bl) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 8305ea54..51853089 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: topconstr.mli 8875 2006-05-29 19:59:11Z msozeau $ i*) +(*i $Id: topconstr.mli 9032 2006-07-07 16:30:34Z herbelin $ i*) (*i*) open Pp @@ -98,7 +98,7 @@ type constr_expr = (constr_expr * explicitation located option) list | CCases of loc * constr_expr option * (constr_expr * (name option * constr_expr option)) list * - (loc * cases_pattern_expr list * constr_expr) list + (loc * cases_pattern_expr list list * constr_expr) list | CLetTuple of loc * name list * (name option * constr_expr option) * constr_expr * constr_expr | CIf of loc * constr_expr * (name option * constr_expr option) @@ -122,6 +122,7 @@ and cofixpoint_expr = and recursion_order_expr = | CStructRec | CWfRec of constr_expr + | CMeasureRec of constr_expr and local_binder = | LocalRawDef of name located * constr_expr @@ -158,6 +159,9 @@ val prod_constr_expr : constr_expr -> local_binder list -> constr_expr (* Includes let binders *) val local_binders_length : local_binder list -> int +(* Excludes let binders *) +val local_assums_length : local_binder list -> int + (* Does not take let binders into account *) val names_of_local_assums : local_binder list -> name located list diff --git a/kernel/inductive.ml b/kernel/inductive.ml index d9f9f912..76553237 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inductive.ml 8871 2006-05-28 16:46:48Z herbelin $ *) +(* $Id: inductive.ml 8972 2006-06-22 22:17:43Z herbelin $ *) open Util open Names @@ -135,16 +135,22 @@ let sort_as_univ = function | Prop Null -> neutral_univ | Prop Pos -> base_univ +let cons_subst u su subst = + try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst + with Not_found -> (u, su) :: subst + let rec make_subst env exp act = match exp, act with (* Bind expected levels of parameters to actual levels *) | None :: exp, _ :: act -> make_subst env exp act - | Some u :: exp, t :: act -> - (u, sort_as_univ (snd (dest_arity env t))) :: make_subst env exp act + | Some u :: exp, t :: act -> + let su = sort_as_univ (snd (dest_arity env t)) in + cons_subst u su (make_subst env exp act) (* Not enough parameters, create a fresh univ *) | Some u :: exp, [] -> - (u, fresh_local_univ ()) :: make_subst env exp [] + let su = fresh_local_univ () in + cons_subst u su (make_subst env exp []) | None :: exp, [] -> make_subst env exp [] (* Uniform parameters are exhausted *) diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index ec3c2c9c..638a8d65 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: argextend.ml4 8926 2006-06-08 20:23:17Z herbelin $ *) +(* $Id: argextend.ml4 8976 2006-06-23 10:03:54Z herbelin $ *) open Genarg open Q_util @@ -176,41 +176,6 @@ let declare_vernac_argument loc s cl = open Vernacexpr open Pcoq - -let rec interp_entry_name loc s = - let l = String.length s in - if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in - List1ArgType t, <:expr< Gramext.Slist1 $g$ >> - else if l > 5 & String.sub s (l-5) 5 = "_list" then - let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in - List0ArgType t, <:expr< Gramext.Slist0 $g$ >> - else if l > 4 & String.sub s (l-4) 4 = "_opt" then - let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in - OptArgType t, <:expr< Gramext.Sopt $g$ >> - else - let t, se = - if tactic_genarg_level s <> None then - Some (ExtraArgType s), <:expr< Tactic. tactic >> - else - 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 diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 9ee312ff..a1c0c9ae 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_constr.ml4 8875 2006-05-29 19:59:11Z msozeau $ *) +(* $Id: g_constr.ml4 9043 2006-07-12 10:06:40Z herbelin $ *) open Pcoq open Constr @@ -244,6 +244,7 @@ GEXTEND Gram fixannot: [ [ "{"; IDENT "struct"; id=name; "}" -> (Some id, CStructRec) | "{"; IDENT "wf"; id=name; rel=lconstr; "}" -> (Some id, CWfRec rel) + | "{"; IDENT "measure"; id=name; rel=lconstr; "}" -> (Some id, CMeasureRec rel) | -> (None, CStructRec) ] ] ; @@ -273,24 +274,25 @@ GEXTEND Gram [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ] ; eqn: - [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ] + [ [ pll = LIST0 LIST1 pattern LEVEL "99" SEP "," SEP "|"; + "=>"; rhs = lconstr -> (loc,pll,rhs) ] ] ; pattern: [ "200" RIGHTA [ ] - | "100" LEFTA + | "100" RIGHTA [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ] | "99" RIGHTA [ ] | "10" LEFTA - [ p = pattern; lp = LIST1 (pattern LEVEL "0") -> + [ p = pattern; lp = LIST1 NEXT -> (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 = ident -> - CPatAlias (loc, p, id) - | c = pattern; "%"; key=IDENT -> - CPatDelimiters (loc,key,c) ] + CPatAlias (loc, p, id) ] + | "1" LEFTA + [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ] | "0" [ r = Prim.reference -> CPatAtom (loc,Some r) | "_" -> CPatAtom (loc,None) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index eaa51810..c01c23b6 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_ltac.ml4 8878 2006-05-30 16:44:25Z herbelin $ *) +(* $Id: g_ltac.ml4 9037 2006-07-11 12:43:50Z herbelin $ *) open Pp open Util @@ -134,7 +134,7 @@ GEXTEND Gram | "()" -> TacVoid ] ] ; match_key: - [ [ "match" -> false ] ] + [ [ "match" -> false | "lazymatch" -> true ] ] ; input_fun: [ [ "_" -> None diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 7405ae54..a72ced97 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_vernac.ml4 8929 2006-06-08 22:35:58Z herbelin $ *) +(* $Id: g_vernac.ml4 9017 2006-07-05 17:27:34Z herbelin $ *) (*i camlp4deps: "parsing/grammar.cma" i*) open Pp @@ -237,6 +237,7 @@ GEXTEND Gram rec_annotation: [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec) | "{"; IDENT "wf"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CWfRec rel) + | "{"; IDENT "measure"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CMeasureRec rel) | -> (None, CStructRec) ] ] ; @@ -651,8 +652,11 @@ GEXTEND Gram VernacBacktrack (n,m,p) (* Tactic Debugger *) - | IDENT "Debug"; IDENT "On" -> VernacDebug true - | IDENT "Debug"; IDENT "Off" -> VernacDebug false + | IDENT "Debug"; IDENT "On" -> + VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue true) + + | IDENT "Debug"; IDENT "Off" -> + VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue false) ] ]; END diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 5ad0193b..a89fffa0 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_xml.ml4 8875 2006-05-29 19:59:11Z msozeau $ *) +(* $Id: g_xml.ml4 9016 2006-07-05 17:19:39Z herbelin $ *) open Pp open Util @@ -228,6 +228,10 @@ and interp_xml_recursionOrder x = (match l with [c] -> RWfRec (interp_xml_type c) | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)")) + | "Measure" -> + (match l with + [c] -> RMeasureRec (interp_xml_type c) + | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)")) | _ -> user_err_loc (locs,"",str "invalid recursion order") @@ -252,22 +256,12 @@ and interp_xml_CoFixFunction x = (* Interpreting tactic argument *) -let rec (interp_xml_tactic_expr : xml -> glob_tactic_expr) = function - | XmlTag (loc,"TACARG",[],[x]) -> - TacArg (interp_xml_tactic_arg x) - | _ -> error "Ill-formed xml tree" - -and interp_xml_tactic_arg = function +let rec interp_xml_tactic_arg = function | XmlTag (loc,"TERM",[],[x]) -> ConstrMayEval (ConstrTerm (interp_xml_constr x,None)) | XmlTag (loc,"CALL",al,xl) -> let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl) -(* - | XmlTag (loc,"TACTIC",[],[x]) -> - Tacexp (interp_xml_tactic_expr x) - | _ -> error "Ill-formed xml tree" -*) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s) let parse_tactic_arg ch = diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index c02dc59b..80eaf7f0 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: lexer.ml4 8924 2006-06-08 17:49:01Z notin $ i*) +(*i $Id: lexer.ml4 9015 2006-07-05 17:19:22Z herbelin $ i*) open Pp open Token @@ -146,12 +146,14 @@ let lookup_utf8_tail c cs = (* utf-8 what do to with diacritics U0483-U0489 \ U0487 ? *) (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *) | x when 0x048A <= x & x <= 0x04F9 -> Utf8Letter n - (* utf-8 Cyrillic supplements letters U0500-U050F *) + (* utf-8 Cyrillic supplement letters U0500-U050F *) | x when 0x0500 <= x & x <= 0x050F -> Utf8Letter n (* utf-8 Hebrew letters U05D0-05EA *) | x when 0x05D0 <= x & x <= 0x05EA -> Utf8Letter n - (* utf-8 Hebrew letters U0621-064A *) + (* utf-8 Arabic letters U0621-064A *) | x when 0x0621 <= x & x <= 0x064A -> Utf8Letter n + (* utf-8 Arabic supplement letters U0750-076D *) + | x when 0x0750 <= x & x <= 0x076D -> Utf8Letter n | _ -> error_unsupported_unicode_character n cs end | 0x1000 -> @@ -589,9 +591,10 @@ let is_ident_not_keyword s = | _ -> false let is_number s = - match s.[0] with - | '0'..'9' -> true - | _ -> false + let rec aux i = + String.length s = i or + match s.[i] with '0'..'9' -> aux (i+1) | _ -> false + in aux 0 let strip s = let len = diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 127a911f..56e434fb 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pcoq.ml4 8926 2006-06-08 20:23:17Z herbelin $ i*) +(*i $Id: pcoq.ml4 9043 2006-07-12 10:06:40Z herbelin $ i*) open Pp open Util @@ -484,7 +484,11 @@ let default_levels = 0,Gramext.RightA] let default_pattern_levels = - [10,Gramext.LeftA; + [200,Gramext.RightA; + 100,Gramext.RightA; + 99,Gramext.RightA; + 10,Gramext.LeftA; + 1,Gramext.LeftA; 0,Gramext.RightA] let level_stack = diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index d55a6c1e..a1ca386e 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppconstr.ml 8878 2006-05-30 16:44:25Z herbelin $ *) +(* $Id: ppconstr.ml 8997 2006-07-03 16:40:20Z herbelin $ *) (*i*) open Util @@ -186,12 +186,12 @@ let rec pr_patt sep inh p = 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 " =>") ++ + hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl + ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) let begin_of_binder = function @@ -384,6 +384,8 @@ let pr_fixdecl pr prd dangling_with_for (id,(n,ro),bl,t,c) = else mt() | CWfRec c -> spc () ++ str "{wf " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}" + | CMeasureRec c -> + spc () ++ str "{measure " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}" in pr_recursive_decl pr prd dangling_with_for id bl annot t c diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index aea44604..7e3c853d 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppvernac.ml 8831 2006-05-19 09:29:54Z herbelin $ *) +(* $Id: ppvernac.ml 9020 2006-07-05 17:35:23Z herbelin $ *) open Pp open Names @@ -414,7 +414,6 @@ let rec pr_vernac = function | 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 @@ -572,6 +571,9 @@ let rec pr_vernac = function | CWfRec c -> spc() ++ str "{wf " ++ pr_name name ++ spc() ++ pr_lconstr_expr c ++ str"}" + | CMeasureRec c -> + spc() ++ str "{measure " ++ pr_name name ++ spc() ++ + pr_lconstr_expr c ++ str"}" in pr_id id ++ pr_binders_arg bl ++ annot ++ spc() ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index 07b23972..61a552f3 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: q_util.ml4 7732 2005-12-26 13:51:24Z herbelin $ *) +(* $Id: q_util.ml4 8982 2006-06-23 13:17:49Z herbelin $ *) (* This file defines standard combinators to build ml expressions *) @@ -84,21 +84,27 @@ let rec interp_entry_name loc s = OptArgType t, <:expr< Gramext.Sopt $g$ >> else let s = if s = "hyp" then "var" else s in - let t, se = + let t, se, lev = + match tactic_genarg_level s with + | Some n -> Some (ExtraArgType s), <:expr< Tactic. tactic_expr >>, Some n + | None -> match Pcoq.entry_type (Pcoq.get_univ "prim") s with - | Some _ as x -> x, <:expr< Prim. $lid:s$ >> + | Some _ as x -> x, <:expr< Prim. $lid:s$ >>, None | None -> match Pcoq.entry_type (Pcoq.get_univ "constr") s with - | Some _ as x -> x, <:expr< Constr. $lid:s$ >> + | Some _ as x -> x, <:expr< Constr. $lid:s$ >>, None | None -> match Pcoq.entry_type (Pcoq.get_univ "tactic") s with - | Some _ as x -> x, <:expr< Tactic. $lid:s$ >> - | None -> None, <:expr< $lid:s$ >> in + | Some _ as x -> x, <:expr< Tactic. $lid:s$ >>, None + | None -> None, <:expr< $lid:s$ >>, None in let t = match t with | Some t -> t - | None -> -(* Pp.warning_with Pp_control.err_ft - ("Unknown primitive grammar entry: "^s);*) - ExtraArgType s - in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> + | None -> ExtraArgType s in + let entry = match lev with + | Some n -> + let s = string_of_int n in + <:expr< Gramext.Snterml (Pcoq.Gram.Entry.obj $se$, $str:s$) >> + | None -> + <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >> + in t, entry diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index ef97250a..eb8a25eb 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pattern.ml 8755 2006-04-27 22:22:15Z herbelin $ *) +(* $Id: pattern.ml 8963 2006-06-19 18:54:49Z barras $ *) open Util open Names @@ -132,7 +132,7 @@ let map_pattern_with_binders g f l = function let map_pattern f = map_pattern_with_binders (fun () -> ()) (fun () -> f) () let rec instantiate_pattern lvar = function - | PVar id as x -> (try List.assoc id lvar with Not_found -> x) + | PVar id as x -> (try Lazy.force(List.assoc id lvar) with Not_found -> x) | (PFix _ | PCoFix _) -> error ("Not instantiable pattern") | c -> map_pattern (instantiate_pattern lvar) c diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 1637fc5f..4102db9e 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pattern.mli 8755 2006-04-27 22:22:15Z herbelin $ i*) +(*i $Id: pattern.mli 8963 2006-06-19 18:54:49Z barras $ i*) (*i*) open Pp @@ -76,6 +76,6 @@ val pattern_of_rawconstr : rawconstr -> patvar list * constr_pattern val instantiate_pattern : - (identifier * constr_pattern) list -> constr_pattern -> constr_pattern + (identifier * constr_pattern Lazy.t) list -> constr_pattern -> constr_pattern val lift_pattern : int -> constr_pattern -> constr_pattern diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ca797f97..e3cfe974 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pretyping.ml 8875 2006-05-29 19:59:11Z msozeau $ *) +(* $Id: pretyping.ml 8992 2006-06-27 21:29:18Z herbelin $ *) open Pp open Util @@ -482,6 +482,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct else error_cant_find_case_type_loc loc env (evars_of !isevars) cj.uj_val in + let ccl = refresh_universes ccl in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index e61bf2c3..ece536d1 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rawterm.ml 8878 2006-05-30 16:44:25Z herbelin $ *) +(* $Id: rawterm.ml 8969 2006-06-22 12:51:04Z msozeau $ *) (*i*) open Util @@ -73,7 +73,7 @@ type rawconstr = and rawdecl = name * rawconstr option * rawconstr -and fix_recursion_order = RStructRec | RWfRec of rawconstr +and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr and fix_kind = | RFix of ((int option * fix_recursion_order) array * int) diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index b29cc7b6..89b13ff0 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: rawterm.mli 8878 2006-05-30 16:44:25Z herbelin $ i*) +(*i $Id: rawterm.mli 8969 2006-06-22 12:51:04Z msozeau $ i*) (*i*) open Util @@ -70,7 +70,7 @@ type rawconstr = and rawdecl = name * rawconstr option * rawconstr -and fix_recursion_order = RStructRec | RWfRec of rawconstr +and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr and fix_kind = | RFix of ((int option * fix_recursion_order) array * int) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 5d38f52c..74df5eea 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: recordops.ml 8752 2006-04-27 19:37:33Z herbelin $ *) +(* $Id: recordops.ml 9032 2006-07-07 16:30:34Z herbelin $ *) open Util open Pp @@ -32,7 +32,7 @@ open Mod_subst type struc_typ = { s_CONST : identifier; - s_PARAM : int; + s_EXPECTEDPARAM : int; s_PROJKIND : bool list; s_PROJ : constant option list } @@ -44,7 +44,7 @@ let option_fold_right f p e = match p with Some a -> f a e | None -> e let load_structure i (_,(ind,id,kl,projs)) = let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in let struc = - { s_CONST = id; s_PARAM = n; s_PROJ = projs; s_PROJKIND = kl } in + { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in structure_table := Indmap.add ind struc !structure_table; projection_table := List.fold_right (option_fold_right (fun proj -> Cmap.add proj struc)) @@ -83,8 +83,10 @@ let declare_structure (s,c,_,kl,pl) = let lookup_structure indsp = Indmap.find indsp !structure_table +let lookup_projections indsp = (lookup_structure indsp).s_PROJ + let find_projection_nparams = function - | ConstRef cst -> (Cmap.find cst !projection_table).s_PARAM + | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM | _ -> raise Not_found @@ -134,7 +136,7 @@ let compute_canonical_projections (con,ind) = let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in let lt = List.rev (List.map snd lt) in let args = snd (decompose_app t) in - let { s_PARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in + let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = list_chop p args in let lpj = keep_true_projections lpj kl in let lps = List.combine lpj projs in @@ -202,7 +204,8 @@ let check_and_decompose_canonical_structure ref = | Construct (indsp,1) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in - if s.s_PARAM + List.length s.s_PROJ > Array.length args then + let ntrue_projs = List.length (List.filter (fun x -> x) s.s_PROJKIND) in + if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 1e061dc6..91bc2ba1 100755 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: recordops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*) +(*i $Id: recordops.mli 9032 2006-07-07 16:30:34Z herbelin $ i*) (*i*) open Names @@ -21,18 +21,13 @@ open Library (*s A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) -type struc_typ = { - s_CONST : identifier; - s_PARAM : int; - s_PROJKIND : bool list; - s_PROJ : constant option list } - val declare_structure : inductive * identifier * int * bool list * constant option list -> unit -(* [lookup_structure isp] returns the infos associated to inductive path - [isp] if it corresponds to a structure, otherwise fails with [Not_found] *) -val lookup_structure : inductive -> struc_typ +(* [lookup_projections isp] returns the projections associated to the + inductive path [isp] if it corresponds to a structure, otherwise + it fails with [Not_found] *) +val lookup_projections : inductive -> constant option list (* raise [Not_found] if not a projection *) val find_projection_nparams : global_reference -> int diff --git a/tactics/equality.ml b/tactics/equality.ml index 42fc1201..f05c3882 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml 8878 2006-05-30 16:44:25Z herbelin $ *) +(* $Id: equality.ml 9010 2006-07-05 07:17:41Z jforest $ *) open Pp open Util @@ -201,7 +201,7 @@ let abstract_replace clause c2 c1 unsafe tac gl = ] ] gl else - error "terms does not have convertible types" + error "terms do not have convertible types" let replace c2 c1 gl = abstract_replace None c2 c1 false tclIDTAC gl @@ -544,11 +544,9 @@ 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 | Type _ -> build_sigma_type () (* Set/Type *) - | Prop Null -> error "find_sigma_data" +(* J.F.: correction du bug #1167 en accord avec Hugo. *) + +let find_sigma_data s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser index bound in [rty] diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 48bd87ee..c2820c44 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: extratactics.ml4 8926 2006-06-08 20:23:17Z herbelin $ *) +(* $Id: extratactics.ml4 8979 2006-06-23 10:17:14Z herbelin $ *) open Pp open Pcoq @@ -46,14 +46,15 @@ let pr_by_arg_tac _prc _prlc prtac opt_c = | None -> mt () | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) -(* Julien Forest: on voudrait pouvoir passer la loc mais je -n'ai pas reussi -*) +let pr_in_hyp = function + | None -> mt () + | Some id -> spc () ++ hov 2 (str "in" ++ spc () ++ Nameops.pr_id id) let pr_in_arg_hyp _prc _prlc _prtac opt_c = - match opt_c with - | None -> mt () - | Some id -> spc () ++ hov 2 (str "by" ++ spc () ++ Nameops.pr_id id) + pr_in_hyp (Util.option_map snd opt_c) + +let pr_in_arg_hyp_typed _prc _prlc _prtac = + pr_in_hyp ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt @@ -63,9 +64,13 @@ ARGUMENT EXTEND by_arg_tac END ARGUMENT EXTEND in_arg_hyp - TYPED AS ident_opt - PRINTED BY pr_in_arg_hyp -| [ "in" ident(c) ] -> [ Some (c) ] + TYPED AS var_opt + PRINTED BY pr_in_arg_hyp_typed + RAW_TYPED AS var_opt + RAW_PRINTED BY pr_in_arg_hyp + GLOB_TYPED AS var_opt + GLOB_PRINTED BY pr_in_arg_hyp +| [ "in" hyp(c) ] -> [ Some (c) ] | [ ] -> [ None ] END @@ -183,9 +188,9 @@ TACTIC EXTEND autorewrite [ autorewrite Refiner.tclIDTAC l ] | [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] -> [ autorewrite (snd t) l ] -| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) ] -> [ autorewrite_in id Refiner.tclIDTAC l ] -| [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) "using" tactic(t) ] -> +| [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) "using" tactic(t) ] -> [ autorewrite_in id (snd t) l ] END @@ -283,7 +288,7 @@ END TACTIC EXTEND setoid_symmetry [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" ident(n) ] -> [ setoid_symmetry_in n ] + | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] END TACTIC EXTEND setoid_reflexivity diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index e42a40e7..91766254 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -6,12 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extratactics.mli 8780 2006-05-02 21:58:58Z letouzey $ i*) +(*i $Id: extratactics.mli 8977 2006-06-23 10:09:59Z herbelin $ i*) +open Util open Names open Term open Proof_type open Rawterm +open Tacexpr +open Topconstr +open Genarg val h_discrHyp : quantified_hypothesis -> tactic val h_injHyp : quantified_hypothesis -> tactic @@ -26,14 +30,13 @@ val refine_tac : Genarg.open_constr -> tactic *) -val rawwit_in_arg_hyp: identifier option Tacexpr.raw_abstract_argument_type -val in_arg_hyp: identifier option Pcoq.Gram.Entry.e +val rawwit_in_arg_hyp: identifier located option raw_abstract_argument_type + +val in_arg_hyp: identifier located option Pcoq.Gram.Entry.e val rawwit_by_arg_tac : - (Tacexpr.raw_tactic_expr option, Topconstr.constr_expr, - Tacexpr.raw_tactic_expr) - Genarg.abstract_argument_type + (raw_tactic_expr option, constr_expr, raw_tactic_expr) abstract_argument_type val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 0f487009..114968c8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml 8926 2006-06-08 20:23:17Z herbelin $ *) +(* $Id: tacinterp.ml 8991 2006-06-27 11:59:50Z herbelin $ *) open Constrintern open Closure @@ -73,7 +73,7 @@ type value = | VIntroPattern of intro_pattern_expr (* includes idents which are not *) (* bound as in "Intro H" but which may be bound *) (* later, as in "tac" in "Intro H; tac" *) - | VConstr of constr (* includes idents known bound and references *) + | VConstr of constr (* includes idents known to be bound and references *) | VConstr_context of constr | VRec of value ref @@ -116,9 +116,9 @@ let pr_value env = function | VVoid -> str "()" | VInteger n -> int n | VIntroPattern ipat -> pr_intro_pattern ipat - | VConstr c -> pr_lconstr_env env c - | VConstr_context c -> pr_lconstr_env env c - | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "<fun>" + | VConstr c | VConstr_context c -> + (match env with Some env -> pr_lconstr_env env c | _ -> str "a term") + | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "a tactic" (* Transforms a named_context into a (string * constr) list *) let make_hyps = List.map (fun (id,_,typ) -> (id, typ)) @@ -167,10 +167,9 @@ let constrOut = function | ast -> anomalylabstrm "constrOut" (str "Not a Dynamic ast") -let loc = dummy_loc +let dloc = dummy_loc (* Globalizes the identifier *) - let find_reference env qid = (* We first look for a variable of the current proof *) match repr_qualid qid with @@ -178,46 +177,11 @@ let find_reference env qid = -> VarRef id | _ -> Nametab.locate qid -let coerce_to_reference env = function - | VConstr c -> - (try global_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 -> global_of_constr c - | _ -> failwith "" in - errorlabstrm "coerce_to_inductive" - (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 = @@ -227,7 +191,7 @@ let add_primitive_tactic s tac = let _ = let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in List.iter - (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t))) + (fun (s,t) -> add_primitive_tactic s (TacAtom(dloc,t))) [ "red", TacReduce(Red false,nocl); "hnf", TacReduce(Hnf,nocl); "simpl", TacReduce(Simpl None,nocl); @@ -354,14 +318,14 @@ let get_current_context () = let strict_check = ref false -let adjust_loc loc = if !strict_check then dummy_loc else loc +let adjust_loc loc = if !strict_check then dloc else loc (* Globalize a name which must be bound -- actually just check it is bound *) let intern_hyp ist (loc,id as locid) = if not !strict_check then locid else if find_ident id ist then - (dummy_loc,id) + (dloc,id) else Pretype_errors.error_var_not_found_loc loc id @@ -401,7 +365,7 @@ let intern_tactic_reference ist r = let intern_constr_reference strict ist = function | Ident (_,id) when (not strict & find_hyp id ist) or find_ctxvar id ist -> - RVar (loc,id), None + RVar (dloc,id), None | r -> let loc,qid = qualid_of_reference r in RRef (loc,locate_global qid), if strict then None else Some (CRef r) @@ -474,7 +438,7 @@ let intern_induction_arg ist = function | ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id)))) + ElimOnConstr (intern_constr ist (CRef (Ident (dloc,id)))) else ElimOnIdent (loc,id) @@ -509,7 +473,7 @@ let intern_flag ist red = let intern_constr_occurrence ist (l,c) = (l,intern_constr ist c) -let intern_redexp ist = function +let intern_red_expr ist = function | Unfold l -> Unfold (List.map (intern_unfold ist) l) | Fold l -> Fold (List.map (intern_constr ist) l) | Cbv f -> Cbv (intern_flag ist f) @@ -539,16 +503,16 @@ let interp_constrpattern_gen sigma env ltacvar c = pattern_of_rawconstr c (* Reads a pattern *) -let intern_pattern evc env lfun = function +let intern_pattern sigma env lfun = function | Subterm (ido,pc) -> - let (metas,pat) = interp_constrpattern_gen evc env lfun pc in + let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in ido, metas, Subterm (ido,pat) | Term pc -> - let (metas,pat) = interp_constrpattern_gen evc env lfun pc in + let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in None, metas, Term pat let intern_constr_may_eval ist = function - | ConstrEval (r,c) -> ConstrEval (intern_redexp ist r,intern_constr ist c) + | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) | ConstrContext (locid,c) -> ConstrContext (intern_hyp ist locid,intern_constr ist c) | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) @@ -573,10 +537,10 @@ let extern_request ch req gl la = output_string ch "</REQUEST>\n" (* Reads the hypotheses of a Match Context rule *) -let rec intern_match_context_hyps evc env lfun = function +let rec intern_match_context_hyps sigma env lfun = function | (Hyp ((_,na) as locna,mp))::tl -> - let ido, metas1, pat = intern_pattern evc env lfun mp in - let lfun, metas2, hyps = intern_match_context_hyps evc env lfun tl in + let ido, metas1, pat = intern_pattern sigma env lfun mp in + let lfun, metas2, hyps = intern_match_context_hyps sigma env lfun tl in let lfun' = name_cons na (option_cons ido lfun) in lfun', metas1@metas2, Hyp (locna,pat)::hyps | [] -> lfun, [], [] @@ -709,7 +673,7 @@ let rec intern_atomic lf ist x = (* Conversion *) | TacReduce (r,cl) -> - TacReduce (intern_redexp ist r, clause_app (intern_hyp_location ist) cl) + TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) | TacChange (occl,c,cl) -> TacChange (option_map (intern_constr_occurrence ist) occl, intern_constr ist c, clause_app (intern_hyp_location ist) cl) @@ -867,7 +831,7 @@ and intern_genarg ist x = in_gen globwit_quant_hyp (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x)) | RedExprArgType -> - in_gen globwit_red_expr (intern_redexp ist (out_gen rawwit_red_expr x)) + in_gen globwit_red_expr (intern_red_expr ist (out_gen rawwit_red_expr x)) | OpenConstrArgType b -> in_gen (globwit_open_constr_gen b) ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen b) x))) @@ -914,37 +878,36 @@ let give_context ctxt = function | None -> [] | Some id -> [id,VConstr_context ctxt] -(* Reads a pattern by substituing vars of lfun *) +(* Reads a pattern by substituting vars of lfun *) let eval_pattern lfun c = - let lvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lfun in + let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in instantiate_pattern lvar c -let read_pattern evc env lfun = function +let read_pattern lfun = function | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc) | Term pc -> Term (eval_pattern lfun pc) (* Reads the hypotheses of a Match Context rule *) let cons_and_check_name id l = if List.mem id l then - user_err_loc (loc,"read_match_context_hyps", + user_err_loc (dloc,"read_match_context_hyps", str ("Hypothesis pattern-matching variable "^(string_of_id id)^ " used twice in the same pattern")) else id::l -let rec read_match_context_hyps evc env lfun lidh = function +let rec read_match_context_hyps lfun lidh = function | (Hyp ((loc,na) as locna,mp))::tl -> let lidh' = name_fold cons_and_check_name na lidh in - Hyp (locna,read_pattern evc env lfun mp):: - (read_match_context_hyps evc env lfun lidh' tl) + Hyp (locna,read_pattern lfun mp):: + (read_match_context_hyps lfun lidh' tl) | [] -> [] (* Reads the rules of a Match Context or a Match *) -let rec read_match_rule evc env lfun = function - | (All tc)::tl -> (All tc)::(read_match_rule evc env lfun tl) +let rec read_match_rule lfun = function + | (All tc)::tl -> (All tc)::(read_match_rule lfun tl) | (Pat (rl,mp,tc))::tl -> - Pat (read_match_context_hyps evc env lfun [] rl, - read_pattern evc env lfun mp,tc) - ::(read_match_rule evc env lfun tl) + Pat (read_match_context_hyps lfun [] rl, read_pattern lfun mp,tc) + :: read_match_rule lfun tl | [] -> [] (* For Match Context and Match *) @@ -1004,6 +967,9 @@ let constr_to_qid loc c = try shortest_qualid_of_global Idset.empty (global_of_constr c) with _ -> invalid_arg_loc (loc, "Not a global reference") +let is_variable env id = + List.mem id (ids_of_named_context (Environ.named_context env)) + (* Debug reference *) let debug = ref DebugOff @@ -1013,46 +979,70 @@ let set_debug pos = debug := pos (* Gives the state of debug *) let get_debug () = !debug +let error_ltac_variable loc id env v s = + user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + str " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + str "which cannot be coerced to " ++ str s) + +exception CannotCoerceTo of string + +(* Raise Not_found if not in interpretation sign *) +let try_interp_ltac_var coerce ist env (loc,id) = + let v = List.assoc id ist.lfun in + try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s + +let interp_ltac_var coerce ist env locid = + try try_interp_ltac_var coerce ist env locid + with Not_found -> anomaly "Detected as ltac var at interning time" + (* Interprets an identifier which must be fresh *) -let interp_ident ist id = - try match List.assoc id ist.lfun with +let coerce_to_ident env = function | VIntroPattern (IntroIdentifier id) -> id - | VConstr c when isVar c -> - (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *) - (* c is then expected not to belong to the proof context *) - (* would be checkable if env were known from interp_ident *) + | VConstr c when isVar c & not (is_variable env (destVar c)) -> + (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) destVar c - | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ - str ") should have been bound to an identifier") + | v -> raise (CannotCoerceTo "a fresh identifier") + +let interp_ident ist gl id = + let env = pf_env gl in + try try_interp_ltac_var (coerce_to_ident env) ist (Some env) (dloc,id) with Not_found -> id -let interp_hint_base ist s = - try match List.assoc (id_of_string s) ist.lfun with - | VIntroPattern (IntroIdentifier id) -> string_of_id id - | _ -> user_err_loc(loc,"", str "An ltac name (" ++ str s ++ - str ") should have been bound to a hint base name") - with Not_found -> s +(* Interprets an optional identifier which must be fresh *) +let interp_name ist gl = function + | Anonymous -> Anonymous + | Name id -> Name (interp_ident ist gl id) -let interp_intro_pattern_var ist id = - try match List.assoc id ist.lfun with +let coerce_to_intro_pattern env = function | VIntroPattern ipat -> ipat | VConstr c 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 *) + (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) + (* but also in "destruct H as (H,H')" *) IntroIdentifier (destVar c) - | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ - str ") should have been bound to an introduction pattern") + | v -> raise (CannotCoerceTo "an introduction pattern") + +let interp_intro_pattern_var ist env id = + try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env)(dloc,id) with Not_found -> IntroIdentifier id -let interp_int lfun (loc,id) = - try match List.assoc id lfun with +let coerce_to_hint_base = function + | VIntroPattern (IntroIdentifier id) -> string_of_id id + | _ -> raise (CannotCoerceTo "a hint base name") + +let interp_hint_base ist s = + try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s) + with Not_found -> s + +let coerce_to_int = function | VInteger n -> n - | _ -> user_err_loc(loc,"interp_int",str "should be bound to an integer") - with Not_found -> user_err_loc (loc,"interp_int",str "Unbound variable") + | v -> raise (CannotCoerceTo "an integer") + +let interp_int ist locid = + try try_interp_ltac_var coerce_to_int ist None locid + with Not_found -> user_err_loc(fst locid,"interp_int",str "Unbound variable") let interp_int_or_var ist = function - | ArgVar locid -> interp_int ist.lfun locid + | ArgVar locid -> interp_int ist locid | ArgArg n -> n let constr_of_value env = function @@ -1060,39 +1050,20 @@ let constr_of_value env = function | 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 +let coerce_to_hyp env = function | VConstr c when isVar c -> destVar c | VIntroPattern (IntroIdentifier id) when is_variable env id -> id - | _ -> raise Not_found - -(* Extract a variable from a value, if any *) -let id_of_Identifier = variable_of_value - -(* Extract a constr from a value, if any *) -let constr_of_VConstr = constr_of_value + | _ -> raise (CannotCoerceTo "a variable") (* Interprets a bound variable (especially an existing hypothesis) *) -let interp_hyp ist gl (loc,id) = +let interp_hyp ist gl (loc,id as locid) = + let env = pf_env gl in (* Look first in lfun for a value coercible to a variable *) - try - let v = List.assoc id ist.lfun in - try variable_of_value (pf_env gl) v - with Not_found -> - errorlabstrm "coerce_to_variable" - (str "Cannot coerce" ++ spc () ++ pr_value (pf_env gl) v ++ spc () ++ - str "to a variable") + try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid with Not_found -> (* Then look if bound in the proof context at calling time *) - if is_variable (pf_env gl) id then id - else - user_err_loc (loc,"eval_variable",pr_id id ++ str " not found") - -let interp_name ist = function - | Anonymous -> Anonymous - | Name id -> Name (interp_ident ist id) + if is_variable env id then id + else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found") let interp_clause_pattern ist gl (l,occl) = let rec check acc = function @@ -1105,28 +1076,53 @@ let interp_clause_pattern ist gl (l,occl) = in (l,check [] occl) (* Interprets a qualified name *) +let coerce_to_reference env v = + try match v with + | VConstr c -> global_of_constr c (* may raise Not_found *) + | _ -> raise Not_found + with Not_found -> raise (CannotCoerceTo "a reference") + let interp_reference ist env = function | ArgArg (_,r) -> r - | ArgVar (loc,id) -> coerce_to_reference env (List.assoc id ist.lfun) + | ArgVar locid -> + interp_ltac_var (coerce_to_reference env) ist (Some env) locid let pf_interp_reference ist gl = interp_reference ist (pf_env gl) +let coerce_to_inductive = function + | VConstr c when isInd c -> destInd c + | _ -> raise (CannotCoerceTo "an inductive type") + let interp_inductive ist = function | ArgArg r -> r - | ArgVar (_,id) -> coerce_to_inductive (List.assoc id ist.lfun) + | ArgVar locid -> interp_ltac_var coerce_to_inductive ist None locid + +let coerce_to_evaluable_ref env v = + let ev = match v with + | VConstr c when isConst c -> EvalConstRef (destConst c) + | VConstr c when isVar c -> EvalVarRef (destVar c) + | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) + -> EvalVarRef id + | _ -> raise (CannotCoerceTo "an evaluable reference") + in + if not (Tacred.is_evaluable env ev) then + raise (CannotCoerceTo "an evaluable reference") + else + ev let interp_evaluable ist env = function | ArgArg (r,Some (loc,id)) -> (* Maybe [id] has been introduced by Intro-like tactics *) (try match Environ.lookup_named id env with - | (_,Some _,_) -> EvalVarRef id - | _ -> error_not_evaluable (pr_id id) - with Not_found -> - match r with - | EvalConstRef _ -> r - | _ -> Pretype_errors.error_var_not_found_loc loc id) + | (_,Some _,_) -> EvalVarRef id + | _ -> error_not_evaluable (pr_id id) + with Not_found -> + match r with + | EvalConstRef _ -> r + | _ -> Pretype_errors.error_var_not_found_loc loc id) | ArgArg (r,None) -> r - | ArgVar (_,id) -> coerce_to_evaluable_ref env (List.assoc id ist.lfun) + | ArgVar locid -> + interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid (* Interprets an hypothesis name *) let interp_hyp_location ist gl ((occs,id),hl) = @@ -1172,8 +1168,6 @@ let retype_list sigma env lst = 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*) - let implicit_tactic = ref None let declare_implicit_tactic tac = implicit_tactic := Some tac @@ -1277,7 +1271,7 @@ let interp_pattern ist sigma env (l,c) = let pf_interp_pattern ist gl = interp_pattern ist (project gl) (pf_env gl) -let redexp_interp ist sigma env = function +let interp_red_expr ist sigma env = function | Unfold l -> Unfold (List.map (interp_unfold ist env) l) | Fold l -> Fold (List.map (interp_constr ist sigma env) l) | Cbv f -> Cbv (interp_flag ist env f) @@ -1286,11 +1280,11 @@ let redexp_interp ist sigma env = function | Simpl o -> Simpl (option_map (interp_pattern ist sigma env) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r -let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl) +let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl) let interp_may_eval f ist gl = function | ConstrEval (r,c) -> - let redexp = pf_redexp_interp ist gl r in + let redexp = pf_interp_red_expr ist gl r in pf_reduction_of_red_expr gl redexp (f ist gl c) | ConstrContext ((loc,s),c) -> (try @@ -1323,43 +1317,54 @@ let rec interp_message ist = function | [] -> mt() | MsgString s :: l -> pr_arg str s ++ interp_message ist l | MsgInt n :: l -> pr_arg int n ++ interp_message ist l - | MsgIdent (_,id) :: l -> + | MsgIdent (loc,id) :: l -> let v = try List.assoc id ist.lfun - with Not_found -> user_err_loc (loc,"",pr_id id ++ str " not found") in + with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found") in pr_arg message_of_value v ++ interp_message ist l let rec interp_message_nl ist = function | [] -> mt() | l -> interp_message ist l ++ fnl() -let rec interp_intro_pattern ist = function - | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist l) - | IntroIdentifier id -> interp_intro_pattern_var ist id +let rec interp_intro_pattern ist gl = function + | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l) + | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id | IntroWildcard | IntroAnonymous as x -> x -and interp_case_intro_pattern ist = - List.map (List.map (interp_intro_pattern ist)) +and interp_case_intro_pattern ist gl = + List.map (List.map (interp_intro_pattern ist gl)) (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) +let coerce_to_quantified_hypothesis = function + | VInteger n -> AnonHyp n + | VIntroPattern (IntroIdentifier id) -> NamedHyp id + | v -> raise (CannotCoerceTo "a quantified hypothesis") + let interp_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n | NamedHyp id -> - try match List.assoc id ist.lfun with - | VInteger n -> AnonHyp n - | VIntroPattern (IntroIdentifier id) -> NamedHyp id - | _ -> raise Not_found - with Not_found -> NamedHyp id + try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) + with Not_found + | Stdpp.Exc_located (_, UserError _) | UserError _ (*Compat provisoire*) + -> NamedHyp id (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) +let coerce_to_decl_or_quant_hyp env = function + | VInteger n -> AnonHyp n + | v -> + try NamedHyp (coerce_to_hyp env v) + with CannotCoerceTo _ -> + raise (CannotCoerceTo "a declared or quantified hypothesis") + let interp_declared_or_quantified_hypothesis ist gl = function | AnonHyp n -> AnonHyp n | NamedHyp id -> - try match List.assoc id ist.lfun with - | VInteger n -> AnonHyp n - | v -> NamedHyp (variable_of_value (pf_env gl) v) + let env = pf_env gl in + try try_interp_ltac_var + (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id) with Not_found -> NamedHyp id let interp_induction_arg ist gl = function @@ -1395,7 +1400,7 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg a -> interp_tacarg ist gl a (* Delayed evaluation *) - | t -> VTactic (dummy_loc,eval_tactic ist t) + | t -> VTactic (dloc,eval_tactic ist t) in check_for_interrupt (); match ist.debug with @@ -1437,7 +1442,7 @@ and interp_tacarg ist gl = function | TacVoid -> VVoid | Reference r -> interp_ltac_reference false false ist gl r | Integer n -> VInteger n - | IntroPattern ipat -> VIntroPattern ipat + | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat) | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c) | MetaIdArg (loc,id) -> assert false | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r @@ -1467,7 +1472,7 @@ and interp_tacarg ist gl = function else if tg = "constr" then VConstr (constr_out t) else - anomaly_loc (loc, "Tacinterp.val_interp", + anomaly_loc (dloc, "Tacinterp.val_interp", (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) (* Interprets an application node *) @@ -1541,10 +1546,10 @@ and interp_letin ist gl = function start_proof id (Local,Proof Lemma) ndc typ (fun _ _ -> ()); by t; let (_,({const_entry_body = pft},_,_)) = cook_proof () in - delete_proof (dummy_loc,id); + delete_proof (dloc,id); pft with | NotTactic -> - delete_proof (dummy_loc,id); + delete_proof (dloc,id); errorlabstrm "Tacinterp.interp_letin" (str "Term or fully applied tactic expected in Let") in (id,VConstr (mkCast (csr,DEFAULTcast, typ)))::(interp_letin ist gl tl) @@ -1599,7 +1604,7 @@ and interp_match_context ist g lz lr lmr = 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) + (read_match_rule (fst (constr_list ist env)) lmr) (* Tries to match the hypotheses in a Match Context *) and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = @@ -1629,7 +1634,7 @@ and interp_external loc ist gl com req la = interp_tacarg ist gl (System.connect f g com) (* Interprets extended tactic generic arguments *) -and interp_genarg ist goal x = +and interp_genarg ist gl x = match genarg_tag x with | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x) | IntArgType -> in_gen wit_int (out_gen globwit_int x) @@ -1642,49 +1647,49 @@ and interp_genarg ist goal x = in_gen wit_pre_ident (out_gen globwit_pre_ident x) | IntroPatternArgType -> in_gen wit_intro_pattern - (interp_intro_pattern ist (out_gen globwit_intro_pattern x)) + (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) | IdentArgType -> - in_gen wit_ident (interp_ident ist (out_gen globwit_ident x)) + in_gen wit_ident (interp_ident ist gl (out_gen globwit_ident x)) | VarArgType -> - in_gen wit_var (interp_hyp ist goal (out_gen globwit_var x)) + in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x)) | RefArgType -> - in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x)) + in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x)) | SortArgType -> in_gen wit_sort (destSort - (pf_interp_constr ist goal - (RSort (dummy_loc,out_gen globwit_sort x), None))) + (pf_interp_constr ist gl + (RSort (dloc,out_gen globwit_sort x), None))) | ConstrArgType -> - in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x)) + in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x)) | ConstrMayEvalArgType -> - in_gen wit_constr_may_eval (interp_constr_may_eval ist goal (out_gen globwit_constr_may_eval x)) + in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) | QuantHypArgType -> in_gen wit_quant_hyp - (interp_declared_or_quantified_hypothesis ist goal + (interp_declared_or_quantified_hypothesis ist gl (out_gen globwit_quant_hyp x)) | RedExprArgType -> - in_gen wit_red_expr (pf_redexp_interp ist goal (out_gen globwit_red_expr x)) + in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x)) | OpenConstrArgType casted -> in_gen (wit_open_constr_gen casted) - (pf_interp_open_constr casted ist goal + (pf_interp_open_constr casted ist gl (snd (out_gen (globwit_open_constr_gen casted) x))) | ConstrWithBindingsArgType -> in_gen wit_constr_with_bindings - (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x)) + (interp_constr_with_bindings ist gl (out_gen globwit_constr_with_bindings x)) | BindingsArgType -> in_gen wit_bindings - (interp_bindings ist goal (out_gen globwit_bindings x)) - | List0ArgType _ -> app_list0 (interp_genarg ist goal) x - | List1ArgType _ -> app_list1 (interp_genarg ist goal) x - | OptArgType _ -> app_opt (interp_genarg ist goal) x - | PairArgType _ -> app_pair (interp_genarg ist goal) (interp_genarg ist goal) x + (interp_bindings ist gl (out_gen globwit_bindings x)) + | List0ArgType _ -> app_list0 (interp_genarg ist gl) x + | List1ArgType _ -> app_list1 (interp_genarg ist gl) x + | OptArgType _ -> app_opt (interp_genarg ist gl) x + | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x | ExtraArgType s -> match tactic_genarg_level s with | Some n -> (* Special treatment of tactic arguments *) in_gen (wit_tactic n) (out_gen (globwit_tactic n) x) | None -> - lookup_interp_genarg s ist goal x + lookup_interp_genarg s ist gl x (* Interprets the Match expressions *) and interp_match ist g lz constr lmr = @@ -1712,31 +1717,31 @@ and interp_match ist g lz constr lmr = | _ -> 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 + let csr = interp_ltac_constr ist g constr in + let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in apply_match ist csr ilr +(* Interprets tactic expressions : returns a "constr" *) +and interp_ltac_constr ist gl e = + try constr_of_value (pf_env gl) (val_interp ist gl e) + with Not_found -> + errorlabstrm "" (str "Must evaluate to a term") + (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac gl = try tactic_of_value (val_interp ist gl tac) gl - with | NotTactic -> - errorlabstrm "Tacinterp.interp_tactic" (str - "Must be a command or must give a tactic value") + with NotTactic -> + errorlabstrm "" (str "Must be a command or must give a tactic value") (* Interprets a primitive tactic *) and interp_atomic ist gl = function (* Basic tactics *) | TacIntroPattern l -> - h_intro_patterns (List.map (interp_intro_pattern ist) l) + h_intro_patterns (List.map (interp_intro_pattern ist gl) l) | TacIntrosUntil hyp -> h_intros_until (interp_quantified_hypothesis ist hyp) | TacIntroMove (ido,ido') -> - h_intro_move (option_map (interp_ident ist) ido) + h_intro_move (option_map (interp_ident ist gl) ido) (option_map (interp_hyp ist gl) ido') | TacAssumption -> h_assumption | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) @@ -1748,25 +1753,25 @@ and interp_atomic ist gl = function | TacElimType c -> h_elim_type (pf_interp_type ist gl c) | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb) | TacCaseType c -> h_case_type (pf_interp_type ist gl c) - | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist) idopt) n + | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist gl) idopt) n | TacMutualFix (id,n,l) -> - let f (id,n,c) = (interp_ident ist id,n,pf_interp_type ist gl c) in - h_mutual_fix (interp_ident ist id) n (List.map f l) - | TacCofix idopt -> h_cofix (option_map (interp_ident ist) idopt) + let f (id,n,c) = (interp_ident ist gl id,n,pf_interp_type ist gl c) in + h_mutual_fix (interp_ident ist gl id) n (List.map f l) + | TacCofix idopt -> h_cofix (option_map (interp_ident ist gl) idopt) | TacMutualCofix (id,l) -> - let f (id,c) = (interp_ident ist id,pf_interp_type ist gl c) in - h_mutual_cofix (interp_ident ist id) (List.map f l) + let f (id,c) = (interp_ident ist gl id,pf_interp_type ist gl c) in + h_mutual_cofix (interp_ident ist gl id) (List.map f l) | TacCut c -> h_cut (pf_interp_type ist gl c) | TacAssert (t,ipat,c) -> let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in abstract_tactic (TacAssert (t,ipat,c)) (Tactics.forward (option_map (interp_tactic ist) t) - (interp_intro_pattern ist ipat) c) + (interp_intro_pattern ist gl ipat) 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 + h_let_tac (interp_name ist gl na) (pf_interp_constr ist gl c) clp (* | TacInstantiate (n,c,idh) -> h_instantiate n (fst c) (* pf_interp_constr ist gl c *) (match idh with @@ -1794,13 +1799,13 @@ and interp_atomic ist gl = function | TacNewInduction (lc,cbo,ids) -> h_new_induction (List.map (interp_induction_arg ist gl) lc) (option_map (interp_constr_with_bindings ist gl) cbo) - (interp_intro_pattern ist ids) + (interp_intro_pattern ist gl ids) | TacSimpleDestruct h -> h_simple_destruct (interp_quantified_hypothesis ist h) | TacNewDestruct (c,cbo,ids) -> h_new_destruct (List.map (interp_induction_arg ist gl) c) (option_map (interp_constr_with_bindings ist gl) cbo) - (interp_intro_pattern ist ids) + (interp_intro_pattern ist gl ids) | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -1820,7 +1825,7 @@ and interp_atomic ist gl = function | TacMove (dep,id1,id2) -> h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2) | TacRename (id1,id2) -> - h_rename (interp_hyp ist gl id1) (interp_ident ist (snd id2)) + h_rename (interp_hyp ist gl id1) (interp_ident ist gl (snd id2)) (* Constructors *) | TacLeft bl -> h_left (interp_bindings ist gl bl) @@ -1834,7 +1839,7 @@ and interp_atomic ist gl = function (* Conversion *) | TacReduce (r,cl) -> - h_reduce (pf_redexp_interp ist gl r) (interp_clause ist gl cl) + h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl) | TacChange (occl,c,cl) -> h_change (option_map (pf_interp_pattern ist gl) occl) (pf_interp_constr ist gl c) (interp_clause ist gl cl) @@ -1851,11 +1856,11 @@ and interp_atomic ist gl = function (interp_clause ist gl cl) | TacInversion (DepInversion (k,c,ids),hyp) -> Inv.dinv k (option_map (pf_interp_constr ist gl) c) - (interp_intro_pattern ist ids) + (interp_intro_pattern ist gl ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Inv.inv_clause k - (interp_intro_pattern ist ids) + (interp_intro_pattern ist gl ids) (List.map (interp_hyp ist gl) idl) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (InversionUsing (c,idl),hyp) -> @@ -1874,9 +1879,11 @@ and interp_atomic ist gl = function | PreIdentArgType -> failwith "pre-identifiers cannot be bound" | IntroPatternArgType -> - VIntroPattern (out_gen globwit_intro_pattern x) + VIntroPattern + (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) | IdentArgType -> - VIntroPattern (IntroIdentifier (out_gen globwit_ident x)) + VIntroPattern + (IntroIdentifier (interp_ident ist gl (out_gen globwit_ident x))) | VarArgType -> VConstr (mkVar (interp_hyp ist gl (out_gen globwit_var x))) | RefArgType -> @@ -1907,6 +1914,10 @@ and interp_atomic ist gl = function try tactic_of_value v gl with NotTactic -> user_err_loc (loc,"",str "not a tactic") +let make_empty_glob_sign () = + { ltacvars = ([],[]); ltacrecvars = []; + gsigma = Evd.empty; genv = Global.env() } + (* Initial call for interpretation *) let interp_tac_gen lfun debug t gl = interp_tactic { lfun=lfun; debug=debug } @@ -1918,6 +1929,10 @@ let eval_tactic t = interp_tactic { lfun=[]; debug=get_debug() } t let interp t = interp_tac_gen [] (get_debug()) t +let eval_ltac_constr gl t = + interp_ltac_constr { lfun=[]; debug=get_debug() } gl + (intern_tactic (make_empty_glob_sign ()) t ) + (* Hides interpretation for pretty-print *) let hide_interp t ot gl = let ist = { ltacvars = ([],[]); ltacrecvars = []; @@ -1965,7 +1980,7 @@ 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_located f (_loc,id) = (dloc,f id) let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) @@ -2107,13 +2122,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* For extensions *) | TacExtend (_loc,opn,l) -> - TacExtend (loc,opn,List.map (subst_genarg subst) l) + TacExtend (dloc,opn,List.map (subst_genarg subst) l) | TacAlias (_,s,l,(dir,body)) -> - TacAlias (loc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l, + TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l, (dir,subst_tactic subst body)) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (loc, subst_atomic subst t) + | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetRecIn (lrc,u) -> let lrc = List.map (fun (n,b) -> (n,subst_tactic_fun subst b)) lrc in @@ -2158,7 +2173,7 @@ and subst_tacarg subst = function | TacDynamic(_,t) as x -> (match tag t with | "tactic" | "value" | "constr" -> x - | s -> anomaly_loc (loc, "Tacinterp.val_interp", + | s -> anomaly_loc (dloc, "Tacinterp.val_interp", str "Unknown dynamic: <" ++ str s ++ str ">")) (* Reads the rules of a Match Context or a Match *) @@ -2281,10 +2296,6 @@ let make_absolute_name (loc,id) = str "There is already an Ltac named " ++ pr_id id); kn -let make_empty_glob_sign () = - { ltacvars = ([],[]); ltacrecvars = []; - gsigma = Evd.empty; genv = Global.env() } - let add_tacdef isrec tacl = (* let isrec = if !Options.p1 then isrec else true in*) let rfun = List.map (fun ((loc,id as locid),_) -> (id,make_absolute_name locid)) tacl in @@ -2311,10 +2322,10 @@ let glob_tactic_env l env x = { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x -let interp_redexp env evc r = +let interp_redexp env sigma r = let ist = { lfun=[]; debug=get_debug () } in - let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = evc } in - redexp_interp ist evc env (intern_redexp gist r) + let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in + interp_red_expr ist sigma env (intern_red_expr gist r) (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 68f6f6ac..7c0180a6 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tacinterp.mli 7841 2006-01-11 11:24:54Z herbelin $ i*) +(*i $Id: tacinterp.mli 8975 2006-06-23 08:52:53Z herbelin $ i*) (*i*) open Dyn open Pp +open Util open Names open Proof_type open Tacmach @@ -20,6 +21,7 @@ open Tacexpr open Genarg open Topconstr open Mod_subst +open Redexpr (*i*) (* Values for interpretation *) @@ -39,12 +41,6 @@ and interp_sign = { lfun : (identifier * value) list; debug : debug_info } -(* Gives the identifier corresponding to an Identifier [tactic_arg] *) -val id_of_Identifier : Environ.env -> value -> identifier - -(* Gives the constr corresponding to a Constr [value] *) -val constr_of_VConstr : Environ.env -> value -> constr - (* Transforms an id into a constr if possible *) val constr_of_id : Environ.env -> identifier -> constr @@ -103,16 +99,18 @@ val subst_rawconstr_and_expr : (* Interprets any expression *) val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value +(* Interprets an expression that evaluates to a constr *) +val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> + constr + (* Interprets redexp arguments *) -val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr - -> Redexpr.red_expr +val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr (* Interprets tactic expressions *) val interp_tac_gen : (identifier * value) list -> debug_info -> raw_tactic_expr -> tactic -val interp_hyp : interp_sign -> goal sigma -> - identifier Util.located -> identifier +val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier (* Initial call for interpretation *) val glob_tactic : raw_tactic_expr -> glob_tactic_expr @@ -123,6 +121,8 @@ val eval_tactic : glob_tactic_expr -> tactic val interp : raw_tactic_expr -> tactic +val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr + val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr (* Hides interpretation for pretty-print *) diff --git a/test-suite/failure/inductive1.v b/test-suite/failure/inductive1.v new file mode 100644 index 00000000..3b57d919 --- /dev/null +++ b/test-suite/failure/inductive1.v @@ -0,0 +1,4 @@ +(* A check that sort-polymorphic product is not set too low *) + +Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. +Check (fun (A:Type) (B:Prop) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive2.v b/test-suite/failure/inductive2.v new file mode 100644 index 00000000..b77474be --- /dev/null +++ b/test-suite/failure/inductive2.v @@ -0,0 +1,4 @@ +(* A check that sort-polymorphic product is not set too low *) + +Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. +Check (fun (A:Prop) (B:Type) => (prod A B : Prop)). diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v new file mode 100644 index 00000000..e5a4e1b6 --- /dev/null +++ b/test-suite/failure/inductive3.v @@ -0,0 +1,5 @@ +(* Check that the nested inductive types positivity check avoids recursively + non uniform parameters (at least if these parameters break positivity) *) + +Inductive t (A:Type) : Type := c : t (A -> A) -> t A. +Inductive u : Type := d : u | e : t u -> u. diff --git a/test-suite/success/CanonicalStructure.v b/test-suite/success/CanonicalStructure.v new file mode 100644 index 00000000..003810cc --- /dev/null +++ b/test-suite/success/CanonicalStructure.v @@ -0,0 +1,7 @@ +(* Bug #1172 *) + +Structure foo : Type := Foo { + A : Set; Aopt := option A; unopt : Aopt -> A +}. + +Canonical Structure unopt_nat := @Foo nat (fun _ => O). diff --git a/test-suite/success/Case18.v b/test-suite/success/Case18.v index a57fe413..91c80e88 100644 --- a/test-suite/success/Case18.v +++ b/test-suite/success/Case18.v @@ -3,9 +3,12 @@ Definition g x := match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end. -Eval compute in (g ((1,2),(3,4))). -(* (1,3) *) +Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)). -Eval compute in (g ((1,4),(3,2))). -(* (1,2) *) +Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)). +Fixpoint max (n m:nat) {struct m} : nat := + match n, m with + | S n', S m' => S (max n' m') + | 0, p | p, 0 => p + end. diff --git a/test-suite/success/Case19.v b/test-suite/success/Case19.v new file mode 100644 index 00000000..9a6ed71a --- /dev/null +++ b/test-suite/success/Case19.v @@ -0,0 +1,8 @@ +(* This used to fail in Coq version 8.1 beta due to a non variable + universe (issued by the inductive sort-polymorphism) being sent by + pretyping to the kernel (bug #1182) *) + +Variable T : Type. +Variable x : nat*nat. + +Check let (_, _) := x in sigT (fun _ : T => nat). diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index 939d06c7..1c3e56f2 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -29,6 +29,18 @@ intros n m. functional induction ftest n m; auto. Qed. +Lemma test2 : forall m n, ~ 2 = ftest n m. +Proof. +intros n m;intro H. +functional inversion H ftest. +Qed. + +Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0) \/ n <> 0. +Proof. +functional inversion 1 ftest;auto. +Qed. + + Require Import Arith. Lemma test11 : forall m : nat, ftest 0 m <= 2. intros m. @@ -112,7 +124,8 @@ Function iseven (n : nat) : bool := | S (S m) => iseven m | _ => false end. - + + Function funex (n : nat) : nat := match iseven n with | true => n @@ -122,6 +135,7 @@ Function funex (n : nat) : nat := end end. + Function nat_equal_bool (n m : nat) {struct n} : bool := match n with | O => match m with @@ -151,7 +165,6 @@ Qed. (* reuse this lemma as a scheme:*) - Function nested_lam (n : nat) : nat -> nat := match n with | O => fun m : nat => 0 @@ -184,7 +197,6 @@ auto with arith. auto with arith. Qed. - Function plus_x_not_five'' (n m : nat) {struct n} : nat := let x := nat_equal_bool m 5 in let y := 0 in @@ -206,7 +218,7 @@ Qed. Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true. intros n m. functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto. -rewrite <- hyp in H1; simpl in H1;tauto. +rewrite <- hyp in y; simpl in y;tauto. inversion hyp. Qed. @@ -280,14 +292,14 @@ destruct n. tauto. destruct n. inversion istr. destruct n. inversion istr. destruct n. tauto. -simpl in *. inversion H1. +simpl in *. inversion H0. Qed. Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n). intros n. functional induction isononeorfour n; intros m istr; inversion istr. apply istrue0. -rewrite H in H0; simpl in H0;tauto. +rewrite H in y; simpl in y;tauto. Qed. Function ftest4 (n m : nat) : nat := @@ -353,7 +365,7 @@ Function ftest2 (n m : nat) {struct n} : nat := | S p => ftest2 p m end. -Lemma test2 : forall n m : nat, ftest2 n m <= 2. +Lemma test2' : forall n m : nat, ftest2 n m <= 2. intros n m. functional induction ftest2 n m; simpl in |- *; intros; auto. Qed. @@ -367,7 +379,7 @@ Function ftest3 (n m : nat) {struct n} : nat := end end. -Lemma test3 : forall n m : nat, ftest3 n m <= 2. +Lemma test3' : forall n m : nat, ftest3 n m <= 2. intros n m. functional induction ftest3 n m. intros. @@ -442,10 +454,52 @@ intros n m. functional induction ftest6 n m; simpl in |- *; auto. Qed. +(* Some tests with modules *) +Module M. +Function test_m (n:nat) : nat := + match n with + | 0 => 0 + | S n => S (S (test_m n)) + end. +Lemma test_m_is_double : forall n, div2 (test_m n) = n. +Proof. +intros n. +functional induction (test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. +End M. +(* We redefine a new Function with the same name *) +Function test_m (n:nat) : nat := + pred n. + +Lemma test_m_is_pred : forall n, test_m n = pred n. +Proof. +intro n. +functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) +reflexivity. +Qed. +(* Checks if the dot notation are correctly treated in infos *) +Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n. +intro n. +(* here we should apply M.test_m_ind *) +functional induction (M.test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. +Import M. +(* Now test_m is the one which defines double *) +Lemma test_m_is_double : forall n, div2 (M.test_m n) = n. +intro n. +(* here we should apply M.test_m_ind *) +functional induction (test_m n). +reflexivity. +simpl;rewrite IHn0;reflexivity. +Qed. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 425528ee..786ade0e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -9,7 +9,7 @@ (* Finite map library. *) -(* $Id: FMapAVL.v 8899 2006-06-06 11:09:43Z jforest $ *) +(* $Id: FMapAVL.v 8985 2006-06-23 16:12:45Z jforest $ *) (** This module implements map using AVL trees. It follows the implementation from Ocaml's standard library. *) @@ -512,7 +512,7 @@ Proof. (* LT *) inv avl. rewrite bal_in; auto. - rewrite (IHt H1); intuition_in. + rewrite (IHt H0); intuition_in. (* EQ *) inv avl. firstorder_in. @@ -520,7 +520,7 @@ Proof. (* GT *) inv avl. rewrite bal_in; auto. - rewrite (IHt H2); intuition_in. + rewrite (IHt H1); intuition_in. Qed. Lemma add_bst : forall elt (m:t elt) x e, bst m -> avl m -> bst (add x e m). @@ -530,13 +530,13 @@ Proof. (* lt_tree -> lt_tree (add ...) *) red; red in H4. intros. - rewrite (add_in x y0 e H) in H1. + rewrite (add_in x y0 e H) in H0. intuition. eauto. (* gt_tree -> gt_tree (add ...) *) - red; red in H5. + red; red in H4. intros. - rewrite (add_in x y0 e H6) in H1. + rewrite (add_in x y0 e H5) in H0. intuition. apply lt_eq with x; auto. Qed. @@ -591,9 +591,9 @@ Proof. inversion_clear H. destruct (IHp lh); auto. split; simpl in *. - rewrite_all H0. simpl in *. + rewrite_all e1. simpl in *. apply bal_avl; subst;auto; omega_max. - rewrite_all H0;simpl in *;omega_bal. + rewrite_all e1;simpl in *;omega_bal. Qed. Lemma remove_min_avl : forall elt (l:t elt) x e r h, avl (Node l x e r h) -> @@ -610,13 +610,13 @@ Proof. intuition_in. (* l = Node *) inversion_clear H. - generalize (remove_min_avl H1). + generalize (remove_min_avl H0). - rewrite_all H0; simpl; intros. + rewrite_all e1; simpl; intros. rewrite bal_in; auto. - generalize (IHp lh y H1). + generalize (IHp lh y H0). intuition. - inversion_clear H8; intuition. + inversion_clear H7; intuition. Qed. Lemma remove_min_mapsto : forall elt (l:t elt) x e r h y e', avl (Node l x e r h) -> @@ -628,14 +628,14 @@ Proof. intuition_in; subst; auto. (* l = Node *) inversion_clear H. - generalize (remove_min_avl H1). - rewrite_all H0; simpl; intros. + generalize (remove_min_avl H0). + rewrite_all e1; simpl; intros. rewrite bal_mapsto; auto; unfold create. simpl in *;destruct (IHp lh y e'). auto. intuition. - inversion_clear H3; intuition. - inversion_clear H10; intuition. + inversion_clear H2; intuition. + inversion_clear H9; intuition. Qed. Lemma remove_min_bst : forall elt (l:t elt) x e r h, @@ -643,14 +643,14 @@ Lemma remove_min_bst : forall elt (l:t elt) x e r h, Proof. intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. - inversion_clear H; inversion_clear H1. + inversion_clear H; inversion_clear H0. apply bal_bst; auto. - rewrite_all H0;simpl in *;firstorder. + rewrite_all e1;simpl in *;firstorder. intro; intros. generalize (remove_min_in y H). - rewrite_all H0; simpl in *. + rewrite_all e1; simpl in *. destruct 1. - apply H4; intuition. + apply H3; intuition. Qed. Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h, @@ -659,15 +659,15 @@ Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h, Proof. intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros. inv bst; auto. - inversion_clear H; inversion_clear H1. + inversion_clear H; inversion_clear H0. intro; intro. - rewrite_all H0;simpl in *. - generalize (IHp lh H2 H); clear H7 H8 IHp. + rewrite_all e1;simpl in *. + generalize (IHp lh H1 H); clear H7 H6 IHp. generalize (remove_min_avl H). generalize (remove_min_in (fst m) H). - rewrite H0; simpl; intros. - rewrite (bal_in x e y H8 H6) in H1. - destruct H7. + rewrite e1; simpl; intros. + rewrite (bal_in x e y H7 H5) in H0. + destruct H6. firstorder. apply lt_eq with x; auto. apply X.lt_trans with x; auto. @@ -696,11 +696,11 @@ Lemma merge_avl_1 : forall elt (s1 s2:t elt), avl s1 -> avl s2 -> Proof. intros elt s1 s2; functional induction (merge s1 s2); simpl in *; intros. split; auto; avl_nns; omega_max. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. split; auto; avl_nns; simpl in *; omega_max. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. generalize (remove_min_avl_1 H0). - rewrite H2; simpl;destruct 1. + rewrite e3; simpl;destruct 1. split. apply bal_avl; auto. simpl; omega_max. @@ -719,13 +719,13 @@ Proof. intros elt s1 s2; functional induction (merge s1 s2);intros. intuition_in. intuition_in. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. (* rewrite H_eq_2; rewrite H_eq_2 in H_eq_1; clear H_eq_2. *) - replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto]. + replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto]. rewrite bal_in; auto. - generalize (remove_min_avl H4); rewrite H2; simpl; auto. - generalize (remove_min_in y H4); rewrite H2; simpl; intro. - rewrite H1; intuition. + generalize (remove_min_avl H2); rewrite e3; simpl; auto. + generalize (remove_min_in y0 H2); rewrite e3; simpl; intro. + rewrite H3; intuition. Qed. Lemma merge_mapsto : forall elt (s1 s2:t elt) y e, bst s1 -> avl s1 -> bst s2 -> avl s2 -> @@ -734,13 +734,13 @@ Proof. intros elt s1 s2; functional induction (@merge elt s1 s2); intros. intuition_in. intuition_in. - destruct s1;try contradiction;clear H1. - replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto]. + destruct s1;try contradiction;clear y. + replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto]. rewrite bal_mapsto; auto; unfold create. - generalize (remove_min_avl H4); rewrite H2; simpl; auto. - generalize (remove_min_mapsto y e0 H4); rewrite H2; simpl; intro. - rewrite H1; intuition (try subst; auto). - inversion_clear H1; intuition. + generalize (remove_min_avl H2); rewrite e3; simpl; auto. + generalize (remove_min_mapsto y0 e H2); rewrite e3; simpl; intro. + rewrite H3; intuition (try subst; auto). + inversion_clear H3; intuition. Qed. Lemma merge_bst : forall elt (s1 s2:t elt), bst s1 -> avl s1 -> bst s2 -> avl s2 -> @@ -751,13 +751,13 @@ Proof. apply bal_bst; auto. destruct s1;try contradiction. - generalize (remove_min_bst H3); rewrite H2; simpl in *; auto. + generalize (remove_min_bst H1); rewrite e3; simpl in *; auto. destruct s1;try contradiction. intro; intro. - apply H5; auto. - generalize (remove_min_in x H4); rewrite H2; simpl; intuition. + apply H3; auto. + generalize (remove_min_in x H2); rewrite e3; simpl; intuition. destruct s1;try contradiction. - generalize (remove_min_gt_tree H3); rewrite H2; simpl; auto. + generalize (remove_min_gt_tree H1); rewrite e3; simpl; auto. Qed. (** * Deletion *) @@ -779,18 +779,18 @@ Proof. split; auto; omega_max. (* LT *) inv avl. - destruct (IHt H1). + destruct (IHt H0). split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) inv avl. - generalize (merge_avl_1 H1 H2 H3). + generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. - destruct (IHt H2). + destruct (IHt H1). split. apply bal_avl; auto. omega_max. @@ -809,17 +809,17 @@ Proof. intros elt s x; functional induction (@remove elt x s); simpl; intros. intuition_in. (* LT *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e1. rewrite bal_in; auto. - generalize (IHt y0 H1); intuition; [ order | order | intuition_in ]. + generalize (IHt y0 H0); intuition; [ order | order | intuition_in ]. (* EQ *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e1. rewrite merge_in; intuition; [ order | order | intuition_in ]. elim H9; eauto. (* GT *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e1. rewrite bal_in; auto. - generalize (IHt y0 H6); intuition; [ order | order | intuition_in ]. + generalize (IHt y0 H5); intuition; [ order | order | intuition_in ]. Qed. Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s). @@ -830,7 +830,7 @@ Proof. inv avl; inv bst. apply bal_bst; auto. intro; intro. - rewrite (remove_in x y0 H1) in H; auto. + rewrite (remove_in x y0 H0) in H; auto. destruct H; eauto. (* EQ *) inv avl; inv bst. @@ -839,7 +839,7 @@ Proof. inv avl; inv bst. apply bal_bst; auto. intro; intro. - rewrite (remove_in x y0 H6) in H; auto. + rewrite (remove_in x y0 H5) in H; auto. destruct H; eauto. Qed. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index c671ba82..067f5a3e 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 8899 2006-06-06 11:09:43Z jforest $ *) +(* $Id: FMapList.v 9035 2006-07-09 15:42:09Z herbelin $ *) (** * Finite map library *) @@ -20,8 +20,6 @@ Require Import FMapInterface. Set Implicit Arguments. Unset Strict Implicit. -Arguments Scope list [type_scope]. - Module Raw (X:OrderedType). Module E := X. @@ -161,14 +159,14 @@ Proof. inversion 2. inversion_clear 2. - clear H0;compute in H1; destruct H1;order. - clear H0;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H1)); compute; order. + clear e1;compute in H0; destruct H0;order. + clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. - clear H0;inversion_clear 2. + clear e1;inversion_clear 2. compute in H0; destruct H0; intuition congruence. generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. - clear H0; do 2 inversion_clear 1; auto. + clear e1; do 2 inversion_clear 1; auto. compute in H2; destruct H2; order. Qed. @@ -197,7 +195,7 @@ Lemma add_2 : forall m x y e e', Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. - functional induction (add x e' m) ;simpl;auto; clear H0. + functional induction (add x e' m) ;simpl;auto; clear e0. subst;auto. intros y' e'' eqky'; inversion_clear 1; destruct H0; simpl in *. @@ -214,9 +212,9 @@ Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl; intros. apply (In_inv_3 H0); compute; auto. - apply (In_inv_3 H1); compute; auto. - constructor 2; apply (In_inv_3 H1); compute; auto. - inversion_clear H1; auto. + apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. + inversion_clear H0; auto. Qed. @@ -265,13 +263,13 @@ Proof. red; inversion 1; inversion H1. apply Sort_Inf_NotIn with x0; auto. - clear H0;constructor; compute; order. + clear e0;constructor; compute; order. - clear H0;inversion_clear Hm. + clear e0;inversion_clear Hm. apply Sort_Inf_NotIn with x0; auto. apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. - clear H0;inversion_clear Hm. + clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. intros (x1,abs). inversion_clear abs. @@ -393,7 +391,7 @@ Proof. assert (cmp_e_e':cmp e e' = true). - apply H2 with x; auto. + apply H1 with x; auto. rewrite cmp_e_e'; simpl. apply IHb; auto. inversion_clear Hm; auto. @@ -402,7 +400,7 @@ Proof. destruct (H0 k). assert (In k ((x,e) ::l)). destruct H as (e'', hyp); exists e''; auto. - destruct (In_inv (H1 H4)); auto. + destruct (In_inv (H2 H4)); auto. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. @@ -415,10 +413,10 @@ Proof. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. - apply H2 with k; destruct (eq_dec x k); auto. + apply H1 with k; destruct (eq_dec x k); auto. - destruct (X.compare x x'); try contradiction;clear H2. + destruct (X.compare x x'); try contradiction; clear y. destruct (H0 x). assert (In x ((x',e')::l')). apply H; auto. @@ -492,16 +490,16 @@ Proof. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. - destruct (IHb H1 H4 H7). + destruct (IHb H2 H4 H7). inversion_clear H0. destruct H9; simpl in *; subst. - inversion_clear H2. + inversion_clear H1. destruct H9; simpl in *; subst; auto. elim (Sort_Inf_NotIn H4 H5). exists e'0; apply MapsTo_eq with k; auto; order. - inversion_clear H2. + inversion_clear H1. destruct H0; simpl in *; subst; auto. - elim (Sort_Inf_NotIn H1 H3). + elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. apply H8 with k; auto. Qed. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 3a91b868..890485a8 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapWeakList.v 8899 2006-06-06 11:09:43Z jforest $ *) +(* $Id: FMapWeakList.v 8985 2006-06-23 16:12:45Z jforest $ *) (** * Finite map library *) @@ -104,8 +104,8 @@ Proof. inversion belong1. inversion H. inversion_clear NoDup. inversion_clear belong1. - inversion_clear H2. - compute in H3; destruct H3. + inversion_clear H1. + compute in H2; destruct H2. contradiction. apply IHb; auto. exists x0; auto. @@ -144,11 +144,11 @@ Proof. inversion 2. do 2 inversion_clear 1. - compute in H3; destruct H3; subst; trivial. + compute in H2; destruct H2; subst; trivial. elim H; apply InA_eqk with (x,e); auto. do 2 inversion_clear 1; auto. - compute in H3; destruct H3; elim _x; auto. + compute in H2; destruct H2; elim _x; auto. Qed. (* Not part of the exported specifications, used later for [combine]. *) @@ -184,7 +184,7 @@ Proof. intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl;auto. intros y' e'' eqky'; inversion_clear 1. - destruct H1; simpl in *. + destruct H0; simpl in *. elim eqky'; apply X.eq_trans with k'; auto. auto. intros y' e'' eqky'; inversion_clear 1; intuition. @@ -196,7 +196,7 @@ Proof. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl;auto. intros; apply (In_inv_3 H0); auto. - constructor 2; apply (In_inv_3 H1); auto. + constructor 2; apply (In_inv_3 H0); auto. inversion_clear 2; auto. Qed. @@ -208,8 +208,8 @@ Proof. inversion_clear 2. compute in H1; elim H; auto. inversion H1. - constructor 2; inversion_clear H1; auto. - compute in H2; elim H; auto. + constructor 2; inversion_clear H0; auto. + compute in H1; elim H; auto. inversion_clear 2; auto. Qed. @@ -272,17 +272,17 @@ Proof. inversion_clear Hm. subst. - swap H1. - destruct H3 as (e,H3); unfold PX.MapsTo in H3. + swap H0. + destruct H2 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. intro H2. destruct H2 as (e,H2); inversion_clear H2. - compute in H1; destruct H1. + compute in H0; destruct H0. elim _x; apply X.eq_trans with y; auto. inversion_clear Hm. - elim (IHt0 H3 H). + elim (IHt0 H2 H). exists e; auto. Qed. @@ -292,7 +292,7 @@ Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (remove x m);auto. inversion_clear 3; auto. - compute in H2; destruct H2. + compute in H1; destruct H1. elim H; apply X.eq_trans with k'; auto. inversion_clear 1; inversion_clear 2; auto. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index b385f50e..5b09945b 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -12,7 +12,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetAVL.v 8899 2006-06-06 11:09:43Z jforest $ *) +(* $Id: FSetAVL.v 8985 2006-06-23 16:12:45Z jforest $ *) (** This module implements sets using AVL trees. It follows the implementation from Ocaml's standard library. *) @@ -515,7 +515,7 @@ Proof. (* LT *) inv avl. rewrite bal_in; auto. - rewrite (IHt y0 H1); intuition_in. + rewrite (IHt y0 H0); intuition_in. (* EQ *) inv avl. intuition. @@ -523,7 +523,7 @@ Proof. (* GT *) inv avl. rewrite bal_in; auto. - rewrite (IHt y0 H2); intuition_in. + rewrite (IHt y0 H1); intuition_in. Qed. Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s). @@ -531,16 +531,16 @@ Proof. intros s x; functional induction (add x s); auto; intros. inv bst; inv avl; apply bal_bst; auto. (* lt_tree -> lt_tree (add ...) *) - red; red in H5. + red; red in H4. intros. - rewrite (add_in l x y0 H) in H1. + rewrite (add_in l x y0 H) in H0. intuition. eauto. inv bst; inv avl; apply bal_bst; auto. (* gt_tree -> gt_tree (add ...) *) - red; red in H5. + red; red in H4. intros. - rewrite (add_in r x y0 H6) in H1. + rewrite (add_in r x y0 H5) in H0. intuition. apply MX.lt_eq with x; auto. Qed. @@ -703,7 +703,7 @@ Proof. avl_nns; omega_max. (* l = Node *) inversion_clear H. - rewrite H0 in IHp;simpl in IHp;destruct (IHp lh); auto. + rewrite e0 in IHp;simpl in IHp;destruct (IHp lh); auto. split; simpl in *. apply bal_avl; auto; omega_max. omega_bal. @@ -723,12 +723,12 @@ Proof. intuition_in. (* l = Node *) inversion_clear H. - generalize (remove_min_avl ll lx lr lh H1). - rewrite H0; simpl; intros. + generalize (remove_min_avl ll lx lr lh H0). + rewrite e0; simpl; intros. rewrite bal_in; auto. - rewrite H0 in IHp;generalize (IHp lh y H1). + rewrite e0 in IHp;generalize (IHp lh y H0). intuition. - inversion_clear H8; intuition. + inversion_clear H7; intuition. Qed. Lemma remove_min_bst : forall l x r h, @@ -736,15 +736,15 @@ Lemma remove_min_bst : forall l x r h, Proof. intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. inv bst; auto. - inversion_clear H; inversion_clear H1. - rewrite_all H0;simpl in *. + inversion_clear H; inversion_clear H0. + rewrite_all e0;simpl in *. apply bal_bst; auto. firstorder. intro; intros. generalize (remove_min_in ll lx lr lh y H). - rewrite H0; simpl. + rewrite e0; simpl. destruct 1. - apply H4; intuition. + apply H3; intuition. Qed. Lemma remove_min_gt_tree : forall l x r h, @@ -753,14 +753,14 @@ Lemma remove_min_gt_tree : forall l x r h, Proof. intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. inv bst; auto. - inversion_clear H; inversion_clear H1. + inversion_clear H; inversion_clear H0. intro; intro. - generalize (IHp lh H2 H); clear H8 H7 IHp. + generalize (IHp lh H1 H); clear H6 H7 IHp. generalize (remove_min_avl ll lx lr lh H). generalize (remove_min_in ll lx lr lh m H). - rewrite H0; simpl; intros. - rewrite (bal_in l' x r y H8 H6) in H1. - destruct H7. + rewrite e0; simpl; intros. + rewrite (bal_in l' x r y H7 H5) in H0. + destruct H6. firstorder. apply MX.lt_eq with x; auto. apply X.lt_trans with x; auto. @@ -788,9 +788,9 @@ Proof. intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros. split; auto; avl_nns; omega_max. split; auto; avl_nns; simpl in *; omega_max. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. generalize (remove_min_avl_1 l2 x2 r2 h2 H0). - rewrite H2; simpl; destruct 1. + rewrite e1; simpl; destruct 1. split. apply bal_avl; auto. simpl; omega_max. @@ -809,12 +809,12 @@ Proof. intros s1 s2; functional induction (merge s1 s2); subst; simpl in *; intros. intuition_in. intuition_in. - destruct s1;try contradiction;clear H1. - replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite H2; auto]. + destruct s1;try contradiction;clear y. + replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite e1; auto]. rewrite bal_in; auto. - generalize (remove_min_avl l2 x2 r2 h2); rewrite H2; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 y); rewrite H2; simpl; intro. - rewrite H1; intuition. + generalize (remove_min_avl l2 x2 r2 h2); rewrite e1; simpl; auto. + generalize (remove_min_in l2 x2 r2 h2 y0); rewrite e1; simpl; intro. + rewrite H3 ; intuition. Qed. Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> @@ -822,13 +822,13 @@ Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> bst (merge s1 s2). Proof. intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. apply bal_bst; auto. - generalize (remove_min_bst l2 x2 r2 h2); rewrite H2; simpl in *; auto. + generalize (remove_min_bst l2 x2 r2 h2); rewrite e1; simpl in *; auto. intro; intro. - apply H5; auto. - generalize (remove_min_in l2 x2 r2 h2 m); rewrite H2; simpl; intuition. - generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite H2; simpl; auto. + apply H3; auto. + generalize (remove_min_in l2 x2 r2 h2 m); rewrite e1; simpl; intuition. + generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite e1; simpl; auto. Qed. (** * Deletion *) @@ -850,18 +850,18 @@ Proof. intuition; omega_max. (* LT *) inv avl. - destruct (IHt H1). + destruct (IHt H0). split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) inv avl. - generalize (merge_avl_1 l r H1 H2 H3). + generalize (merge_avl_1 l r H0 H1 H2). intuition omega_max. (* GT *) inv avl. - destruct (IHt H2). + destruct (IHt H1). split. apply bal_avl; auto. omega_max. @@ -880,17 +880,17 @@ Proof. intros s x; functional induction (remove x s); subst;simpl; intros. intuition_in. (* LT *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e0. rewrite bal_in; auto. - generalize (IHt y0 H1); intuition; [ order | order | intuition_in ]. + generalize (IHt y0 H0); intuition; [ order | order | intuition_in ]. (* EQ *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e0. rewrite merge_in; intuition; [ order | order | intuition_in ]. elim H9; eauto. (* GT *) - inv avl; inv bst; clear H0. + inv avl; inv bst; clear e0. rewrite bal_in; auto. - generalize (IHt y0 H6); intuition; [ order | order | intuition_in ]. + generalize (IHt y0 H5); intuition; [ order | order | intuition_in ]. Qed. Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s). @@ -945,7 +945,7 @@ Proof. simpl. destruct l1. inversion 1; subst. - assert (X.lt x _x) by (apply H3; auto). + assert (X.lt x _x) by (apply H2; auto). inversion_clear 1; auto; order. assert (X.lt t _x) by auto. inversion_clear 2; auto; @@ -958,7 +958,7 @@ Proof. red; auto. inversion 1. destruct l;try contradiction. - clear H0;intro H0. + clear y;intro H0. destruct (IHo H0 t); auto. Qed. @@ -1004,7 +1004,7 @@ Proof. red; auto. inversion 1. destruct r;try contradiction. - clear H0;intros H0; destruct (IHo H0 t); auto. + intros H0; destruct (IHo H0 t); auto. Qed. (** * Any element *) @@ -1038,9 +1038,9 @@ Function concat (s1 s2 : t) : t := Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2). Proof. intros s1 s2; functional induction (concat s1 s2); subst;auto. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. intros; apply join_avl; auto. - generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite H2; simpl; auto. + generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite e1; simpl; auto. Qed. Lemma concat_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> @@ -1048,13 +1048,13 @@ Lemma concat_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 -> bst (concat s1 s2). Proof. intros s1 s2; functional induction (concat s1 s2); subst ;auto. - destruct s1;try contradiction;clear H1. + destruct s1;try contradiction;clear y. intros; apply join_bst; auto. - generalize (remove_min_bst l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto. - generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 m H3); rewrite H2; simpl; auto. + generalize (remove_min_bst l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto. + generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto. + generalize (remove_min_in l2 x2 r2 h2 m H2); rewrite e1; simpl; auto. destruct 1; intuition. - generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto. + generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto. Qed. Lemma concat_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 -> @@ -1064,12 +1064,12 @@ Proof. intros s1 s2; functional induction (concat s1 s2);subst;simpl. intuition. inversion_clear H5. - destruct s1;try contradiction;clear H1;intuition. + destruct s1;try contradiction;clear y;intuition. inversion_clear H5. - destruct s1;try contradiction;clear H1; intros. + destruct s1;try contradiction;clear y; intros. rewrite (join_in (Node s1_1 t s1_2 i) m s2' y H0). - generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto. - generalize (remove_min_in l2 x2 r2 h2 y H3); rewrite H2; simpl. + generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto. + generalize (remove_min_in l2 x2 r2 h2 y H2); rewrite e1; simpl. intro EQ; rewrite EQ; intuition. Qed. @@ -1100,9 +1100,9 @@ Lemma split_avl : forall s x, avl s -> Proof. intros s x; functional induction (split x s);subst;simpl in *. auto. - rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition. + rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. - rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition. + rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition. Qed. Lemma split_in_1 : forall s x y, bst s -> avl s -> @@ -1111,20 +1111,20 @@ Proof. intros s x; functional induction (split x s);subst;simpl in *. intuition; try inversion_clear H1. (* LT *) - rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H9. - rewrite (IHp y0 H2 H6); clear IHp H0. + rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. + rewrite (IHp y0 H0 H4); clear IHp e0. intuition. - inversion_clear H0; auto; order. + inversion_clear H6; auto; order. (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0. + simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0. intuition. order. intuition_in; order. (* GT *) - rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8. + rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. rewrite join_in; auto. - generalize (split_avl r x H7); rewrite H1; simpl; intuition. - rewrite (IHp y0 H3 H7); clear H1. + generalize (split_avl r x H5); rewrite e1; simpl; intuition. + rewrite (IHp y0 H1 H5); clear e1. intuition; [ eauto | eauto | intuition_in ]. Qed. @@ -1134,17 +1134,17 @@ Proof. intros s x; functional induction (split x s);subst;simpl in *. intuition; try inversion_clear H1. (* LT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. rewrite join_in; auto. - generalize (split_avl l x H6); rewrite H1; simpl; intuition. - rewrite (IHp y0 H2 H6); clear IHp H0. + generalize (split_avl l x H4); rewrite e1; simpl; intuition. + rewrite (IHp y0 H0 H4); clear IHp e0. intuition; [ order | order | intuition_in ]. (* EQ *) - simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0. + simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0. intuition; [ order | intuition_in; order ]. (* GT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8. - rewrite (IHp y0 H3 H7); clear IHp H0. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. + rewrite (IHp y0 H1 H5); clear IHp e0. intuition; intuition_in; order. Qed. @@ -1154,13 +1154,13 @@ Proof. intros s x; functional induction (split x s);subst;simpl in *. intuition; try inversion_clear H1. (* LT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. rewrite IHp; auto. intuition_in; absurd (X.lt x y); eauto. (* EQ *) simpl in *; inversion_clear 1; inversion_clear 1; intuition. (* GT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6. rewrite IHp; auto. intuition_in; absurd (X.lt y x); eauto. Qed. @@ -1171,21 +1171,21 @@ Proof. intros s x; functional induction (split x s);subst;simpl in *. intuition. (* LT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. intuition. apply join_bst; auto. - generalize (split_avl l x H6); rewrite H1; simpl; intuition. + generalize (split_avl l x H4); rewrite e1; simpl; intuition. intro; intro. - generalize (split_in_2 l x y0 H2 H6); rewrite H1; simpl; intuition. + generalize (split_in_2 l x y0 H0 H4); rewrite e1; simpl; intuition. (* EQ *) simpl in *; inversion_clear 1; inversion_clear 1; intuition. (* GT *) - rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. + rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1. intuition. apply join_bst; auto. - generalize (split_avl r x H7); rewrite H1; simpl; intuition. + generalize (split_avl r x H5); rewrite e1; simpl; intuition. intro; intro. - generalize (split_in_1 r x y0 H3 H7); rewrite H1; simpl; intuition. + generalize (split_in_1 r x y0 H1 H5); rewrite e1; simpl; intuition. Qed. (** * Intersection *) diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index fde70225..4e0f3745 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Wf.v 8642 2006-03-17 10:09:02Z notin $ i*) +(*i $Id: Wf.v 8988 2006-06-25 22:15:32Z letouzey $ i*) (** This module proves the validity of - well-founded recursion (also called course of values) @@ -146,6 +146,8 @@ Section Well_founded_2. Variable R : A * B -> A * B -> Prop. Variable P : A -> B -> Type. + + Section Acc_iter_2. Variable F : forall (x:A) (x':B), @@ -156,6 +158,7 @@ Section Well_founded_2. F (fun (y:A) (y':B) (h:R (y, y') (x, x')) => Acc_iter_2 (x:=y) (x':=y') (Acc_inv a (y, y') h)). + End Acc_iter_2. Hypothesis Rwf : well_founded R. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 751bc3da..df2b17e0 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - (*i $Id: List.v 8866 2006-05-28 16:21:04Z herbelin $ i*) + (*i $Id: List.v 9035 2006-07-09 15:42:09Z herbelin $ i*) Require Import Le Gt Minus Min Bool. Require Import Setoid. @@ -85,6 +85,7 @@ Delimit Scope list_scope with list. Bind Scope list_scope with list. +Arguments Scope list [type_scope]. (** ** Facts about lists *) @@ -135,13 +136,11 @@ Section Facts. Proof. simpl in |- *; auto. Qed. - Hint Resolve in_eq. Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). Proof. simpl in |- *; auto. Qed. - Hint Resolve in_cons. Theorem in_nil : forall a:A, ~ In a nil. Proof. @@ -197,8 +196,6 @@ Section Facts. induction l; simpl in |- *; auto. rewrite <- IHl; auto. Qed. - Hint Resolve app_nil_end. - (** [app] is associative *) Theorem app_ass : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. @@ -211,9 +208,8 @@ Section Facts. Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. Proof. - auto. + auto using app_ass. Qed. - Hint Resolve ass_app. (** [app] commutes with [cons] *) Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y. @@ -296,7 +292,6 @@ Section Facts. 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:A), In a l \/ In a m -> In a (l ++ m). Proof. @@ -313,7 +308,6 @@ Section Facts. now_show (H = a \/ In a (y ++ m)). elim H2; auto. Qed. - Hint Resolve in_or_app. End Facts. @@ -890,7 +884,7 @@ Section ListOps. break_list l1 b l1' H0; break_list l3 c l3' H1. auto. apply perm_trans with (l3'++c::l4); auto. - apply perm_trans with (l1'++a::l2); auto. + apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app. apply perm_skip. apply (IH a l1' l2 l3' l4); auto. (* swap *) diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index e0be9ed3..d2b7db04 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ChoiceFacts.v 8892 2006-06-04 17:59:53Z herbelin $ i*) +(*i $Id: ChoiceFacts.v 8999 2006-07-04 12:46:04Z notin $ i*) (** ** Some facts and definitions concerning choice and description in intuitionistic logic. @@ -78,7 +78,7 @@ unpublished. [Bell93] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic Type Theories, Mathematical Logic Quarterly, volume 39, 1993. -[Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in +[Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005. *) @@ -125,7 +125,7 @@ Definition FunctionalRelReification_on := (** ID_epsilon (constructive version of indefinite description; combined with proof-irrelevance, it may be connected to - Carlstrøm's type theory with a constructive indefinite description + Carlstrøm's type theory with a constructive indefinite description operator) *) Definition ConstructiveIndefiniteDescription_on := @@ -133,7 +133,7 @@ Definition ConstructiveIndefiniteDescription_on := (exists x, P x) -> { x:A | P x }. (** ID_iota (constructive version of definite description; combined - with proof-irrelevance, it may be connected to Carlstrøm's and + with proof-irrelevance, it may be connected to Carlstrøm's and Stenlund's type theory with a constructive definite description operator) *) @@ -694,7 +694,7 @@ Qed. We adapt the proof to show that constructive definite description transports excluded-middle from [Prop] to [Set]. - [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos + [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical Quotients and Quotient Types in Coq, Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646, Springer Verlag. *) diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 79bef2af..28d32fcc 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ClassicalUniqueChoice.v 8893 2006-06-04 18:04:53Z herbelin $ i*) +(*i $Id: ClassicalUniqueChoice.v 9026 2006-07-06 15:16:20Z herbelin $ i*) (** This file provides classical logic and unique choice *) @@ -15,7 +15,7 @@ excluded-middle in [Set], hence it implies a strongly classical world. Especially it conflicts with the impredicativity of [Set]. - [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos + [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos Simpson, Mathematical Quotients and Quotient Types in Coq, Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646, Springer Verlag. *) @@ -39,7 +39,7 @@ intros A B. apply (dependent_unique_choice A (fun _ => B)). Qed. -(** The followig proof comes from [ChicliPottierSimpson02] *) +(** The following proof comes from [ChicliPottierSimpson02] *) Require Import Setoid. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 1d56b747..335466a6 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith_base.v 8883 2006-05-31 21:56:37Z letouzey $ i*) +(*i $Id: QArith_base.v 8989 2006-06-25 22:17:49Z letouzey $ i*) Require Export ZArith. Require Export ZArithRing. @@ -43,12 +43,48 @@ Notation Qge := (fun x y : Q => Qle y x). Infix "==" := Qeq (at level 70, no associativity) : Q_scope. Infix "<" := Qlt : Q_scope. +Infix ">" := Qgt : Q_scope. Infix "<=" := Qle : Q_scope. -Infix ">" := Qgt : Q_scope. -Infix ">=" := Qge : Q_scope. +Infix ">=" := Qge : Q_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. -Hint Unfold Qeq Qle Qlt: qarith. +(** Another approach : using Qcompare for defining order relations. *) + +Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z. +Notation "p ?= q" := (Qcompare p q) : Q_scope. + +Lemma Qeq_alt : forall p q, (p == q) <-> (p ?= q) = Eq. +Proof. +unfold Qeq, Qcompare; intros; split; intros. +rewrite H; apply Zcompare_refl. +apply Zcompare_Eq_eq; auto. +Qed. + +Lemma Qlt_alt : forall p q, (p<q) <-> (p?=q = Lt). +Proof. +unfold Qlt, Qcompare, Zlt; split; auto. +Qed. + +Lemma Qgt_alt : forall p q, (p>q) <-> (p?=q = Gt). +Proof. +unfold Qlt, Qcompare, Zlt. +intros; rewrite Zcompare_Gt_Lt_antisym; split; auto. +Qed. + +Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). +Proof. +unfold Qle, Qcompare, Zle; split; auto. +Qed. + +Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). +Proof. +unfold Qle, Qcompare, Zle. +split; intros; swap H. +rewrite Zcompare_Gt_Lt_antisym; auto. +rewrite Zcompare_Gt_Lt_antisym in H0; auto. +Qed. + +Hint Unfold Qeq Qlt Qle: qarith. Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. (** Properties of equality. *) @@ -236,6 +272,24 @@ apply Zmult_gt_0_lt_compat_l; auto with zarith. Open Scope Q_scope. Qed. + +Lemma Qcompare_egal_dec: forall n m p q : Q, + (n<m -> p<q) -> (n==m -> p==q) -> (n>m -> p>q) -> ((n?=m) = (p?=q)). +Proof. +intros. +do 2 rewrite Qeq_alt in H0. +unfold Qeq, Qlt, Qcompare in *. +apply Zcompare_egal_dec; auto. +omega. +Qed. + + +Add Morphism Qcompare : Qcompare_comp. +Proof. +intros; apply Qcompare_egal_dec; rewrite H; rewrite H0; auto. +Qed. + + (** [0] and [1] are apart *) Lemma Q_apart_0_1 : ~ 1 == 0. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v new file mode 100644 index 00000000..9cbd400d --- /dev/null +++ b/theories/QArith/Qcanon.v @@ -0,0 +1,526 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: Qcanon.v 8989 2006-06-25 22:17:49Z letouzey $ i*) + +Require Import QArith. +Require Import Eqdep_dec. + +(** [Qc] : A canonical representation of rational numbers. + based on the setoid representation [Q]. *) + +Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }. + +Delimit Scope Qc_scope with Qc. +Bind Scope Qc_scope with Qc. +Arguments Scope Qcmake [Q_scope]. +Open Scope Qc_scope. + +Lemma Qred_identity : + forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. +Proof. +unfold Qred; intros (a,b); simpl. +generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)). +intros. +rewrite H1 in H; clear H1. +destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. +destruct H0. +rewrite Zmult_1_l in H, H0. +subst; simpl; auto. +Qed. + +Lemma Qred_identity2 : + forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z. +Proof. +unfold Qred; intros (a,b); simpl. +generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)) (Zgcd_is_pos a ('b)). +intros. +rewrite <- H; rewrite <- H in H1; clear H. +destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. +injection H2; intros; clear H2. +destruct H0. +clear H0 H3. +destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. +f_equal. +apply Pmult_reg_r with bb. +injection H2; intros. +rewrite <- H0. +rewrite H; simpl; auto. +elim H1; auto. +Qed. + +Lemma Qred_iff : forall q:Q, Qred q = q <-> Zgcd (Qnum q) (QDen q) = 1%Z. +Proof. +split; intros. +apply Qred_identity2; auto. +apply Qred_identity; auto. +Qed. + + +Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q. +Proof. +intros; apply Qred_complete. +apply Qred_correct. +Qed. + +Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). +Arguments Scope Q2Qc [Q_scope]. +Notation " !! " := Q2Qc : Qc_scope. + +Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. +Proof. +intros (q,proof_q) (q',proof_q'). +simpl. +intros H. +assert (H0:=Qred_complete _ _ H). +assert (q = q') by congruence. +subst q'. +assert (proof_q = proof_q'). + apply eq_proofs_unicity; auto; intros. + repeat decide equality. +congruence. +Qed. +Hint Resolve Qc_is_canon. + +Notation " 0 " := (!!0) : Qc_scope. +Notation " 1 " := (!!1) : Qc_scope. + +Definition Qcle (x y : Qc) := (x <= y)%Q. +Definition Qclt (x y : Qc) := (x < y)%Q. +Notation Qcgt := (fun x y : Qc => Qlt y x). +Notation Qcge := (fun x y : Qc => Qle y x). +Infix "<" := Qclt : Qc_scope. +Infix "<=" := Qcle : Qc_scope. +Infix ">" := Qcgt : Qc_scope. +Infix ">=" := Qcge : Qc_scope. +Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. + +Definition Qccompare (p q : Qc) := (Qcompare p q). +Notation "p ?= q" := (Qccompare p q) : Qc_scope. + +Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq. +Proof. +unfold Qccompare. +intros; rewrite <- Qeq_alt. +split; auto. +intro H; rewrite H; auto with qarith. +Qed. + +Lemma Qclt_alt : forall p q, (p<q) <-> (p?=q = Lt). +Proof. +intros; exact (Qlt_alt p q). +Qed. + +Lemma Qcgt_alt : forall p q, (p>q) <-> (p?=q = Gt). +Proof. +intros; exact (Qgt_alt p q). +Qed. + +Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). +Proof. +intros; exact (Qle_alt p q). +Qed. + +Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). +Proof. +intros; exact (Qge_alt p q). +Qed. + +(** equality on [Qc] is decidable: *) + +Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}. +Proof. + intros. + destruct (Qeq_dec x y) as [H|H]; auto. + right; swap H; subst; auto with qarith. +Defined. + +(** The addition, multiplication and opposite are defined + in the straightforward way: *) + +Definition Qcplus (x y : Qc) := !!(x+y). +Infix "+" := Qcplus : Qc_scope. +Definition Qcmult (x y : Qc) := !!(x*y). +Infix "*" := Qcmult : Qc_scope. +Definition Qcopp (x : Qc) := !!(-x). +Notation "- x" := (Qcopp x) : Qc_scope. +Definition Qcminus (x y : Qc) := x+-y. +Infix "-" := Qcminus : Qc_scope. +Definition Qcinv (x : Qc) := !!(/x). +Notation "/ x" := (Qcinv x) : Qc_scope. +Definition Qcdiv (x y : Qc) := x*/y. +Infix "/" := Qcdiv : Qc_scope. + +(** [0] and [1] are apart *) + +Lemma Q_apart_0_1 : 1 <> 0. +Proof. + unfold Q2Qc. + intros H; discriminate H. +Qed. + +Ltac qc := match goal with + | q:Qc |- _ => destruct q; qc + | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct +end. + +Opaque Qred. + +(** Addition is associative: *) + +Theorem Qcplus_assoc : forall x y z, x+(y+z)=(x+y)+z. +Proof. + intros; qc; apply Qplus_assoc. +Qed. + +(** [0] is a neutral element for addition: *) + +Lemma Qcplus_0_l : forall x, 0+x = x. +Proof. + intros; qc; apply Qplus_0_l. +Qed. + +Lemma Qcplus_0_r : forall x, x+0 = x. +Proof. + intros; qc; apply Qplus_0_r. +Qed. + +(** Commutativity of addition: *) + +Theorem Qcplus_comm : forall x y, x+y = y+x. +Proof. + intros; qc; apply Qplus_comm. +Qed. + +(** Properties of [Qopp] *) + +Lemma Qcopp_involutive : forall q, - -q = q. +Proof. + intros; qc; apply Qopp_involutive. +Qed. + +Theorem Qcplus_opp_r : forall q, q+(-q) = 0. +Proof. + intros; qc; apply Qplus_opp_r. +Qed. + +(** Multiplication is associative: *) + +Theorem Qcmult_assoc : forall n m p, n*(m*p)=(n*m)*p. +Proof. + intros; qc; apply Qmult_assoc. +Qed. + +(** [1] is a neutral element for multiplication: *) + +Lemma Qcmult_1_l : forall n, 1*n = n. +Proof. + intros; qc; apply Qmult_1_l. +Qed. + +Theorem Qcmult_1_r : forall n, n*1=n. +Proof. + intros; qc; apply Qmult_1_r. +Qed. + +(** Commutativity of multiplication *) + +Theorem Qcmult_comm : forall x y, x*y=y*x. +Proof. + intros; qc; apply Qmult_comm. +Qed. + +(** Distributivity *) + +Theorem Qcmult_plus_distr_r : forall x y z, x*(y+z)=(x*y)+(x*z). +Proof. + intros; qc; apply Qmult_plus_distr_r. +Qed. + +Theorem Qcmult_plus_distr_l : forall x y z, (x+y)*z=(x*z)+(y*z). +Proof. + intros; qc; apply Qmult_plus_distr_l. +Qed. + +(** Integrality *) + +Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0. +Proof. + intros. + destruct (Qmult_integral x y); try qc; auto. + injection H; clear H; intros. + rewrite <- (Qred_correct (x*y)). + rewrite <- (Qred_correct 0). + rewrite H; auto with qarith. +Qed. + +Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0. +Proof. + intros; destruct (Qcmult_integral _ _ H0); tauto. +Qed. + +(** Inverse and division. *) + +Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1. +Proof. + intros; qc; apply Qmult_inv_r; auto. +Qed. + +Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1. +Proof. + intros. + rewrite Qcmult_comm. + apply Qcmult_inv_r; auto. +Qed. + +Lemma Qcinv_mult_distr : forall p q, / (p * q) = /p * /q. +Proof. + intros; qc; apply Qinv_mult_distr. +Qed. + +Theorem Qcdiv_mult_l : forall x y, y<>0 -> (x*y)/y = x. +Proof. + unfold Qcdiv. + intros. + rewrite <- Qcmult_assoc. + rewrite Qcmult_inv_r; auto. + apply Qcmult_1_r. +Qed. + +Theorem Qcmult_div_r : forall x y, ~ y = 0 -> y*(x/y) = x. +Proof. + unfold Qcdiv. + intros. + rewrite Qcmult_assoc. + rewrite Qcmult_comm. + rewrite Qcmult_assoc. + rewrite Qcmult_inv_l; auto. + apply Qcmult_1_l. +Qed. + +(** Properties of order upon Q. *) + +Lemma Qcle_refl : forall x, x<=x. +Proof. +unfold Qcle; intros; simpl; apply Qle_refl. +Qed. + +Lemma Qcle_antisym : forall x y, x<=y -> y<=x -> x=y. +Proof. +unfold Qcle; intros; simpl in *. +apply Qc_is_canon; apply Qle_antisym; auto. +Qed. + +Lemma Qcle_trans : forall x y z, x<=y -> y<=z -> x<=z. +Proof. +unfold Qcle; intros; eapply Qle_trans; eauto. +Qed. + +Lemma Qclt_not_eq : forall x y, x<y -> x<>y. +Proof. +unfold Qclt; intros; simpl in *. +intro; destruct (Qlt_not_eq _ _ H). +subst; auto with qarith. +Qed. + +(** Large = strict or equal *) + +Lemma Qclt_le_weak : forall x y, x<y -> x<=y. +Proof. +unfold Qcle, Qclt; intros; apply Qlt_le_weak; auto. +Qed. + +Lemma Qcle_lt_trans : forall x y z, x<=y -> y<z -> x<z. +Proof. +unfold Qcle, Qclt; intros; eapply Qle_lt_trans; eauto. +Qed. + +Lemma Qclt_le_trans : forall x y z, x<y -> y<=z -> x<z. +Proof. +unfold Qcle, Qclt; intros; eapply Qlt_le_trans; eauto. +Qed. + +Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z. +Proof. +unfold Qclt; intros; eapply Qlt_trans; eauto. +Qed. + +(** [x<y] iff [~(y<=x)] *) + +Lemma Qcnot_lt_le : forall x y, ~ x<y -> y<=x. +Proof. +unfold Qcle, Qclt; intros; apply Qnot_lt_le; auto. +Qed. + +Lemma Qcnot_le_lt : forall x y, ~ x<=y -> y<x. +Proof. +unfold Qcle, Qclt; intros; apply Qnot_le_lt; auto. +Qed. + +Lemma Qclt_not_le : forall x y, x<y -> ~ y<=x. +Proof. +unfold Qcle, Qclt; intros; apply Qlt_not_le; auto. +Qed. + +Lemma Qcle_not_lt : forall x y, x<=y -> ~ y<x. +Proof. +unfold Qcle, Qclt; intros; apply Qle_not_lt; auto. +Qed. + +Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y. +Proof. +unfold Qcle, Qclt; intros; apply Qle_lt_or_eq; auto. +Qed. + +(** Some decidability results about orders. *) + +Lemma Qc_dec : forall x y, {x<y} + {y<x} + {x=y}. +Proof. +unfold Qclt, Qcle; intros. +destruct (Q_dec x y) as [H|H]. +left; auto. +right; apply Qc_is_canon; auto. +Defined. + +Lemma Qclt_le_dec : forall x y, {x<y} + {y<=x}. +Proof. +unfold Qclt, Qcle; intros; apply Qlt_le_dec; auto. +Defined. + +(** Compatibility of operations with respect to order. *) + +Lemma Qcopp_le_compat : forall p q, p<=q -> -q <= -p. +Proof. +unfold Qcle, Qcopp; intros; simpl in *. +repeat rewrite Qred_correct. +apply Qopp_le_compat; auto. +Qed. + +Lemma Qcle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. +Proof. +unfold Qcle, Qcminus; intros; simpl in *. +repeat rewrite Qred_correct. +apply Qle_minus_iff; auto. +Qed. + +Lemma Qclt_minus_iff : forall p q, p < q <-> 0 < q+-p. +Proof. +unfold Qclt, Qcplus, Qcopp; intros; simpl in *. +repeat rewrite Qred_correct. +apply Qlt_minus_iff; auto. +Qed. + +Lemma Qcplus_le_compat : + forall x y z t, x<=y -> z<=t -> x+z <= y+t. +Proof. +unfold Qcplus, Qcle; intros; simpl in *. +repeat rewrite Qred_correct. +apply Qplus_le_compat; auto. +Qed. + +Lemma Qcmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. +Proof. +unfold Qcmult, Qcle; intros; simpl in *. +repeat rewrite Qred_correct. +apply Qmult_le_compat_r; auto. +Qed. + +Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. +Proof. +unfold Qcmult, Qcle, Qclt; intros; simpl in *. +repeat progress rewrite Qred_correct in * |-. +eapply Qmult_lt_0_le_reg_r; eauto. +Qed. + +Lemma Qcmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. +Proof. +unfold Qcmult, Qclt; intros; simpl in *. +repeat progress rewrite Qred_correct in *. +eapply Qmult_lt_compat_r; eauto. +Qed. + +(** Rational to the n-th power *) + +Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := + match n with + | O => 1 + | S n => q * (Qcpower q n) + end. + +Notation " q ^ n " := (Qcpower q n) : Qc_scope. + +Lemma Qcpower_1 : forall n, 1^n = 1. +Proof. +induction n; simpl; auto with qarith. +rewrite IHn; auto with qarith. +Qed. + +Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. +Proof. +destruct n; simpl. +destruct 1; auto. +intros. +apply Qc_is_canon. +simpl. +compute; auto. +Qed. + +Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n. +Proof. +induction n; simpl; auto with qarith. +intros; compute; intro; discriminate. +intros. +apply Qcle_trans with (0*(p^n)). +compute; intro; discriminate. +apply Qcmult_le_compat_r; auto. +Qed. + +(** And now everything is easier concerning tactics: *) + +(** A ring tactic for rational numbers *) + +Definition Qc_eq_bool (x y : Qc) := + if Qc_eq_dec x y then true else false. + +Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y. +intros x y; unfold Qc_eq_bool in |- *; case (Qc_eq_dec x y); simpl in |- *; auto. +intros _ H; inversion H. +Qed. + +Definition Qcrt : Ring_Theory Qcplus Qcmult 1 0 Qcopp Qc_eq_bool. +Proof. +constructor. +exact Qcplus_comm. +exact Qcplus_assoc. +exact Qcmult_comm. +exact Qcmult_assoc. +exact Qcplus_0_l. +exact Qcmult_1_l. +exact Qcplus_opp_r. +exact Qcmult_plus_distr_l. +unfold Is_true; intros x y; generalize (Qc_eq_bool_correct x y); + case (Qc_eq_bool x y); auto. +Qed. + +Add Ring Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcrt [ Qcmake ]. + +(** A field tactic for rational numbers *) + +Require Import Field. + +Add Field Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcinv Qcrt Qcmult_inv_l + with div:=Qcdiv. + +Example test_field : forall x y : Qc, y<>0 -> (x/y)*y = x. +intros. +field. +auto. +Qed. + + + diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 049c195a..c503daad 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Qreduction.v 8883 2006-05-31 21:56:37Z letouzey $ i*) +(*i $Id: Qreduction.v 8989 2006-06-25 22:17:49Z letouzey $ i*) (** * Normalisation functions for rational numbers. *) @@ -32,65 +32,17 @@ Proof. simple destruct z; simpl in |- *; auto; intros; elim H; auto. Qed. -(** A simple cancelation by powers of two *) - -Fixpoint Pfactor_twos (p p':positive) {struct p} : (positive*positive) := - match p, p' with - | xO p, xO p' => Pfactor_twos p p' - | _, _ => (p,p') - end. - -Definition Qfactor_twos (q:Q) := - let (p,q) := q in - match p with - | Z0 => 0 - | Zpos p => let (p,q) := Pfactor_twos p q in (Zpos p)#q - | Zneg p => let (p,q) := Pfactor_twos p q in (Zneg p)#q - end. - -Lemma Pfactor_twos_correct : forall p p', - (p*(snd (Pfactor_twos p p')))%positive = - (p'*(fst (Pfactor_twos p p')))%positive. -Proof. -induction p; intros. -simpl snd; simpl fst; rewrite Pmult_comm; auto. -destruct p'. -simpl snd; simpl fst; rewrite Pmult_comm; auto. -simpl; f_equal; auto. -simpl snd; simpl fst; rewrite Pmult_comm; auto. -simpl snd; simpl fst; rewrite Pmult_comm; auto. -Qed. - -Lemma Qfactor_twos_correct : forall q, Qfactor_twos q == q. -Proof. -intros (p,q). -destruct p. -red; simpl; auto. -simpl. -generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q). -red; simpl. -intros; f_equal. -rewrite H; apply Pmult_comm. -simpl. -generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q). -red; simpl. -intros; f_equal. -rewrite H; apply Pmult_comm. -Qed. -Hint Resolve Qfactor_twos_correct. - (** Simplification of fractions using [Zgcd]. This version can compute within Coq. *) Definition Qred (q:Q) := - let (q1,q2) := Qfactor_twos q in - let (r1,r2) := snd (Zggcd q1 (Zpos q2)) in r1#(Z2P r2). + let (q1,q2) := q in + let (r1,r2) := snd (Zggcd q1 ('q2)) + in r1#(Z2P r2). Lemma Qred_correct : forall q, (Qred q) == q. Proof. -intros; apply Qeq_trans with (Qfactor_twos q); auto. -unfold Qred. -destruct (Qfactor_twos q) as (n,d); red; simpl. +unfold Qred, Qeq; intros (n,d); simpl. generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)). destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl. @@ -112,16 +64,8 @@ Qed. Lemma Qred_complete : forall p q, p==q -> Qred p = Qred q. Proof. -intros. -assert (Qfactor_twos p == Qfactor_twos q). - apply Qeq_trans with p; auto. - apply Qeq_trans with q; auto. - symmetry; auto. -clear H. -unfold Qred. -destruct (Qfactor_twos p) as (a,b); -destruct (Qfactor_twos q) as (c,d); clear p q. -unfold Qeq in *; simpl in *. +intros (a,b) (c,d). +unfold Qred, Qeq in *; simpl in *. Open Scope Z_scope. generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)). @@ -198,47 +142,6 @@ rewrite (Qred_correct q); auto. rewrite (Qred_correct q'); auto. Qed. -(** Another version, dedicated to extraction *) - -Definition Qred_extr (q : Q) := - let (q1, q2) := Qfactor_twos q in - let (p,_) := Zggcd_spec_pos (Zpos q2) (Zle_0_pos q2) q1 in - let (r2,r1) := snd p in r1#(Z2P r2). - -Lemma Qred_extr_Qred : forall q, Qred_extr q = Qred q. -Proof. -unfold Qred, Qred_extr. -intro q; destruct (Qfactor_twos q) as (n,p); clear q. -Open Scope Z_scope. -destruct (Zggcd_spec_pos (' p) (Zle_0_pos p) n) as ((g,(pp,nn)),H). -generalize (H (Zle_0_pos p)); clear H; intros (Hg1,(Hg2,(Hg4,Hg3))). -simpl. -generalize (Zggcd_gcd n ('p)) (Zgcd_is_gcd n ('p)) - (Zgcd_is_pos n ('p)) (Zggcd_correct_divisors n ('p)). -destruct (Zggcd n (Zpos p)) as (g',(nn',pp')); simpl. -intro H; rewrite <- H; clear H. -intros Hg'1 Hg'2 (Hg'3,Hg'4). -assert (g<>0). - intro; subst g; discriminate. -destruct (Zis_gcd_uniqueness_apart_sign n ('p) g g'); auto. -apply Zis_gcd_sym; auto. -subst g'. -f_equal. -apply Zmult_reg_l with g; auto; congruence. -f_equal. -apply Zmult_reg_l with g; auto; congruence. -elimtype False; omega. -Open Scope Q_scope. -Qed. - -Add Morphism Qred_extr : Qred_extr_comp. -Proof. -intros q q' H. -do 2 rewrite Qred_extr_Qred. -rewrite (Qred_correct q); auto. -rewrite (Qred_correct q'); auto. -Qed. - Definition Qplus' (p q : Q) := Qred (Qplus p q). Definition Qmult' (p q : Q) := Qred (Qmult p q). diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 6d30e291..0148d0a2 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Ranalysis1.v 8670 2006-03-28 22:16:14Z herbelin $ i*) +(*i $Id: Ranalysis1.v 9042 2006-07-11 22:06:48Z herbelin $ i*) Require Import Rbase. Require Import Rfunctions. @@ -27,6 +27,18 @@ Definition div_real_fct (a:R) f (x:R) : R := a / f x. Definition comp f1 f2 (x:R) : R := f1 (f2 x). Definition inv_fct f (x:R) : R := / f x. +Delimit Scope Rfun_scope with F. + +Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope]. +Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope]. +Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope]. +Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope]. +Arguments Scope inv_fct [Rfun_scope R_scope]. +Arguments Scope opp_fct [Rfun_scope R_scope]. +Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope]. +Arguments Scope div_real_fct [R_scope Rfun_scope R_scope]. +Arguments Scope comp [Rfun_scope Rfun_scope R_scope]. + Infix "+" := plus_fct : Rfun_scope. Notation "- x" := (opp_fct x) : Rfun_scope. Infix "*" := mult_fct : Rfun_scope. @@ -36,8 +48,6 @@ 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. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index b74f7585..e722b679 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -6,21 +6,23 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Znumtheory.v 8853 2006-05-23 18:17:38Z herbelin $ i*) +(*i $Id: Znumtheory.v 8990 2006-06-26 13:57:44Z notin $ i*) Require Import ZArith_base. Require Import ZArithRing. Require Import Zcomplements. Require Import Zdiv. +Require Import Ndigits. +Require Import Wf_nat. Open Local Scope Z_scope. (** This file contains some notions of number theory upon Z numbers: - a divisibility predicate [Zdivide] - a gcd predicate [gcd] - Euclid algorithm [euclid] - - an efficient [Zgcd] function - a relatively prime predicate [rel_prime] - a prime predicate [prime] + - an efficient [Zgcd] function *) (** * Divisibility *) @@ -215,6 +217,16 @@ Proof. constructor; auto with zarith. Qed. +Lemma Zis_gcd_1 : forall a, Zis_gcd a 1 1. +Proof. +constructor; auto with zarith. +Qed. + +Lemma Zis_gcd_refl : forall a, Zis_gcd a a a. +Proof. +constructor; auto with zarith. +Qed. + Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d. Proof. simple induction 1; constructor; intuition. @@ -225,6 +237,14 @@ Proof. simple induction 1; constructor; intuition. Qed. +Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a). +Proof. +intros a. +apply Zabs_ind. +intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto. +intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto. +Qed. + Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. (** * Extended Euclid algorithm. *) @@ -366,477 +386,7 @@ replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)). rewrite H6; rewrite H7; ring. ring. Qed. - -Lemma Zis_gcd_0_abs : forall b, - Zis_gcd 0 b (Zabs b) /\ Zabs b >= 0 /\ 0 = Zabs b * 0 /\ b = Zabs b * Zsgn b. -Proof. -intro 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. -repeat split; auto with zarith. -symmetry; apply Zabs_Zsgn. - -intros H0; rewrite <- H0. -rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *. -split; [ apply Zis_gcd_0 | idtac ]; auto with zarith. -Qed. - - -(** We could obtain a [Zgcd] function via [euclid]. But we propose - here a more direct version of a [Zgcd], that can compute within Coq. - For that, we use an explicit measure in [nat], and we proved later - that using [2(d+1)] is enough, where [d] is the number of binary digits - of the first argument. *) - -Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b => - match n with - | O => 1 (* arbitrary, since n should be big enough *) - | S n => match a with - | Z0 => Zabs b - | Zpos _ => Zgcdn n (Zmod b a) a - | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a) - end - end. - -(* For technical reason, we don't use [Ndigit.Psize] but this - ad-hoc version: [Psize p = S (Psiz p)]. *) - -Fixpoint Psiz (p:positive) : nat := - match p with - | xH => O - | xI p => S (Psiz p) - | xO p => S (Psiz p) - end. - -Definition Zgcd_bound (a:Z) := match a with - | Z0 => S O - | Zpos p => let n := Psiz p in S (S (n+n)) - | Zneg p => let n := Psiz p in S (S (n+n)) -end. - -Definition Zgcd a b := Zgcdn (Zgcd_bound a) a b. - -(** A first obvious fact : [Zgcd a b] is positive. *) - -Lemma Zgcdn_is_pos : forall n a b, - 0 <= Zgcdn n a b. -Proof. -induction n. -simpl; auto with zarith. -destruct a; simpl; intros; auto with zarith; auto. -Qed. - -Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b. -Proof. -intros; unfold Zgcd; apply Zgcdn_is_pos; auto. -Qed. - -(** We now prove that Zgcd is indeed a gcd. *) - -(** 1) We prove a weaker & easier bound. *) - -Lemma Zgcdn_linear_bound : forall n a b, - Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b). -Proof. -induction n. -simpl; intros. -elimtype False; generalize (Zabs_pos a); omega. -destruct a; intros; simpl; - [ generalize (Zis_gcd_0_abs b); intuition | | ]; - unfold Zmod; - generalize (Z_div_mod b (Zpos p) (refl_equal Gt)); - destruct (Zdiv_eucl b (Zpos p)) as (q,r); - intros (H0,H1); - rewrite inj_S in H; simpl Zabs in H; - assert (H2: Zabs r < Z_of_nat n) by (rewrite Zabs_eq; auto with zarith); - assert (IH:=IHn r (Zpos p) H2); clear IHn; - simpl in IH |- *; - rewrite H0. - apply Zis_gcd_for_euclid2; auto. - apply Zis_gcd_minus; apply Zis_gcd_sym. - apply Zis_gcd_for_euclid2; auto. -Qed. - -(** 2) For Euclid's algorithm, the worst-case situation corresponds - to Fibonacci numbers. Let's define them: *) - -Fixpoint fibonacci (n:nat) : Z := - match n with - | O => 1 - | S O => 1 - | S (S n as p) => fibonacci p + fibonacci n - end. - -Lemma fibonacci_pos : forall n, 0 <= fibonacci n. -Proof. -cut (forall N n, (n<N)%nat -> 0<=fibonacci n). -eauto. -induction N. -inversion 1. -intros. -destruct n. -simpl; auto with zarith. -destruct n. -simpl; auto with zarith. -change (0 <= fibonacci (S n) + fibonacci n). -generalize (IHN n) (IHN (S n)); omega. -Qed. - -Lemma fibonacci_incr : - forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. -Proof. -induction 1. -auto with zarith. -apply Zle_trans with (fibonacci m); auto. -clear. -destruct m. -simpl; auto with zarith. -change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). -generalize (fibonacci_pos m); omega. -Qed. - -(** 3) We prove that fibonacci numbers are indeed worst-case: - for a given number [n], if we reach a conclusion about [gcd(a,b)] in - exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *) - -Lemma Zgcdn_worst_is_fibonacci : forall n a b, - 0 < a < b -> - Zis_gcd a b (Zgcdn (S n) a b) -> - Zgcdn n a b <> Zgcdn (S n) a b -> - fibonacci (S n) <= a /\ - fibonacci (S (S n)) <= b. -Proof. -induction n. -simpl; intros. -destruct a; omega. -intros. -destruct a; [simpl in *; omega| | destruct H; discriminate]. -revert H1; revert H0. -set (m:=S n) in *; (assert (m=S n) by auto); clearbody m. -pattern m at 2; rewrite H0. -simpl Zgcdn. -unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). -destruct (Zdiv_eucl b (Zpos p)) as (q,r). -intros (H1,H2). -destruct H2. -destruct (Zle_lt_or_eq _ _ H2). -generalize (IHn _ _ (conj H4 H3)). -intros H5 H6 H7. -replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto. -assert (r = Zpos p * (-q) + b) by (rewrite H1; ring). -destruct H5; auto. -pattern r at 1; rewrite H8. -apply Zis_gcd_sym. -apply Zis_gcd_for_euclid2; auto. -apply Zis_gcd_sym; auto. -split; auto. -rewrite H1. -apply Zplus_le_compat; auto. -apply Zle_trans with (Zpos p * 1); auto. -ring (Zpos p * 1); auto. -apply Zmult_le_compat_l. -destruct q. -omega. -assert (0 < Zpos p0) by (compute; auto). -omega. -assert (Zpos p * Zneg p0 < 0) by (compute; auto). -omega. -compute; intros; discriminate. -(* r=0 *) -subst r. -simpl; rewrite H0. -intros. -simpl in H4. -simpl in H5. -destruct n. -simpl in H5. -simpl. -omega. -simpl in H5. -elim H5; auto. -Qed. - -(** 3b) We reformulate the previous result in a more positive way. *) - -Lemma Zgcdn_ok_before_fibonacci : forall n a b, - 0 < a < b -> a < fibonacci (S n) -> - Zis_gcd a b (Zgcdn n a b). -Proof. -destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate]. -cut (forall k n b, - k = (S (nat_of_P p) - n)%nat -> - 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> - Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)). -destruct 2; eauto. -clear n; induction k. -intros. -assert (nat_of_P p < n)%nat by omega. -apply Zgcdn_linear_bound. -simpl. -generalize (inj_le _ _ H2). -rewrite inj_S. -rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto. -omega. -intros. -generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros. -assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)). - apply IHk; auto. - omega. - replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto. - generalize (fibonacci_pos n); omega. -replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. -generalize (H2 H3); clear H2 H3; omega. -Qed. - -(** 4) The proposed bound leads to a fibonacci number that is big enough. *) - -Lemma Zgcd_bound_fibonacci : - forall a, 0 < a -> a < fibonacci (Zgcd_bound a). -Proof. -destruct a; [omega| | intro H; discriminate]. -intros _. -induction p. -simpl Zgcd_bound in *. -rewrite Zpos_xI. -rewrite plus_comm; simpl plus. -set (n:=S (Psiz p+Psiz p)) in *. -change (2*Zpos p+1 < - fibonacci (S n) + fibonacci n + fibonacci (S n)). -generalize (fibonacci_pos n). -omega. -simpl Zgcd_bound in *. -rewrite Zpos_xO. -rewrite plus_comm; simpl plus. -set (n:= S (Psiz p +Psiz p)) in *. -change (2*Zpos p < - fibonacci (S n) + fibonacci n + fibonacci (S n)). -generalize (fibonacci_pos n). -omega. -simpl; auto with zarith. -Qed. - -(* 5) the end: we glue everything together and take care of - situations not corresponding to [0<a<b]. *) - -Lemma Zgcd_is_gcd : - forall a b, Zis_gcd a b (Zgcd a b). -Proof. -unfold Zgcd; destruct a; intros. -simpl; generalize (Zis_gcd_0_abs b); intuition. -(*Zpos*) -generalize (Zgcd_bound_fibonacci (Zpos p)). -simpl Zgcd_bound. -set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n. -simpl Zgcdn. -unfold Zmod. -generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). -destruct (Zdiv_eucl b (Zpos p)) as (q,r). -intros (H1,H2) H3. -rewrite H1. -apply Zis_gcd_for_euclid2. -destruct H2. -destruct (Zle_lt_or_eq _ _ H0). -apply Zgcdn_ok_before_fibonacci; auto; omega. -subst r n; simpl. -apply Zis_gcd_sym; apply Zis_gcd_0. -(*Zneg*) -generalize (Zgcd_bound_fibonacci (Zpos p)). -simpl Zgcd_bound. -set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n. -simpl Zgcdn. -unfold Zmod. -generalize (Z_div_mod b (Zpos p) (refl_equal Gt)). -destruct (Zdiv_eucl b (Zpos p)) as (q,r). -intros (H1,H2) H3. -rewrite H1. -apply Zis_gcd_minus. -apply Zis_gcd_sym. -apply Zis_gcd_for_euclid2. -destruct H2. -destruct (Zle_lt_or_eq _ _ H0). -apply Zgcdn_ok_before_fibonacci; auto; omega. -subst r n; simpl. -apply Zis_gcd_sym; apply Zis_gcd_0. -Qed. - -(** A generalized gcd: it additionnally keeps track of the divisors. *) - -Fixpoint Zggcdn (n:nat) : Z -> Z -> (Z*(Z*Z)) := fun a b => - match n with - | O => (1,(a,b)) (*(Zabs b,(0,Zsgn b))*) - | S n => match a with - | Z0 => (Zabs b,(0,Zsgn b)) - | Zpos _ => - let (q,r) := Zdiv_eucl b a in (* b = q*a+r *) - let (g,p) := Zggcdn n r a in - let (rr,aa) := p in (* r = g *rr /\ a = g * aa *) - (g,(aa,q*aa+rr)) - | Zneg a => - let (q,r) := Zdiv_eucl b (Zpos a) in (* b = q*(-a)+r *) - let (g,p) := Zggcdn n r (Zpos a) in - let (rr,aa) := p in (* r = g*rr /\ (-a) = g * aa *) - (g,(-aa,q*aa+rr)) - end - end. - -Definition Zggcd a b : Z * (Z * Z) := Zggcdn (Zgcd_bound a) a b. - -(** The first component of [Zggcd] is [Zgcd] *) - -Lemma Zggcdn_gcdn : forall n a b, - fst (Zggcdn n a b) = Zgcdn n a b. -Proof. -induction n; simpl; auto. -destruct a; unfold Zmod; simpl; intros; auto; - destruct (Zdiv_eucl b (Zpos p)) as (q,r); - rewrite <- IHn; - destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)); simpl; auto. -Qed. - -Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b. -Proof. -intros; unfold Zggcd, Zgcd; apply Zggcdn_gcdn; auto. -Qed. - -(** [Zggcd] always returns divisors that are coherent with its - first output. *) - -Lemma Zggcdn_correct_divisors : forall n a b, - let (g,p) := Zggcdn n a b in - let (aa,bb):=p in - a=g*aa /\ b=g*bb. -Proof. -induction n. -simpl. -split; [destruct a|destruct b]; auto. -intros. -simpl. -destruct a. -rewrite Zmult_comm; simpl. -split; auto. -symmetry; apply Zabs_Zsgn. -generalize (Z_div_mod b (Zpos p)); -destruct (Zdiv_eucl b (Zpos p)) as (q,r). -generalize (IHn r (Zpos p)); -destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)). -intuition. -destruct H0. -compute; auto. -rewrite H; rewrite H1; rewrite H2; ring. -generalize (Z_div_mod b (Zpos p)); -destruct (Zdiv_eucl b (Zpos p)) as (q,r). -destruct 1. -compute; auto. -generalize (IHn r (Zpos p)); -destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)). -intuition. -destruct H0. -replace (Zneg p) with (-Zpos p) by compute; auto. -rewrite H4; ring. -rewrite H; rewrite H4; rewrite H0; ring. -Qed. - -Lemma Zggcd_correct_divisors : forall a b, - let (g,p) := Zggcd a b in - let (aa,bb):=p in - a=g*aa /\ b=g*bb. -Proof. -unfold Zggcd; intros; apply Zggcdn_correct_divisors; auto. -Qed. - -(** Due to the use of an explicit measure, the extraction of [Zgcd] - isn't optimal. We propose here another version [Zgcd_spec] that - doesn't suffer from this problem (but doesn't compute in Coq). *) - -Definition Zgcd_spec_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 - (Zlt_0_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). -generalize (Zis_gcd_0_abs b); intuition. -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 _ H b. -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_spec_pos (- a) H b); intros g Hgkl. -exists g. -intuition. -intros Ha b; elim (Zgcd_spec_pos a Ha b); intros g; exists g; intuition. -Defined. - -(** A last version aimed at extraction that also returns the divisors. *) - -Definition Zggcd_spec_pos : - forall a:Z, - 0 <= a -> forall b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in - 0 <= a -> Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}. -Proof. -intros a Ha. -pattern a; apply Zlt_0_rec; try assumption. -intro x; case x. -intros _ _ b; exists (Zabs b,(0,Zsgn b)). -intros _; apply Zis_gcd_0_abs. - -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. -destruct (Hrec r H0 (Zpos p)) as ((g,(rr,pp)),Hgkl). -destruct H0. -destruct (Hgkl H0) as (H3,(H4,(H5,H6))). -exists (g,(pp,pp*q+rr)); intros. -split; auto. -rewrite H. -apply Zis_gcd_for_euclid2; auto. -repeat split; auto. -rewrite H; rewrite H6; rewrite H5; ring. - -intros p _ H b. -elim H; auto. -Defined. - -Definition Zggcd_spec : - forall a b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in - Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}. -Proof. -intros a; case (Z_gt_le_dec 0 a). -intros; assert (0 <= - a). -omega. -destruct (Zggcd_spec_pos (- a) H b) as ((g,(aa,bb)),Hgkl). -exists (g,(-aa,bb)). -intuition. -rewrite <- Zopp_mult_distr_r. -rewrite <- H2; auto with zarith. -intros Ha b; elim (Zggcd_spec_pos a Ha b); intros p; exists p. - repeat destruct p; intuition. -Defined. (** * Relative primality *) @@ -920,32 +470,25 @@ assert (g <> 0). 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. +destruct H1. +destruct H1 as (a',H1). +destruct H3 as (b',H3). +replace (a/g) with a'; + [|rewrite H1; rewrite Z_div_mult; auto with zarith]. +replace (b/g) with b'; + [|rewrite H3; rewrite Z_div_mult; auto with zarith]. +constructor. +exists a'; auto with zarith. +exists b'; auto with zarith. +intros x (xa,H5) (xb,H6). +destruct (H4 (x*g)). +exists xa; rewrite Zmult_assoc; rewrite <- H5; auto. +exists xb; rewrite Zmult_assoc; rewrite <- H6; auto. +replace g with (1*g) in H7; auto with zarith. +do 2 rewrite Zmult_assoc in H7. +generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros. +rewrite Zmult_1_r in H7. +exists q; auto with zarith. Qed. (** * Primality *) @@ -1045,3 +588,350 @@ case (Zdivide_dec p a); intuition. right; apply Gauss with a; auto with zarith. Qed. + +(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose + here a binary version of [Zgcd], faster and executable within Coq. + + Algorithm: + + gcd 0 b = b + gcd a 0 = a + gcd (2a) (2b) = 2(gcd a b) + gcd (2a+1) (2b) = gcd (2a+1) b + gcd (2a) (2b+1) = gcd a (2b+1) + gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1) + or gcd (a-b) (2*b+1), depending on whether a<b +*) + +Open Scope positive_scope. + +Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive := + match n with + | O => 1 + | S n => + match a,b with + | xH, _ => 1 + | _, xH => 1 + | xO a, xO b => xO (Pgcdn n a b) + | a, xO b => Pgcdn n a b + | xO a, b => Pgcdn n a b + | xI a', xI b' => match Pcompare a' b' Eq with + | Eq => a + | Lt => Pgcdn n (b'-a') a + | Gt => Pgcdn n (a'-b') b + end + end + end. + +Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := + match n with + | O => (1,(a,b)) + | S n => + match a,b with + | xH, b => (1,(1,b)) + | a, xH => (1,(a,1)) + | xO a, xO b => + let (g,p) := Pggcdn n a b in + (xO g,p) + | a, xO b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in + (g,(aa, xO bb)) + | xO a, b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in + (g,(xO aa, bb)) + | xI a', xI b' => match Pcompare a' b' Eq with + | Eq => (a,(1,1)) + | Lt => + let (g,p) := Pggcdn n (b'-a') a in + let (ba,aa) := p in + (g,(aa, aa + xO ba)) + | Gt => + let (g,p) := Pggcdn n (a'-b') b in + let (ab,bb) := p in + (g,(bb+xO ab, bb)) + end + end + end. + +Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b. +Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b. + +Open Scope Z_scope. + +Definition Zgcd (a b : Z) : Z := match a,b with + | Z0, _ => Zabs b + | _, Z0 => Zabs a + | Zpos a, Zpos b => Zpos (Pgcd a b) + | Zpos a, Zneg b => Zpos (Pgcd a b) + | Zneg a, Zpos b => Zpos (Pgcd a b) + | Zneg a, Zneg b => Zpos (Pgcd a b) +end. + +Definition Zggcd (a b : Z) : Z*(Z*Z) := match a,b with + | Z0, _ => (Zabs b,(0, Zsgn b)) + | _, Z0 => (Zabs a,(Zsgn a, 0)) + | Zpos a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in + (Zpos g, (Zpos aa, Zpos bb)) + | Zpos a, Zneg b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in + (Zpos g, (Zpos aa, Zneg bb)) + | Zneg a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in + (Zpos g, (Zneg aa, Zpos bb)) + | Zneg a, Zneg b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in + (Zpos g, (Zneg aa, Zneg bb)) +end. + +Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b. +Proof. +unfold Zgcd; destruct a; destruct b; auto with zarith. +Qed. + +Lemma Psize_monotone : forall p q, Pcompare p q Eq = Lt -> (Psize p <= Psize q)%nat. +Proof. +induction p; destruct q; simpl; auto with arith; intros; try discriminate. +intros; generalize (Pcompare_Gt_Lt _ _ H); auto with arith. +intros; destruct (Pcompare_Lt_Lt _ _ H); auto with arith; subst; auto. +Qed. + +Lemma Pminus_Zminus : forall a b, Pcompare a b Eq = Lt -> + Zpos (b-a) = Zpos b - Zpos a. +Proof. +intros. +repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +rewrite nat_of_P_minus_morphism. +apply inj_minus1. +apply lt_le_weak. +apply nat_of_P_lt_Lt_compare_morphism; auto. +rewrite ZC4; rewrite H; auto. +Qed. + +Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> + Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. +Proof. +intros. +destruct H. +constructor; auto. +destruct H as (e,H2); exists (2*e); auto with zarith. +rewrite Zpos_xO; rewrite H2; ring. +intros. +apply H1; auto. +rewrite Zpos_xO in H2. +rewrite Zpos_xI in H3. +apply Gauss with 2; auto. +apply bezout_rel_prime. +destruct H3 as (bb, H3). +apply Bezout_intro with bb (-Zpos b). +omega. +Qed. + +Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> + Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)). +Proof. +intro n; pattern n; apply lt_wf_ind; clear n; intros. +destruct n. +simpl. +destruct a; simpl in *; try inversion H0. +destruct a. +destruct b; simpl. +case_eq (Pcompare a b Eq); intros. +(* a = xI, b = xI, compare = Eq *) +rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl. +(* a = xI, b = xI, compare = Lt *) +apply Zis_gcd_sym. +apply Zis_gcd_for_euclid with 1. +apply Zis_gcd_sym. +replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))). +apply Zis_gcd_even_odd. +apply H; auto. +simpl in *. +assert (Psize (b-a) <= Psize b)%nat. + apply Psize_monotone. + change (Zpos (b-a) < Zpos b). + rewrite (Pminus_Zminus _ _ H1). + assert (0 < Zpos a) by (compute; auto). + omega. +omega. +rewrite Zpos_xO; do 2 rewrite Zpos_xI. +rewrite Pminus_Zminus; auto. +omega. +(* a = xI, b = xI, compare = Gt *) +apply Zis_gcd_for_euclid with 1. +replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))). +apply Zis_gcd_sym. +apply Zis_gcd_even_odd. +apply H; auto. +simpl in *. +assert (Psize (a-b) <= Psize a)%nat. + apply Psize_monotone. + change (Zpos (a-b) < Zpos a). + rewrite (Pminus_Zminus b a). + assert (0 < Zpos b) by (compute; auto). + omega. + rewrite ZC4; rewrite H1; auto. +omega. +rewrite Zpos_xO; do 2 rewrite Zpos_xI. +rewrite Pminus_Zminus; auto. +omega. +rewrite ZC4; rewrite H1; auto. +(* a = xI, b = xO *) +apply Zis_gcd_sym. +apply Zis_gcd_even_odd. +apply Zis_gcd_sym. +apply H; auto. +simpl in *; omega. +(* a = xI, b = xH *) +apply Zis_gcd_1. +destruct b; simpl. +(* a = xO, b = xI *) +apply Zis_gcd_even_odd. +apply H; auto. +simpl in *; omega. +(* a = xO, b = xO *) +rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)). +apply Zis_gcd_mult. +apply H; auto. +simpl in *; omega. +(* a = xO, b = xH *) +apply Zis_gcd_1. +(* a = xH *) +simpl; apply Zis_gcd_sym; apply Zis_gcd_1. +Qed. + +Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)). +Proof. +unfold Pgcd; intros. +apply Pgcdn_correct; auto. +Qed. + +Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b). +Proof. +destruct a. +intros. +simpl. +apply Zis_gcd_0_abs. +destruct b; simpl. +apply Zis_gcd_0. +apply Pgcd_correct. +apply Zis_gcd_sym. +apply Zis_gcd_minus; simpl. +apply Pgcd_correct. +destruct b; simpl. +apply Zis_gcd_minus; simpl. +apply Zis_gcd_sym. +apply Zis_gcd_0. +apply Zis_gcd_minus; simpl. +apply Zis_gcd_sym. +apply Pgcd_correct. +apply Zis_gcd_sym. +apply Zis_gcd_minus; simpl. +apply Zis_gcd_minus; simpl. +apply Zis_gcd_sym. +apply Pgcd_correct. +Qed. + + +Lemma Pggcdn_gcdn : forall n a b, + fst (Pggcdn n a b) = Pgcdn n a b. +Proof. +induction n. +simpl; auto. +destruct a; destruct b; simpl; auto. +destruct (Pcompare a b Eq); simpl; auto. +rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto. +rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto. +rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto. +rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto. +rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto. +Qed. + +Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b. +Proof. +intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b). +Qed. + +Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b. +Proof. +destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; +destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto. +Qed. + +Open Scope positive_scope. + +Lemma Pggcdn_correct_divisors : forall n a b, + let (g,p) := Pggcdn n a b in + let (aa,bb):=p in + (a=g*aa) /\ (b=g*bb). +Proof. +induction n. +simpl; auto. +destruct a; destruct b; simpl; auto. +case_eq (Pcompare a b Eq); intros. +(* Eq *) +rewrite Pmult_comm; simpl; auto. +rewrite (Pcompare_Eq_eq _ _ H); auto. +(* Lt *) +generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl. +intros (H0,H1); split; auto. +rewrite Pmult_plus_distr_l. +rewrite Pmult_xO_permute_r. +rewrite <- H1; rewrite <- H0. +simpl; f_equal; symmetry. +apply Pplus_minus; auto. +rewrite ZC4; rewrite H; auto. +(* Gt *) +generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl. +intros (H0,H1); split; auto. +rewrite Pmult_plus_distr_l. +rewrite Pmult_xO_permute_r. +rewrite <- H1; rewrite <- H0. +simpl; f_equal; symmetry. +apply Pplus_minus; auto. +(* Then... *) +generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl. +intros (H0,H1); split; auto. +rewrite Pmult_xO_permute_r; rewrite H1; auto. +generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl. +intros (H0,H1); split; auto. +rewrite Pmult_xO_permute_r; rewrite H0; auto. +generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl. +intros (H0,H1); split; subst; auto. +Qed. + +Lemma Pggcd_correct_divisors : forall a b, + let (g,p) := Pggcd a b in + let (aa,bb):=p in + (a=g*aa) /\ (b=g*bb). +Proof. +intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b). +Qed. + +Open Scope Z_scope. + +Lemma Zggcd_correct_divisors : forall a b, + let (g,p) := Zggcd a b in + let (aa,bb):=p in + (a=g*aa) /\ (b=g*bb). +Proof. +destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; +generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); +destruct 1; subst; auto. +Qed. + +Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}. +Proof. + intros x y; exists (Zgcd x y). + split; [apply Zgcd_is_gcd | apply Zgcd_is_pos]. +Qed. + + + + diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 033fb0e6..d384541f 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacentries.ml 8751 2006-04-27 16:17:51Z courtieu $ i*) +(*i $Id: vernacentries.ml 9017 2006-07-05 17:27:34Z herbelin $ i*) (* Concrete syntax of the mathematical vernacular MV V2.6 *) @@ -789,6 +789,17 @@ let _ = optread=Pp_control.get_margin; optwrite=Pp_control.set_margin } +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + declare_bool_option + { optsync=false; + optkey=SecondaryTable("Ltac","Debug"); + optname="Ltac debug"; + optread=(fun () -> get_debug () <> Tactic_debug.DebugOff); + optwrite=vernac_debug } + let vernac_set_opacity opaq locqid = match Nametab.global locqid with | ConstRef sp -> @@ -1069,9 +1080,6 @@ let vernac_check_guard () = in msgnl message -let vernac_debug b = - set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) - let interp c = match c with (* Control (done in vernac) *) | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false @@ -1175,7 +1183,6 @@ let interp c = match c with | VernacGo g -> vernac_go g | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () - | VernacDebug b -> vernac_debug b | VernacProof tac -> vernac_set_end_tac tac (* Toplevel control *) | VernacToplevelControl e -> raise e diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index a00901a4..972d7ed9 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacexpr.ml 7936 2006-01-28 18:36:54Z herbelin $ i*) +(*i $Id: vernacexpr.ml 9017 2006-07-05 17:27:34Z herbelin $ i*) open Util open Names @@ -281,7 +281,6 @@ type vernac_expr = | VernacGo of goable | VernacShow of showable | VernacCheckGuard - | VernacDebug of bool | VernacProof of raw_tactic_expr (* Toplevel control *) | VernacToplevelControl of exn |