Codebase list coq / 03b9147
Merge commit 'upstream/8.0pl3+8.1beta.2' into 8.1 Samuel Mimram 17 years ago
113 changed file(s) with 6712 addition(s) and 3318 deletion(s). Raw diff Collapse all Expand all
+240
-175
.depend less more
281281 tactics/extraargs.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
282282 proofs/tacexpr.cmo tactics/setoid_replace.cmi pretyping/rawterm.cmi \
283283 proofs/proof_type.cmi parsing/pcoq.cmi kernel/names.cmi
284 tactics/extratactics.cmi: interp/topconstr.cmi kernel/term.cmi \
284 tactics/extratactics.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \
285285 proofs/tacexpr.cmo pretyping/rawterm.cmi proofs/proof_type.cmi \
286286 parsing/pcoq.cmi kernel/names.cmi interp/genarg.cmi
287287 tactics/hiddentac.cmi: kernel/term.cmi tactics/tacticals.cmi \
428428 contrib/funind/functional_principles_proofs.cmi: kernel/term.cmi \
429429 proofs/tacmach.cmi kernel/names.cmi
430430 contrib/funind/functional_principles_types.cmi: kernel/term.cmi \
431 proofs/tacmach.cmi pretyping/rawterm.cmi kernel/names.cmi
432 contrib/funind/indfun_common.cmi: kernel/term.cmi pretyping/rawterm.cmi \
433 lib/pp.cmi kernel/names.cmi library/libnames.cmi
431 proofs/tacmach.cmi pretyping/rawterm.cmi kernel/names.cmi \
432 library/libnames.cmi kernel/entries.cmi
433 contrib/funind/indfun_common.cmi: kernel/term.cmi proofs/tacexpr.cmo \
434 pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \
435 kernel/entries.cmi library/decl_kinds.cmo
434436 contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \
435437 kernel/names.cmi library/libnames.cmi
436438 contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \
479481 contrib/subtac/subtac_errors.cmi: lib/util.cmi lib/pp.cmi
480482 contrib/subtac/subtac_interp_fixpoint.cmi: lib/util.cmi interp/topconstr.cmi \
481483 lib/pp.cmi kernel/names.cmi library/libnames.cmi
482 contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
483 interp/topconstr.cmi kernel/names.cmi
484 contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi
484485 contrib/subtac/subtac_pretyping.cmi: interp/topconstr.cmi kernel/term.cmi \
485486 kernel/sign.cmi pretyping/pretyping.cmi kernel/names.cmi \
486487 library/global.cmi pretyping/evd.cmi kernel/environ.cmi
539540 ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \
540541 lib/system.cmi ide/preferences.cmi lib/pp.cmi proofs/pfedit.cmi \
541542 ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \
542 ide/coq_commands.cmo ide/coq.cmi ide/command_windows.cmi \
543 ide/blaster_window.cmo ide/coqide.cmi
543 config/coq_config.cmi ide/coq_commands.cmo ide/coq.cmi \
544 ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi
544545 ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \
545546 lib/system.cmx ide/preferences.cmx lib/pp.cmx proofs/pfedit.cmx \
546547 ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \
547 ide/coq_commands.cmx ide/coq.cmx ide/command_windows.cmx \
548 ide/blaster_window.cmx ide/coqide.cmi
548 config/coq_config.cmx ide/coq_commands.cmx ide/coq.cmx \
549 ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi
549550 ide/coq.cmo: toplevel/vernacexpr.cmo toplevel/vernacentries.cmi \
550551 toplevel/vernac.cmi lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
551552 proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi \
21802181 kernel/names.cmi library/nameops.cmi toplevel/mltop.cmi \
21812182 library/library.cmi library/libnames.cmi library/lib.cmi \
21822183 library/global.cmi library/declaremods.cmi kernel/declarations.cmi \
2183 toplevel/coqinit.cmi config/coq_config.cmi toplevel/cerrors.cmi \
2184 toplevel/coqtop.cmi
2184 toplevel/coqinit.cmi config/coq_config.cmi interp/constrintern.cmi \
2185 toplevel/cerrors.cmi toplevel/coqtop.cmi
21852186 toplevel/coqtop.cmx: kernel/vm.cmx toplevel/vernac.cmx kernel/vconv.cmx \
21862187 lib/util.cmx toplevel/usage.cmx toplevel/toplevel.cmx lib/system.cmx \
21872188 library/states.cmx lib/profile.cmx lib/pp.cmx lib/options.cmx \
21882189 kernel/names.cmx library/nameops.cmx toplevel/mltop.cmx \
21892190 library/library.cmx library/libnames.cmx library/lib.cmx \
21902191 library/global.cmx library/declaremods.cmx kernel/declarations.cmx \
2191 toplevel/coqinit.cmx config/coq_config.cmx toplevel/cerrors.cmx \
2192 toplevel/coqtop.cmi
2192 toplevel/coqinit.cmx config/coq_config.cmx interp/constrintern.cmx \
2193 toplevel/cerrors.cmx toplevel/coqtop.cmi
21932194 toplevel/discharge.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
21942195 kernel/sign.cmi kernel/names.cmi kernel/inductive.cmi kernel/entries.cmi \
21952196 kernel/declarations.cmi kernel/cooking.cmi toplevel/discharge.cmi
28502851 pretyping/tacred.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
28512852 kernel/sign.cmi pretyping/reductionops.cmi contrib/recdef/recdef.cmo \
28522853 pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
2853 lib/pp.cmi lib/options.cmi kernel/names.cmi library/nameops.cmi \
2854 library/libnames.cmi contrib/funind/indfun_common.cmi \
2855 tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \
2856 pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \
2857 kernel/entries.cmi tactics/elim.cmi tactics/eauto.cmi \
2858 kernel/declarations.cmi interp/coqlib.cmi kernel/closure.cmi \
2859 toplevel/cerrors.cmi contrib/funind/functional_principles_proofs.cmi
2854 lib/pp.cmi proofs/pfedit.cmi lib/options.cmi library/nametab.cmi \
2855 kernel/names.cmi library/nameops.cmi library/libnames.cmi \
2856 contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
2857 interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \
2858 kernel/environ.cmi kernel/entries.cmi tactics/elim.cmi tactics/eauto.cmi \
2859 kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \
2860 toplevel/command.cmi kernel/closure.cmi toplevel/cerrors.cmi \
2861 contrib/funind/functional_principles_proofs.cmi
28602862 contrib/funind/functional_principles_proofs.cmx: lib/util.cmx \
28612863 pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
28622864 tactics/tactics.cmx tactics/tacticals.cmx proofs/tactic_debug.cmx \
28632865 pretyping/tacred.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
28642866 kernel/sign.cmx pretyping/reductionops.cmx contrib/recdef/recdef.cmx \
28652867 pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
2866 lib/pp.cmx lib/options.cmx kernel/names.cmx library/nameops.cmx \
2867 library/libnames.cmx contrib/funind/indfun_common.cmx \
2868 tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \
2869 pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \
2870 kernel/entries.cmx tactics/elim.cmx tactics/eauto.cmx \
2871 kernel/declarations.cmx interp/coqlib.cmx kernel/closure.cmx \
2872 toplevel/cerrors.cmx contrib/funind/functional_principles_proofs.cmi
2873 contrib/funind/functional_principles_types.cmo: toplevel/vernacexpr.cmo \
2874 toplevel/vernacentries.cmi lib/util.cmi pretyping/typing.cmi \
2875 pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
2876 tactics/tacticals.cmi pretyping/tacred.cmi proofs/tacmach.cmi \
2877 tactics/tacinterp.cmi lib/system.cmi proofs/proof_type.cmi \
2878 parsing/printer.cmi pretyping/pretyping.cmi parsing/ppconstr.cmi \
2879 lib/pp.cmi proofs/pfedit.cmi lib/options.cmi kernel/names.cmi \
2868 lib/pp.cmx proofs/pfedit.cmx lib/options.cmx library/nametab.cmx \
2869 kernel/names.cmx library/nameops.cmx library/libnames.cmx \
2870 contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
2871 interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \
2872 kernel/environ.cmx kernel/entries.cmx tactics/elim.cmx tactics/eauto.cmx \
2873 kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \
2874 toplevel/command.cmx kernel/closure.cmx toplevel/cerrors.cmx \
2875 contrib/funind/functional_principles_proofs.cmi
2876 contrib/funind/functional_principles_types.cmo: lib/util.cmi \
2877 pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
2878 tactics/tactics.cmi tactics/tacticals.cmi pretyping/tacred.cmi \
2879 proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \
2880 pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \
2881 pretyping/pretyping.cmi parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi \
2882 lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \
28802883 library/libnames.cmi pretyping/indrec.cmi \
28812884 contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
28822885 contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \
28832886 kernel/environ.cmi kernel/entries.cmi library/declare.cmi \
28842887 kernel/declarations.cmi library/decl_kinds.cmo toplevel/command.cmi \
2885 kernel/closure.cmi toplevel/cerrors.cmi \
2886 contrib/funind/functional_principles_types.cmi
2887 contrib/funind/functional_principles_types.cmx: toplevel/vernacexpr.cmx \
2888 toplevel/vernacentries.cmx lib/util.cmx pretyping/typing.cmx \
2889 pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \
2890 tactics/tacticals.cmx pretyping/tacred.cmx proofs/tacmach.cmx \
2891 tactics/tacinterp.cmx lib/system.cmx proofs/proof_type.cmx \
2892 parsing/printer.cmx pretyping/pretyping.cmx parsing/ppconstr.cmx \
2893 lib/pp.cmx proofs/pfedit.cmx lib/options.cmx kernel/names.cmx \
2888 kernel/closure.cmi contrib/funind/functional_principles_types.cmi
2889 contrib/funind/functional_principles_types.cmx: lib/util.cmx \
2890 pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
2891 tactics/tactics.cmx tactics/tacticals.cmx pretyping/tacred.cmx \
2892 proofs/tacmach.cmx tactics/tacinterp.cmx lib/system.cmx kernel/sign.cmx \
2893 pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \
2894 pretyping/pretyping.cmx parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx \
2895 lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \
28942896 library/libnames.cmx pretyping/indrec.cmx \
28952897 contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
28962898 contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \
28972899 kernel/environ.cmx kernel/entries.cmx library/declare.cmx \
28982900 kernel/declarations.cmx library/decl_kinds.cmx toplevel/command.cmx \
2899 kernel/closure.cmx toplevel/cerrors.cmx \
2900 contrib/funind/functional_principles_types.cmi
2901 kernel/closure.cmx contrib/funind/functional_principles_types.cmi
29012902 contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \
2902 kernel/term.cmi pretyping/rawterm.cmi lib/pp.cmi library/nametab.cmi \
2903 kernel/names.cmi library/libnames.cmi library/global.cmi \
2904 kernel/declarations.cmi interp/coqlib.cmi \
2905 contrib/funind/indfun_common.cmi
2903 kernel/term.cmi library/summary.cmi proofs/refiner.cmi \
2904 pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \
2905 parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \
2906 library/nametab.cmi kernel/names.cmi library/nameops.cmi \
2907 kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \
2908 library/lib.cmi library/global.cmi pretyping/evd.cmi \
2909 pretyping/evarutil.cmi kernel/entries.cmi library/declare.cmi \
2910 kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \
2911 kernel/closure.cmi contrib/funind/indfun_common.cmi
29062912 contrib/funind/indfun_common.cmx: lib/util.cmx pretyping/termops.cmx \
2907 kernel/term.cmx pretyping/rawterm.cmx lib/pp.cmx library/nametab.cmx \
2908 kernel/names.cmx library/libnames.cmx library/global.cmx \
2909 kernel/declarations.cmx interp/coqlib.cmx \
2910 contrib/funind/indfun_common.cmi
2913 kernel/term.cmx library/summary.cmx proofs/refiner.cmx \
2914 pretyping/reductionops.cmx pretyping/rawterm.cmx proofs/proof_type.cmx \
2915 parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \
2916 library/nametab.cmx kernel/names.cmx library/nameops.cmx \
2917 kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \
2918 library/lib.cmx library/global.cmx pretyping/evd.cmx \
2919 pretyping/evarutil.cmx kernel/entries.cmx library/declare.cmx \
2920 kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \
2921 kernel/closure.cmx contrib/funind/indfun_common.cmi
29112922 contrib/funind/indfun_main.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
29122923 interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
2913 tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
2914 tactics/tacinterp.cmi proofs/tacexpr.cmo kernel/sign.cmi \
2915 proofs/refiner.cmi pretyping/rawterm.cmi parsing/pptactic.cmi \
2916 parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \
2917 library/nameops.cmi parsing/lexer.cmi contrib/funind/invfun.cmo \
2918 pretyping/indrec.cmi contrib/funind/indfun_common.cmi \
2919 contrib/funind/indfun.cmo tactics/hiddentac.cmi interp/genarg.cmi \
2920 contrib/funind/functional_principles_types.cmi tactics/equality.cmi \
2921 parsing/egrammar.cmi toplevel/cerrors.cmi
2924 tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
2925 proofs/tacexpr.cmo proofs/refiner.cmi pretyping/rawterm.cmi \
2926 proofs/proof_type.cmi parsing/printer.cmi parsing/pptactic.cmi \
2927 parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi \
2928 kernel/names.cmi library/nameops.cmi parsing/lexer.cmi \
2929 contrib/funind/invfun.cmo contrib/funind/indfun_common.cmi \
2930 contrib/funind/indfun.cmo interp/genarg.cmi \
2931 contrib/funind/functional_principles_types.cmi parsing/egrammar.cmi \
2932 toplevel/cerrors.cmi
29222933 contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
29232934 interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
2935 tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
2936 proofs/tacexpr.cmx proofs/refiner.cmx pretyping/rawterm.cmx \
2937 proofs/proof_type.cmx parsing/printer.cmx parsing/pptactic.cmx \
2938 parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx library/nametab.cmx \
2939 kernel/names.cmx library/nameops.cmx parsing/lexer.cmx \
2940 contrib/funind/invfun.cmx contrib/funind/indfun_common.cmx \
2941 contrib/funind/indfun.cmx interp/genarg.cmx \
2942 contrib/funind/functional_principles_types.cmx parsing/egrammar.cmx \
2943 toplevel/cerrors.cmx
2944 contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
2945 interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
2946 tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \
2947 tactics/tacinterp.cmi proofs/tacexpr.cmo library/states.cmi \
2948 kernel/sign.cmi contrib/recdef/recdef.cmo \
2949 contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \
2950 parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \
2951 interp/notation.cmi kernel/names.cmi library/nameops.cmi \
2952 library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \
2953 contrib/funind/indfun_common.cmi library/impargs.cmi \
2954 tactics/hiddentac.cmi library/global.cmi \
2955 contrib/funind/functional_principles_types.cmi \
2956 contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \
2957 tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \
2958 library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \
2959 toplevel/command.cmi toplevel/cerrors.cmi
2960 contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
2961 interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
29242962 tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \
2925 tactics/tacinterp.cmx proofs/tacexpr.cmx kernel/sign.cmx \
2926 proofs/refiner.cmx pretyping/rawterm.cmx parsing/pptactic.cmx \
2927 parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \
2928 library/nameops.cmx parsing/lexer.cmx contrib/funind/invfun.cmx \
2929 pretyping/indrec.cmx contrib/funind/indfun_common.cmx \
2930 contrib/funind/indfun.cmx tactics/hiddentac.cmx interp/genarg.cmx \
2931 contrib/funind/functional_principles_types.cmx tactics/equality.cmx \
2932 parsing/egrammar.cmx toplevel/cerrors.cmx
2933 contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
2934 interp/topconstr.cmi kernel/term.cmi proofs/tacmach.cmi \
2935 library/states.cmi contrib/recdef/recdef.cmo \
2936 contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \
2937 parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi interp/notation.cmi \
2938 kernel/names.cmi library/nameops.cmi library/libnames.cmi \
2939 pretyping/indrec.cmi contrib/funind/indfun_common.cmi library/impargs.cmi \
2940 library/global.cmi contrib/funind/functional_principles_types.cmi \
2941 contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \
2942 kernel/environ.cmi kernel/declarations.cmi library/decl_kinds.cmo \
2943 interp/constrintern.cmi interp/constrextern.cmi toplevel/command.cmi \
2944 toplevel/cerrors.cmi
2945 contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
2946 interp/topconstr.cmx kernel/term.cmx proofs/tacmach.cmx \
2947 library/states.cmx contrib/recdef/recdef.cmx \
2963 tactics/tacinterp.cmx proofs/tacexpr.cmx library/states.cmx \
2964 kernel/sign.cmx contrib/recdef/recdef.cmx \
29482965 contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \
2949 parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx interp/notation.cmx \
2950 kernel/names.cmx library/nameops.cmx library/libnames.cmx \
2951 pretyping/indrec.cmx contrib/funind/indfun_common.cmx library/impargs.cmx \
2952 library/global.cmx contrib/funind/functional_principles_types.cmx \
2966 parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \
2967 interp/notation.cmx kernel/names.cmx library/nameops.cmx \
2968 library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \
2969 contrib/funind/indfun_common.cmx library/impargs.cmx \
2970 tactics/hiddentac.cmx library/global.cmx \
2971 contrib/funind/functional_principles_types.cmx \
29532972 contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \
2954 kernel/environ.cmx kernel/declarations.cmx library/decl_kinds.cmx \
2955 interp/constrintern.cmx interp/constrextern.cmx toplevel/command.cmx \
2956 toplevel/cerrors.cmx
2957 contrib/funind/invfun.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
2958 tactics/tacticals.cmi proofs/tacmach.cmi contrib/funind/tacinvutils.cmi \
2959 kernel/sign.cmi pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi \
2960 library/libnames.cmi contrib/funind/indfun_common.cmi \
2961 tactics/hiddentac.cmi library/global.cmi tactics/extratactics.cmi \
2962 tactics/equality.cmi kernel/declarations.cmi
2963 contrib/funind/invfun.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
2964 tactics/tacticals.cmx proofs/tacmach.cmx contrib/funind/tacinvutils.cmx \
2965 kernel/sign.cmx pretyping/rawterm.cmx lib/pp.cmx kernel/names.cmx \
2966 library/libnames.cmx contrib/funind/indfun_common.cmx \
2967 tactics/hiddentac.cmx library/global.cmx tactics/extratactics.cmx \
2968 tactics/equality.cmx kernel/declarations.cmx
2973 tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \
2974 library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \
2975 toplevel/command.cmx toplevel/cerrors.cmx
2976 contrib/funind/invfun.cmo: toplevel/vernacentries.cmi lib/util.cmi \
2977 pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
2978 tactics/tauto.cmo tactics/tactics.cmi tactics/tacticals.cmi \
2979 proofs/tactic_debug.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \
2980 proofs/tacexpr.cmo kernel/sign.cmi lib/rtree.cmi \
2981 pretyping/reductionops.cmi pretyping/rawterm.cmi parsing/printer.cmi \
2982 parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi \
2983 library/nameops.cmi library/libnames.cmi tactics/inv.cmi \
2984 kernel/inductive.cmi pretyping/indrec.cmi \
2985 contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
2986 interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \
2987 kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \
2988 library/decl_kinds.cmo interp/coqlib.cmi toplevel/command.cmi \
2989 kernel/closure.cmi toplevel/cerrors.cmi
2990 contrib/funind/invfun.cmx: toplevel/vernacentries.cmx lib/util.cmx \
2991 pretyping/typing.cmx pretyping/termops.cmx kernel/term.cmx \
2992 tactics/tauto.cmx tactics/tactics.cmx tactics/tacticals.cmx \
2993 proofs/tactic_debug.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \
2994 proofs/tacexpr.cmx kernel/sign.cmx lib/rtree.cmx \
2995 pretyping/reductionops.cmx pretyping/rawterm.cmx parsing/printer.cmx \
2996 parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx \
2997 library/nameops.cmx library/libnames.cmx tactics/inv.cmx \
2998 kernel/inductive.cmx pretyping/indrec.cmx \
2999 contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
3000 interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \
3001 kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
3002 library/decl_kinds.cmx interp/coqlib.cmx toplevel/command.cmx \
3003 kernel/closure.cmx toplevel/cerrors.cmx
29693004 contrib/funind/rawtermops.cmo: lib/util.cmi proofs/tactic_debug.cmi \
29703005 tactics/tacinterp.cmi pretyping/rawterm.cmi parsing/printer.cmi \
29713006 parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
35583593 interp/genarg.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
35593594 contrib/subtac/eterm.cmi kernel/environ.cmi kernel/entries.cmi \
35603595 lib/dyn.cmi library/declare.cmi kernel/declarations.cmi \
3561 library/decl_kinds.cmo interp/constrintern.cmi toplevel/command.cmi \
3562 kernel/closure.cmi contrib/subtac/subtac_command.cmi
3596 library/decl_kinds.cmo interp/coqlib.cmi interp/constrintern.cmi \
3597 toplevel/command.cmi kernel/closure.cmi contrib/subtac/subtac_command.cmi
35633598 contrib/subtac/subtac_command.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
35643599 pretyping/typing.cmx interp/topconstr.cmx pretyping/termops.cmx \
35653600 kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \
35783613 interp/genarg.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
35793614 contrib/subtac/eterm.cmx kernel/environ.cmx kernel/entries.cmx \
35803615 lib/dyn.cmx library/declare.cmx kernel/declarations.cmx \
3581 library/decl_kinds.cmx interp/constrintern.cmx toplevel/command.cmx \
3582 kernel/closure.cmx contrib/subtac/subtac_command.cmi
3616 library/decl_kinds.cmx interp/coqlib.cmx interp/constrintern.cmx \
3617 toplevel/command.cmx kernel/closure.cmx contrib/subtac/subtac_command.cmi
35833618 contrib/subtac/subtac_errors.cmo: lib/util.cmi parsing/printer.cmi lib/pp.cmi \
35843619 contrib/subtac/subtac_errors.cmi
35853620 contrib/subtac/subtac_errors.cmx: lib/util.cmx parsing/printer.cmx lib/pp.cmx \
36113646 contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
36123647 kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \
36133648 kernel/term.cmi contrib/subtac/subtac_utils.cmi \
3614 contrib/subtac/subtac_pretyping.cmi \
3615 contrib/subtac/subtac_interp_fixpoint.cmi \
3616 contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_command.cmi \
3617 contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \
3618 pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \
3619 parsing/printer.cmi pretyping/pretype_errors.cmi parsing/ppconstr.cmi \
3620 lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \
3621 library/nametab.cmi kernel/names.cmi library/library.cmi \
3649 contrib/subtac/subtac_pretyping.cmi contrib/subtac/subtac_errors.cmi \
3650 contrib/subtac/subtac_command.cmi contrib/subtac/subtac_coercion.cmi \
3651 kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \
3652 pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \
3653 parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi \
3654 lib/options.cmi library/nametab.cmi kernel/names.cmi library/library.cmi \
36223655 library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \
36233656 library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \
36243657 pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \
36283661 contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
36293662 kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \
36303663 kernel/term.cmx contrib/subtac/subtac_utils.cmx \
3631 contrib/subtac/subtac_pretyping.cmx \
3632 contrib/subtac/subtac_interp_fixpoint.cmx \
3633 contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_command.cmx \
3634 contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \
3635 pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \
3636 parsing/printer.cmx pretyping/pretype_errors.cmx parsing/ppconstr.cmx \
3637 lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \
3638 library/nametab.cmx kernel/names.cmx library/library.cmx \
3664 contrib/subtac/subtac_pretyping.cmx contrib/subtac/subtac_errors.cmx \
3665 contrib/subtac/subtac_command.cmx contrib/subtac/subtac_coercion.cmx \
3666 kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \
3667 pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \
3668 parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx \
3669 lib/options.cmx library/nametab.cmx kernel/names.cmx library/library.cmx \
36393670 library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \
36403671 library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \
36413672 pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \
38083839 parsing/egrammar.cmx toplevel/cerrors.cmx
38093840 contrib/xml/xml.cmo: contrib/xml/xml.cmi
38103841 contrib/xml/xml.cmx: contrib/xml/xml.cmi
3811 doc/refman/euclid.cmo: doc/refman/euclid.cmi
3812 doc/refman/euclid.cmx: doc/refman/euclid.cmi
3813 doc/refman/heapsort.cmo: doc/refman/heapsort.cmi
3814 doc/refman/heapsort.cmx: doc/refman/heapsort.cmi
38153842 ide/utils/config_file.cmo: ide/utils/config_file.cmi
38163843 ide/utils/config_file.cmx: ide/utils/config_file.cmi
38173844 ide/utils/configwin_html_config.cmo: ide/utils/configwin_types.cmo \
39633990 tools/coq-tex.cmo:
39643991 tools/coq-tex.cmx:
39653992 coq_fix_code.o: kernel/byterun/coq_fix_code.c \
3966 /usr/local/lib/ocaml/caml/config.h \
3967 /usr/local/lib/ocaml/caml/compatibility.h \
3968 /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/mlvalues.h \
3969 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
3993 /user/jforest/home//lib/ocaml/caml/config.h \
3994 /user/jforest/home//lib/ocaml/caml/compatibility.h \
3995 /user/jforest/home//lib/ocaml/caml/misc.h \
3996 /user/jforest/home//lib/ocaml/caml/config.h \
3997 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
3998 /user/jforest/home//lib/ocaml/caml/misc.h \
3999 /user/jforest/home//lib/ocaml/caml/fail.h \
4000 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4001 /user/jforest/home//lib/ocaml/caml/memory.h \
39704002 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h
39714003 coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \
3972 /usr/local/lib/ocaml/caml/mlvalues.h \
3973 /usr/local/lib/ocaml/caml/compatibility.h \
3974 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
3975 /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \
3976 kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \
3977 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
3978 kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h
4004 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4005 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4006 /user/jforest/home//lib/ocaml/caml/config.h \
4007 /user/jforest/home//lib/ocaml/caml/misc.h \
4008 /user/jforest/home//lib/ocaml/caml/alloc.h \
4009 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4010 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
4011 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4012 /user/jforest/home//lib/ocaml/caml/fail.h \
4013 /user/jforest/home//lib/ocaml/caml/misc.h \
4014 /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
4015 kernel/byterun/coq_jumptbl.h
39794016 coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \
3980 /usr/local/lib/ocaml/caml/mlvalues.h \
3981 /usr/local/lib/ocaml/caml/compatibility.h \
3982 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
3983 /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \
3984 kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \
3985 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h
4017 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4018 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4019 /user/jforest/home//lib/ocaml/caml/config.h \
4020 /user/jforest/home//lib/ocaml/caml/misc.h \
4021 /user/jforest/home//lib/ocaml/caml/alloc.h \
4022 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4023 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
4024 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4025 /user/jforest/home//lib/ocaml/caml/fail.h \
4026 /user/jforest/home//lib/ocaml/caml/misc.h \
4027 /user/jforest/home//lib/ocaml/caml/memory.h
39864028 coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \
3987 /usr/local/lib/ocaml/caml/mlvalues.h \
3988 /usr/local/lib/ocaml/caml/compatibility.h \
3989 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
3990 kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \
3991 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
3992 kernel/byterun/coq_values.h /usr/local/lib/ocaml/caml/alloc.h
4029 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4030 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4031 /user/jforest/home//lib/ocaml/caml/config.h \
4032 /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \
4033 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4034 /user/jforest/home//lib/ocaml/caml/fail.h \
4035 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4036 /user/jforest/home//lib/ocaml/caml/misc.h \
4037 /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
4038 /user/jforest/home//lib/ocaml/caml/alloc.h
39934039 coq_fix_code.d.o: kernel/byterun/coq_fix_code.c \
3994 /usr/local/lib/ocaml/caml/config.h \
3995 /usr/local/lib/ocaml/caml/compatibility.h \
3996 /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/mlvalues.h \
3997 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
4040 /user/jforest/home//lib/ocaml/caml/config.h \
4041 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4042 /user/jforest/home//lib/ocaml/caml/misc.h \
4043 /user/jforest/home//lib/ocaml/caml/config.h \
4044 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4045 /user/jforest/home//lib/ocaml/caml/misc.h \
4046 /user/jforest/home//lib/ocaml/caml/fail.h \
4047 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4048 /user/jforest/home//lib/ocaml/caml/memory.h \
39984049 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h
39994050 coq_interp.d.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \
4000 /usr/local/lib/ocaml/caml/mlvalues.h \
4001 /usr/local/lib/ocaml/caml/compatibility.h \
4002 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
4003 /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \
4004 kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \
4005 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
4006 kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h
4051 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4052 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4053 /user/jforest/home//lib/ocaml/caml/config.h \
4054 /user/jforest/home//lib/ocaml/caml/misc.h \
4055 /user/jforest/home//lib/ocaml/caml/alloc.h \
4056 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4057 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
4058 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4059 /user/jforest/home//lib/ocaml/caml/fail.h \
4060 /user/jforest/home//lib/ocaml/caml/misc.h \
4061 /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
4062 kernel/byterun/coq_jumptbl.h
40074063 coq_memory.d.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \
4008 /usr/local/lib/ocaml/caml/mlvalues.h \
4009 /usr/local/lib/ocaml/caml/compatibility.h \
4010 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
4011 /usr/local/lib/ocaml/caml/alloc.h kernel/byterun/coq_instruct.h \
4012 kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \
4013 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h
4064 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4065 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4066 /user/jforest/home//lib/ocaml/caml/config.h \
4067 /user/jforest/home//lib/ocaml/caml/misc.h \
4068 /user/jforest/home//lib/ocaml/caml/alloc.h \
4069 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4070 kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
4071 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4072 /user/jforest/home//lib/ocaml/caml/fail.h \
4073 /user/jforest/home//lib/ocaml/caml/misc.h \
4074 /user/jforest/home//lib/ocaml/caml/memory.h
40144075 coq_values.d.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \
4015 /usr/local/lib/ocaml/caml/mlvalues.h \
4016 /usr/local/lib/ocaml/caml/compatibility.h \
4017 /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \
4018 kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \
4019 /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/memory.h \
4020 kernel/byterun/coq_values.h /usr/local/lib/ocaml/caml/alloc.h
4076 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4077 /user/jforest/home//lib/ocaml/caml/compatibility.h \
4078 /user/jforest/home//lib/ocaml/caml/config.h \
4079 /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \
4080 kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
4081 /user/jforest/home//lib/ocaml/caml/fail.h \
4082 /user/jforest/home//lib/ocaml/caml/mlvalues.h \
4083 /user/jforest/home//lib/ocaml/caml/misc.h \
4084 /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
4085 /user/jforest/home//lib/ocaml/caml/alloc.h
+3
-50
.depend.coq less more
179179 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
180180 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
181181 theories/ZArith/Zbinary.vo: theories/ZArith/Zbinary.v theories/Bool/Bvector.vo theories/ZArith/ZArith.vo theories/ZArith/Zpower.vo contrib/omega/Omega.vo
182 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
182 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
183183 theories/ZArith/Int.vo: theories/ZArith/Int.v theories/ZArith/ZArith.vo contrib/romega/ROmega.vo
184184 theories/Setoids/Setoid.vo: theories/Setoids/Setoid.v theories/Relations/Relation_Definitions.vo
185185 theories/Lists/MonoList.vo: theories/Lists/MonoList.v theories/Arith/Le.vo
273273 theories/Reals/RIneq.vo: theories/Reals/RIneq.v theories/Reals/Raxioms.vo contrib/ring/ZArithRing.vo contrib/omega/Omega.vo contrib/field/Field.vo
274274 theories/Reals/DiscrR.vo: theories/Reals/DiscrR.v theories/Reals/RIneq.vo contrib/omega/Omega.vo
275275 theories/Reals/Rbase.vo: theories/Reals/Rbase.v theories/Reals/Rdefinitions.vo theories/Reals/Raxioms.vo theories/Reals/RIneq.vo theories/Reals/DiscrR.vo
276 theories/Reals/R_Ifp.vo: theories/Reals/R_Ifp.v theories/Reals/Rbase.vo contrib/omega/Omega.vo
277 theories/Reals/Rbasic_fun.vo: theories/Reals/Rbasic_fun.v theories/Reals/Rbase.vo theories/Reals/R_Ifp.vo contrib/fourier/Fourier.vo
278 theories/Reals/R_sqr.vo: theories/Reals/R_sqr.v theories/Reals/Rbase.vo theories/Reals/Rbasic_fun.vo
279 theories/Reals/SplitAbsolu.vo: theories/Reals/SplitAbsolu.v theories/Reals/Rbasic_fun.vo
280 theories/Reals/SplitRmult.vo: theories/Reals/SplitRmult.v theories/Reals/Rbase.vo
281 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
282 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
283 theories/Reals/Rseries.vo: theories/Reals/Rseries.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Logic/Classical.vo theories/Arith/Compare.vo
284 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
285 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
286 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
287 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
288 theories/Reals/Binomial.vo: theories/Reals/Binomial.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/PartSum.vo
289 theories/Reals/Rsigma.vo: theories/Reals/Rsigma.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rseries.vo theories/Reals/PartSum.vo
290 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
291 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
292 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
293 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
294 theories/Reals/Rtrigo_fun.vo: theories/Reals/Rtrigo_fun.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/SeqSeries.vo
295 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
296 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
297 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
298 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
299 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
300 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
301 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
302 theories/Reals/RList.vo: theories/Reals/RList.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo
303 theories/Reals/Ranalysis1.vo: theories/Reals/Ranalysis1.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rlimit.vo theories/Reals/Rderiv.vo
304 theories/Reals/Ranalysis2.vo: theories/Reals/Ranalysis2.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo
305 theories/Reals/Ranalysis3.vo: theories/Reals/Ranalysis3.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Ranalysis2.vo
306 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
307 theories/Reals/MVT.vo: theories/Reals/MVT.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Ranalysis1.vo theories/Reals/Rtopology.vo
308 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
309 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
310 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
311 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
312 theories/Reals/R_sqrt.vo: theories/Reals/R_sqrt.v theories/Reals/Rbase.vo theories/Reals/Rfunctions.vo theories/Reals/Rsqrt_def.vo
313 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
314 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
315 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
316 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
317 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
318 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
319 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
320 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
321 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
322 theories/Reals/Integration.vo: theories/Reals/Integration.v theories/Reals/NewtonInt.vo theories/Reals/RiemannInt_SF.vo theories/Reals/RiemannInt.vo
323 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
324276 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
325277 theories/Sorting/Permutation.vo: theories/Sorting/Permutation.v theories/Relations/Relations.vo theories/Lists/List.vo theories/Sets/Multiset.vo theories/Arith/Arith.vo
326278 theories/Sorting/Sorting.vo: theories/Sorting/Sorting.v theories/Lists/List.vo theories/Sets/Multiset.vo theories/Sorting/Permutation.vo theories/Relations/Relations.vo
331283 theories/QArith/Qring.vo: theories/QArith/Qring.v contrib/ring/Ring.vo contrib/ring/Setoid_ring.vo theories/QArith/QArith_base.vo
332284 theories/QArith/Qreals.vo: theories/QArith/Qreals.v theories/Reals/Rbase.vo theories/QArith/QArith_base.vo
333285 theories/QArith/QArith.vo: theories/QArith/QArith.v theories/QArith/QArith_base.vo theories/QArith/Qring.vo theories/QArith/Qreduction.vo
286 theories/QArith/Qcanon.vo: theories/QArith/Qcanon.v theories/QArith/QArith.vo theories/Logic/Eqdep_dec.vo contrib/field/Field.vo
334287 contrib/omega/OmegaLemmas.vo: contrib/omega/OmegaLemmas.v theories/ZArith/ZArith_base.vo
335288 contrib/omega/Omega.vo: contrib/omega/Omega.v theories/ZArith/ZArith_base.vo contrib/omega/OmegaLemmas.vo theories/ZArith/Zhints.vo
336289 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
352305 contrib/field/Field.vo: contrib/field/Field.v contrib/field/Field_Compl.vo contrib/field/Field_Theory.vo contrib/field/Field_Tactic.vo
353306 contrib/fourier/Fourier_util.vo: contrib/fourier/Fourier_util.v theories/Reals/Rbase.vo
354307 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
355 contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo
308 contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo theories/Arith/Wf_nat.vo theories/Arith/Lt.vo
356309 contrib/subtac/Utils.vo: contrib/subtac/Utils.v
357310 contrib/rtauto/Bintree.vo: contrib/rtauto/Bintree.v theories/Lists/List.vo theories/NArith/BinPos.vo
358311 contrib/rtauto/Rtauto.vo: contrib/rtauto/Rtauto.v theories/Lists/List.vo contrib/rtauto/Bintree.vo theories/Bool/Bool.vo theories/NArith/BinPos.vo
+48
-40
CHANGES less more
99
1010 - No more support for version 7 syntax and for translation to version 8 syntax.
1111 - In fixpoints, the { struct ... } annotation is not mandatory any more when
12 only one of the arguments has an inductive type (doc TODO)
13 - Added disjunctive patterns in match-with patterns (doc TODO)
14 - Support for primitive interpretation of string literals (doc TODO)
15 - Extended support for Unicode ranges (doc TODO)
12 only one of the arguments has an inductive type
13 - Added disjunctive patterns in match-with patterns
14 - Support for primitive interpretation of string literals
15 - Extended support for Unicode ranges
1616
1717 Vernacular commands
1818
19 - Added "Print Ltac qualid" to print a user defined tactic (doc TODO)
19 - Added "Print Ltac qualid" to print a user defined tactic.
2020 - Added "Print Rewrite HintDb" to print the content of a DB used by
21 autorewrite (doc TODO)
22 - Added "Print Canonical Projections" (doc TODO)
23 - Added "Example" as synonym of "Definition" (doc TODO)
24 - Added "Property", "Proposition" and "Corollary" as extra synonyms of "Lemma"
25 (doc TODO)
21 autorewrite.
22 - Added "Print Canonical Projections".
23 - Added "Example" as synonym of "Definition".
24 - Added "Proposition" and "Corollary" as extra synonyms of "Lemma".
2625 - New command "Whelp" to send requests to the Helm database of proofs
27 formalized in the Calculus of Inductive Constructions (doc TODO)
26 formalized in the Calculus of Inductive Constructions.
2827 - Command "functional induction" has been re-implemented from the new
29 "definition" command.
28 "Function" command.
3029
3130 Ltac and tactic syntactic extensions
3231
33 - New primitive "external" for communication with tool external to Coq
34 (doc TODO).
32 - New primitive "external" for communication with tool external to Coq.
3533 - New semantics for "match t with": if a clause returns a
3634 tactic, it is now applied to the current goal. If it fails, the next
3735 clause or next matching subterm is tried (i.e. it behaves as "match
38 goal with" does) (doc TODO).
36 goal with" does). The keyword "lazymatch" can be used to delay the
37 evaluation of tactics occurring in matching clauses.
3938 - Hint base names can be parametric in auto and trivial.
4039 - Occurrence values can be parametric in unfold, pattern, etc.
4140 - Added entry constr_may_eval for tactic extensions.
4241 - Low-priority term printer made available in ML-written tactic extensions.
43 - "Tactic Notation" extended to allow notations of tacticals (doc TODO).
42 - "Tactic Notation" extended to allow notations of tacticals.
4443
4544 Tactics
4645
5655 - "rewrite ... in" now accepts a clause as place where to rewrite instead of
5756 juste a simple hypothesis name. For instance:
5857 rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H
59 rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H
60 (doc TODO).
61 - Added "clear - id" to clear all hypotheses except the ones depending in id
62 (doc TODO).
58 rewrite H in * |- will do try rewrite H in Hi for all hypothesis Hi <> H.
6359 - Added "dependent rewrite term" and "dependent rewrite term in hyp" (doc TODO)
60 - Added "autorewrite with ... in hyp [using ...]".
61 - Tactic "replace" now accepts a "by" tactic clause.
62 - Added "clear - id" to clear all hypotheses except the ones depending in id.
6463 - The argument of Declare Left Step and Declare Right Step is now a term
65 (it used to be a reference) (doc TODO).
64 (it used to be a reference).
6665 - Omega now handles arbitrary precision integers.
6766 - Several bug fixes in Reflexive Omega (romega).
6867 - Idtac can now be left implicit in a [...|...] construct: for instance,
69 [ foo | | bar ] stands for [ foo | idtac | bar ] (doc TODO).
70 - Added "autorewrite with ... in hyp [using ...]" (doc TODO).
68 [ foo | | bar ] stands for [ foo | idtac | bar ].
7169 - Fixed a "fold" bug (non critical but possible source of incompatibilities).
7270 - Added classical_left and classical_right which transforms |- A \/ B into
7371 ~B |- A and ~A |- B respectively.
7472 - Added command "Declare Implicit Tactic" to set up a default tactic to be
75 used to solve unresolved subterms of term arguments of tactics (doc TODO).
73 used to solve unresolved subterms of term arguments of tactics.
7674 - Better support for coercions to Sortclass in tactics expecting type
7775 arguments.
78 - Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses
79 (doc TODO).
80 - Tactic "replace" now accepts a "by" tactic clause (doc TODO).
81 - New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns
82 (doc TODO).
83 - New introduction pattern "?" for letting Coq choose a name (doc TODO).
84 - Added "eassumption" (doc TODO).
85 - Added option 'using lemmas' to auto, trivial and eauto (doc TODO).
76 - Tactic "assert" now accepts "as" intro patterns and "by" tactic clauses.
77 - New tactic "pose proof" that generalizes "assert (id:=p)" with intro patterns.
78 - New introduction pattern "?" for letting Coq choose a name.
79 - Added "eassumption".
80 - Added option 'using lemmas' to auto, trivial and eauto.
81 - Tactic "congruence" is now complete for its intended scope (ground
82 equalities and inequalities with constructors). Furthermore, it
83 tries to equates goal and hypotheses.
84 - New tactic "rtauto" solves pure propositional logic and gives a
85 reflective version of the available proof.
8686 - Numbering of "pattern", "unfold", "simpl", ... occurrences in "match
8787 with" made consistent with the printing of the return clause after
8888 the term to match in the "match-with" construct (use "Set Printing All"
8989 to see hidden occurrences).
9090 - Generalization of induction "induction x1...xn using scheme" where
9191 scheme is an induction principle with complex predicates (like the
92 ones generated by function induction) (doc TODO).
92 ones generated by function induction).
9393 - Some small Ltac tactics has been added to the standard library
9494 (file Tactics.v):
9595 * f_equal : instead of using the different f_equalX lemmas
110110
111111 Modules
112112
113 - Added "Locate Module qualid" to get the full path of a module (TODO doc).
114 - Module/Declare Module syntax made more uniform (doc TODO).
113 - Added "Locate Module qualid" to get the full path of a module.
114 - Module/Declare Module syntax made more uniform.
115115 - Added syntactic sugar "Declare Module Export/Import" and
116 "Module Export/Import" (doc TODO).
116 "Module Export/Import".
117117 - Added syntactic sugar "Module M(Export/Import X Y: T)" and
118118 "Module Type M(Export/Import X Y: T)"
119 (only for interactive definitions) (doc TODO)
119 (only for interactive definitions)
120120 - Construct "with" generalized to module paths:
121121 T with (Definition|Module) M1.M2....Mn.l := l' (doc TODO).
122122
126126 - Added insertion of spaces by default in recursive notations w/o separators.
127127 - No more automatic printing box in case of user-provided printing "format".
128128 - New notation "exists! x:A, P" for unique existence.
129 - Notations for specific numerals now compatible with generic notations of
130 numerals (e.g. "1" can be used to denote the unit of a group without
131 hiding 1%nat)
129132
130133 Libraries
131134
133136 - New library FSets+FMaps of finite sets and maps.
134137 - New library QArith on rational numbers.
135138 - Small extension of Zmin.V, new Zmax.v, new Zminmax.v.
136 - Reworking of the files on classical logic and description principles
137 (possible incompatibilities).
139 - Reworking and extension of the files on classical logic and
140 description principles (possible incompatibilities)
138141 - Few other improvements in ZArith potentially exceptionally breaking the
139142 compatibility (useless hypothesys of Zgt_square_simpl and
140143 Zlt_square_simpl removed; fixed names mentioning letter O instead of
143146 - Znumtheory now contains a gcd function that can compute within Coq.
144147 - More lemmas stated on Type in Wf.v, removal of redundant Fix_F.
145148 - Change of the internal names of lemmas in OmegaLemmas.
149 - Acc in Wf.v and clos_refl_trans in Relation_Operators.v now rely on
150 the allowance for recursively non uniform parameters (possible
151 source of incompatibilities: explicit pattern-matching on these
152 types may require to remove the occurrence associated to their
153 recursively non uniform parameter).
146154 - Coq.List.In_dec has been set transparent (this may exceptionally break
147155 proof scripts, set it locally opaque for compatibility).
148156 - More on permutations of lists in List.v and Permutation.v.
168176 "make clean"
169177 - New environment variable COQREMOTEBROWSER to set the command invoked
170178 to start the remote browser both in Coq and coqide. Standard syntax:
171 "%s" is the placeholder for the URL (doc TODO)
179 "%s" is the placeholder for the URL.
172180
173181
174182 Changes from V8.0beta to V8.0
+32
-0
COMPATIBILITY less more
0 Potential sources of incompatibilities between Coq V8.0 and V8.1
1 ----------------------------------------------------------------
2
3 (see also file CHANGES)
4
5 - Inductive types in Type are now polymorphic over their parameters in
6 Type. This may affect the naming of introduction hypotheses if such
7 an inductive type in Type is used on small types such as Prop or
8 Set: the hypothesis names suffix will default to H instead of X. As
9 a matter of fact, it is recommended to systematically name the
10 hypotheses that are later refered to in the proof script.
11
12 - Some bug fixes may lead to incompatibilities. This is e.g. the case
13 of inversion on Type which failed to rewrite some hypotheses as it
14 did on Prop/Set.
15
16 - Add Morphism for the Prop/iff setoid now requires a proof of
17 biimplication instead of a proof of implication.
18
19 - The order of arguments in compatibility morphisms changed: the
20 premises and the parameters are now interleaved while the whole
21 bunch of parameters used to come first.
22
23 - A few changes in the library (as mentioned in the CHANGES file) may
24 imply the need for local adaptations.
25
26 - Occurrence numbering order for unfold, pattern, etc changed for the
27 match construction: occurrences in the return clause now come after
28 the occurrences in the term matched; this was the opposite before.
29
30 - For changes in the ML interfaces, see file dev/doc/changes.txt in
31 the main archive.
+2
-2
Makefile less more
55 # # GNU Lesser General Public License Version 2.1 #
66 #######################################################################
77
8 # $Id: Makefile 8933 2006-06-09 14:08:38Z herbelin $
8 # $Id: Makefile 8989 2006-06-25 22:17:49Z letouzey $
99
1010
1111 # Makefile for Coq
873873 QARITHVO=\
874874 theories/QArith/QArith_base.vo theories/QArith/Qreduction.vo \
875875 theories/QArith/Qring.vo theories/QArith/Qreals.vo \
876 theories/QArith/QArith.vo
876 theories/QArith/QArith.vo theories/QArith/Qcanon.vo
877877
878878 LISTSVO=\
879879 theories/Lists/MonoList.vo \
+216
-179
configure less more
2929 best_compiler=opt
3030
3131 local=false
32 src_spec=no
33 prefix_spec=no
3234 bindir_spec=no
3335 libdir_spec=no
3436 mandir_spec=no
4345 coqide_spec=no
4446 with_geoproof=true
4547
46 COQTOP=`pwd`
48 # COQTOP=`pwd`
4749
4850
4951 # Parse command-line arguments
5153 while : ; do
5254 case "$1" in
5355 "") break;;
54 -prefix|--prefix) bindir_spec=yes
55 bindir=$2/bin
56 libdir_spec=yes
57 libdir=$2/lib/coq
58 mandir_spec=yes
59 mandir=$2/man
60 coqdocdir_spec=yes
61 coqdocdir=$2/share/texmf/tex/latex/misc
56 -prefix|--prefix) prefix_spec=yes
57 prefix="$2"
6258 shift;;
6359 -local|--local) local=true
64 bindir_spec=yes
65 bindir=$COQTOP/bin
66 libdir_spec=yes
67 libdir=$COQTOP
68 mandir_spec=yes
69 mandir=$COQTOP/man
70 emacslib_spec=yes
71 emacslib=$COQTOP/tools/emacs
72 coqdocdir_spec=yes
73 coqdocdir=$COQTOP/tools/coqdoc
74 fsets_opt=yes
75 fsets=all
7660 reals_opt=yes
7761 reals=all;;
78 -src|--src) COQTOP=$2
62 -src|--src) src_spec=yes
63 COQTOP="$2"
7964 shift;;
8065 -bindir|--bindir) bindir_spec=yes
81 bindir=$2
66 bindir="$2"
8267 shift;;
8368 -libdir|--libdir) libdir_spec=yes
84 libdir=$2
69 libdir="$2"
8570 shift;;
8671 -mandir|--mandir) mandir_spec=yes
87 mandir=$2
72 mandir="$2"
8873 shift;;
8974 -emacslib|--emacslib) emacslib_spec=yes
90 emacslib=$2
75 emacslib="$2"
9176 shift;;
9277 -emacs |--emacs) emacs_spec=yes
93 emacs=$2
78 emacs="$2"
9479 shift;;
9580 -coqdocdir|--coqdocdir) coqdocdir_spec=yes
96 coqdocdir=$2
81 coqdocdir="$2"
9782 shift;;
9883 -arch|--arch) arch_spec=yes
9984 arch=$2
124109 shift
125110 done
126111
112 if [ $prefix_spec = yes -a $local = true ] ; then
113 echo "Options -prefix and -local are incompatible"
114 echo "Configure script failed!"
115 exit 1
116 fi
127117
128118 # compile date
129119 DATEPGM=`which date`
159149 yes) ARCH=$arch
160150 esac
161151
162 # bindir, libdir, mandir, etc.
163
164 case $ARCH in
165 win32)
166 bindir_def=C:\\coq\\bin
167 libdir_def=C:\\coq\\lib
168 mandir_def=C:\\coq\\man
169 emacslib_def=C:\\coq\\emacs;;
170 *)
171 bindir_def=/usr/local/bin
172 libdir_def=/usr/local/lib/coq
173 mandir_def=/usr/local/man
174 emacslib_def=/usr/share/emacs/site-lisp
175 coqdocdir_def=/usr/share/texmf/tex/latex/misc;;
176 esac
177
178 emacs_def=emacs
179
180 case $bindir_spec in
181 no) echo "Where should I install the Coq binaries [$bindir_def] ?"
182 read BINDIR
183
184 case $BINDIR in
185 "") BINDIR=$bindir_def;;
186 *) true;;
187 esac;;
188 yes) BINDIR=$bindir;;
189 esac
190
191 case $libdir_spec in
192 no) echo "Where should I install the Coq library [$libdir_def] ?"
193 read LIBDIR
194
195 case $LIBDIR in
196 "") LIBDIR=$libdir_def;;
197 *) true;;
198 esac;;
199 yes) LIBDIR=$libdir;;
200 esac
201
202 case $mandir_spec in
203 no) echo "Where should I install the Coq man pages [$mandir_def] ?"
204 read MANDIR
205
206 case $MANDIR in
207 "") MANDIR=$mandir_def;;
208 *) true;;
209 esac;;
210 yes) MANDIR=$mandir;;
211 esac
212
213 case $emacslib_spec in
214 no) echo "Where should I install the Coq Emacs mode [$emacslib_def] ?"
215 read EMACSLIB
216
217 case $EMACSLIB in
218 "") EMACSLIB=$emacslib_def;;
219 *) true;;
220 esac;;
221 yes) EMACSLIB=$emacslib;;
222 esac
223
224 case $coqdocdir_spec in
225 no) echo "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def] ?"
226 read COQDOCDIR
227
228 case $COQDOCDIR in
229 "") COQDOCDIR=$coqdocdir_def;;
230 *) true;;
231 esac;;
232 yes) COQDOCDIR=$coqdocdir;;
233 esac
234
235 case $fsets_opt in
236 no) echo "Should I compile the complete theory of finite sets [Y/N, default is Y] ?"
237 read fsets_ans
238
239 case $fsets_ans in
240 "N"|"n"|"No"|"NO"|"no")
241 fsets=basic;;
242 *) fsets=all;;
243 esac;;
244 yes) true;;
245 esac
246
247 case $reals_opt in
248 no) echo "Should I compile the complete theory of real analysis [Y/N, default is Y] ?"
249 read reals_ans
250
251 case $reals_ans in
252 "N"|"n"|"No"|"NO"|"no")
253 reals=basic;;
254 *) reals=all;;
255 esac;;
256 yes) true;;
257 esac
258
259 # case $emacs_spec in
260 # no) echo "Which Emacs command should I use to compile coq.el [$emacs_def] ?"
261 # read EMACS
262
263 # case $EMACS in
264 # "") EMACS=$emacs_def;;
265 # *) true;;
266 # esac;;
267 # yes) EMACS=$emacs;;
268 # esac
269
270 # OS dependent libraries
271
272 case $ARCH in
273 sun4*) OS=`uname -r`
274 case $OS in
275 5*) OS="Sun Solaris $OS"
276 OSDEPLIBS="-cclib -lunix -cclib -lnsl -cclib -lsocket";;
277 *) OS="Sun OS $OS"
278 OSDEPLIBS="-cclib -lunix"
279 esac;;
280 alpha) OSDEPLIBS="-cclib -lunix";;
281 win32) OS="Win32"
282 OSDEPLIBS="-cclib -lunix";;
283 *) OSDEPLIBS="-cclib -lunix"
284 esac
285
286152 # executable extension
287153
288154 case $ARCH in
290156 *) EXE=""
291157 esac
292158
159 # strip command
160
161 case $ARCH in
162 win32)
163 # true -> strip : it exists under cygwin !
164 STRIPCOMMAND="strip";;
165 *)
166 if [ "$coq_profile_flag" = "-p" ] ; then
167 STRIPCOMMAND="true"
168 else
169 STRIPCOMMAND="strip"
170 fi
171 esac
172
173 #########################################
293174 # Objective Caml programs
294175
295176 CAMLC=`which $bytecamlc`
370251 # *)
371252 # CAMLP4LIB=${CAMLLIB}/camlp4
372253 #esac
254
255 # OS dependent libraries
256
257 case $ARCH in
258 sun4*) OS=`uname -r`
259 case $OS in
260 5*) OS="Sun Solaris $OS"
261 OSDEPLIBS="-cclib -lunix -cclib -lnsl -cclib -lsocket";;
262 *) OS="Sun OS $OS"
263 OSDEPLIBS="-cclib -lunix"
264 esac;;
265 alpha) OSDEPLIBS="-cclib -lunix";;
266 win32) OS="Win32"
267 OSDEPLIBS="-cclib -lunix";;
268 *) OSDEPLIBS="-cclib -lunix"
269 esac
373270
374271 # lablgtk2 and CoqIDE
375272
422319 # "") MKTEXLSR=true;;
423320 #esac
424321
322 ###########################################
323 # bindir, libdir, mandir, etc.
324
325 canonical_pwd () {
326 ocaml 2>&1 1>/dev/null <<EOF
327 prerr_endline(Sys.getcwd());;
328 EOF
329 }
330
331 case $src_spec in
332 no) COQTOP=`canonical_pwd`
333 esac
334
335 case $ARCH in
336 win32)
337 bindir_def='C:\coq\bin'
338 libdir_def='C:\coq\lib'
339 mandir_def='C:\coq\man'
340 emacslib_def='C:\coq\emacs'
341 coqdocdir_def='C:\coq\latex';;
342 *)
343 bindir_def=/usr/local/bin
344 libdir_def=/usr/local/lib/coq
345 mandir_def=/usr/local/man
346 emacslib_def=/usr/share/emacs/site-lisp
347 coqdocdir_def=/usr/share/texmf/tex/latex/misc;;
348 esac
349
350 emacs_def=emacs
351
352 case $bindir_spec/$prefix_spec/$local in
353 yes/*/*) BINDIR=$bindir ;;
354 */yes/*) BINDIR=$prefix/bin ;;
355 */*/true) BINDIR=$COQTOP/bin ;;
356 *) echo "Where should I install the Coq binaries [$bindir_def] ?"
357 read BINDIR
358 case $BINDIR in
359 "") BINDIR=$bindir_def;;
360 *) true;;
361 esac;;
362 esac
363
364 case $libdir_spec/$prefix_spec/$local in
365 yes/*/*) LIBDIR=$libdir;;
366 */yes/*)
367 case $ARCH in
368 win32) LIBDIR=$prefix ;;
369 *) LIBDIR=$prefix/lib/coq ;;
370 esac ;;
371 */*/true) LIBDIR=$COQTOP ;;
372 *) echo "Where should I install the Coq library [$libdir_def] ?"
373 read LIBDIR
374 case $LIBDIR in
375 "") LIBDIR=$libdir_def;;
376 *) true;;
377 esac;;
378 esac
379
380 case $mandir_spec/$prefix_spec/$local in
381 yes/*/*) MANDIR=$mandir;;
382 */yes/*) MANDIR=$prefix/man ;;
383 */*/true) MANDIR=$COQTOP/man ;;
384 *) echo "Where should I install the Coq man pages [$mandir_def] ?"
385 read MANDIR
386 case $MANDIR in
387 "") MANDIR=$mandir_def;;
388 *) true;;
389 esac;;
390 esac
391
392 case $emacslib_spec/$prefix_spec/$local in
393 yes/*/*) EMACSLIB=$emacslib;;
394 */yes/*)
395 case $ARCH in
396 win32) EMACSLIB=$prefix/emacs ;;
397 *) EMACSLIB=$prefix/share/emacs/site-lisp ;;
398 esac ;;
399 */*/true) EMACSLIB=$COQTOP/tools/emacs ;;
400 *) echo "Where should I install the Coq Emacs mode [$emacslib_def] ?"
401 read EMACSLIB
402 case $EMACSLIB in
403 "") EMACSLIB=$emacslib_def;;
404 *) true;;
405 esac;;
406 esac
407
408 case $coqdocdir_spec/$prefix_spec/$local in
409 yes/*/*) COQDOCDIR=$coqdocdir;;
410 */yes/*)
411 case $ARCH in
412 win32) COQDOCDIR=$prefix/latex ;;
413 *) COQDOCDIR=$prefix/share/emacs/site-lisp ;;
414 esac ;;
415 */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;;
416 *) echo "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def] ?"
417 read COQDOCDIR
418 case $COQDOCDIR in
419 "") COQDOCDIR=$coqdocdir_def;;
420 *) true;;
421 esac;;
422 esac
423
424 case $reals_opt in
425 no) echo "Should I compile the complete theory of real analysis [Y/N, default is Y] ?"
426 read reals_ans
427
428 case $reals_ans in
429 "N"|"n"|"No"|"NO"|"no")
430 reals=basic;;
431 *) reals=all;;
432 esac;;
433 yes) true;;
434 esac
435
436 # case $emacs_spec in
437 # no) echo "Which Emacs command should I use to compile coq.el [$emacs_def] ?"
438 # read EMACS
439
440 # case $EMACS in
441 # "") EMACS=$emacs_def;;
442 # *) true;;
443 # esac;;
444 # yes) EMACS=$emacs;;
445 # esac
446
447 ###########################################
425448 # Summary of the configuration
426449
427450 echo ""
459482 # Building the $COQTOP/config/coq_config.ml file
460483 #####################################################
461484
462 # damned backslashes under M$Windows
463 case $ARCH in
464 win32)
465 CAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'`
466 BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
467 LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
468 MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
469 EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
470 ;;
471 esac
485 # An escaped version of a variable
486 escape_var () {
487 ocaml 2>&1 1>/dev/null <<EOF
488 prerr_endline(String.escaped(Sys.getenv"$VAR"));;
489 EOF
490 }
491
492 export COQTOP BINDIR LIBDIR CAMLLIB
493 ESCCOQTOP="`VAR=COQTOP escape_var`"
494 ESCBINDIR="`VAR=BINDIR escape_var`"
495 ESCLIBDIR="`VAR=LIBDIR escape_var`"
496 ESCCAMLLIB="`VAR=CAMLLIB escape_var`"
497 ESCCAMLP4LIB="$ESCCAMLLIB"/camlp4
472498
473499 mlconfig_file=$COQTOP/config/coq_config.ml
474500 rm -f $mlconfig_file
476502 (* DO NOT EDIT THIS FILE: automatically generated by ../configure *)
477503
478504 let local = $local
479 let bindir = "$BINDIR"
480 let coqlib = "$LIBDIR"
481 let coqtop = "$COQTOP"
482 let camllib = "$CAMLLIB"
483 let camlp4lib = "$CAMLP4LIB"
505 let bindir = "$ESCBINDIR"
506 let coqlib = "$ESCLIBDIR"
507 let coqtop = "$ESCCOQTOP"
508 let camllib = "$ESCCAMLLIB"
509 let camlp4lib = "$ESCCAMLP4LIB"
484510 let best = "$best_compiler"
485511 let arch = "$ARCH"
486512 let osdeplibs = "$OSDEPLIBS"
521547 # damned backslashes under M$Windows (bis)
522548 case $ARCH in
523549 win32)
524 BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
525 LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
526 MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
527 EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
550 ESCCOQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'`
551 ESCBINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
552 ESCLIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
553 ESCMANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
554 ESCEMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
555 ESCCOQDOCDIR=`echo $COQDOCDIR |sed -e 's|\\\|\\\\\\\|g'`
556 ESCCAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'`
528557 ;;
558 *)
559 ESCCOQTOP="$COQTOP"
560 ESCBINDIR="$BINDIR"
561 ESCLIBDIR="$LIBDIR"
562 ESCMANDIR="$MANDIR"
563 ESCEMACSLIB="$EMACSLIB"
564 ESCCOQDOCDIR="$COQDOCDIR"
565 ESCCAMLP4BIN="$CAMLP4BIN" ;;
529566 esac
530567
531568 sed -e "s|LOCALINSTALLATION|$local|" \
532 -e "s|COQTOPDIRECTORY|$COQTOP|" \
569 -e "s|COQTOPDIRECTORY|$ESCCOQTOP|" \
533570 -e "s|COQVERSION|$VERSION|" \
534 -e "s|BINDIRDIRECTORY|$BINDIR|" \
535 -e "s|COQLIBDIRECTORY|$LIBDIR|" \
536 -e "s|MANDIRDIRECTORY|$MANDIR|" \
537 -e "s|EMACSLIBDIRECTORY|$EMACSLIB|" \
571 -e "s|BINDIRDIRECTORY|$ESCBINDIR|" \
572 -e "s|COQLIBDIRECTORY|$ESCLIBDIR|" \
573 -e "s|MANDIRDIRECTORY|$ESCMANDIR|" \
574 -e "s|EMACSLIBDIRECTORY|$ESCEMACSLIB|" \
538575 -e "s|EMACSCOMMAND|$EMACS|" \
539 -e "s|COQDOCDIRECTORY|$COQDOCDIR|" \
576 -e "s|COQDOCDIRECTORY|$ESCCOQDOCDIR|" \
540577 -e "s|MKTEXLSRCOMMAND|$MKTEXLSR|" \
541578 -e "s|ARCHITECTURE|$ARCH|" \
542579 -e "s|OSDEPENDENTLIBS|$OSDEPLIBS|" \
543580 -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
544581 -e "s|CAMLLIBDIRECTORY|$CAMLLIB|" \
545582 -e "s|CAMLTAG|$CAMLTAG|" \
546 -e "s|CAMLP4BINDIRECTORY|$CAMLP4BIN|" \
583 -e "s|CAMLP4BINDIRECTORY|$ESCCAMLP4BIN|" \
547584 -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
548585 -e "s|CAMLP4TOOL|$camlp4o|" \
549586 -e "s|CAMLP4COMPATFLAGS|$CAMLP4COMPAT|" \
601638 echo "*Warning* To compile the system for a new architecture"
602639 echo " don't forget to do a 'make archclean' before './configure'."
603640
604 # $Id: configure 8932 2006-06-09 09:29:03Z notin $
641 # $Id: configure 8961 2006-06-15 15:22:05Z notin $
+2
-2
contrib/extraction/extraction.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: extraction.ml 8931 2006-06-09 07:43:37Z letouzey $ i*)
8 (*i $Id: extraction.ml 9032 2006-07-07 16:30:34Z herbelin $ i*)
99
1010 (*i*)
1111 open Util
405405 List.iter
406406 (option_iter
407407 (fun kn -> if Cset.mem kn !projs then add_projection n kn))
408 (lookup_structure ip).s_PROJ
408 (lookup_projections ip)
409409 with Not_found -> ()
410410 end;
411411 Record field_glob
+126
-64
contrib/funind/functional_principles_proofs.ml less more
1515 open Libnames
1616
1717 let msgnl = Pp.msgnl
18
19 let do_observe () =
20 Tacinterp.get_debug () <> Tactic_debug.DebugOff
21
18
2219
2320 let observe strm =
2421 if do_observe ()
172169 then isConstruct (fst (destApp t))
173170 else false
174171
175
176 let nf_betaiotazeta = Reductionops.local_strong Reductionops.whd_betaiotazeta
177
172 let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *)
173 let clos_norm_flags flgs env sigma t =
174 Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
175 clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty
176
178177
179178 let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type =
180179 let nochange msg =
230229 end_of_type_with_pop
231230 sub''
232231 in
233 (* let new_end_of_type = *)
234 (* Intmap.fold *)
235 (* (fun i t end_of_type -> lift 1 (substnl [t] (i-1) end_of_type)) *)
236 (* sub *)
237 (* end_of_type_with_pop *)
238 (* in *)
239232 let old_context_length = List.length context + 1 in
240233 let witness_fun =
241234 mkLetIn(Anonymous,make_refl_eq t1_typ t1,t,
555548 g
556549
557550
551 let my_orelse tac1 tac2 g =
552 try
553 tac1 g
554 with e ->
555 (* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
556 tac2 g
557
558558 let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
559559 let args = Array.of_list (List.map mkVar args_id) in
560560 let instanciate_one_hyp hid =
561 tclORELSE
561 my_orelse
562562 ( (* we instanciate the hyp if possible *)
563563 fun g ->
564564 let prov_hid = pf_get_new_id hid g in
747747 (build_proof_aux do_finalize dyn_infos) g
748748 and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic =
749749 fun g ->
750 (* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *)
751 (* then msgnl (str "build_proof_args with " ++ *)
752 (* pr_lconstr_env (pf_env g) f_args' *)
753 (* ); *)
754750 let (f_args',args) = dyn_infos.info in
755751 let tac : tactic =
756752 fun g ->
811807 types : types;
812808 offset : int;
813809 nb_realargs : int;
814 body_with_param : constr
810 body_with_param : constr;
811 num_in_block : int
815812 }
816813
817814
837834 exception Not_Rec
838835
839836 let generalize_non_dep hyp g =
837 (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
840838 let hyps = [hyp] in
841839 let env = Global.env () in
842840 let hyp_typ = pf_type_of g (mkVar hyp) in
843841 let to_revert,_ =
844 Environ. fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
842 Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
845843 if List.mem hyp hyps
846844 or List.exists (occur_var_in_decl env hyp) keep
847845 or occur_var env hyp hyp_typ
852850 in
853851 (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
854852 tclTHEN
855 (observe_tac "h_generalize" (h_generalize (List.map mkVar to_revert)))
853 (observe_tac "h_generalize" (h_generalize (List.map mkVar to_revert) ))
856854 (observe_tac "thin" (thin to_revert))
857855 g
858856
863861 (generalize (List.map mkVar idl))
864862 (thin idl)
865863
866
867 let do_replace params rec_arg_num rev_args_id fun_to_replace body =
868 fun g ->
869 let nb_intro_to_do = nb_prod (pf_concl g) in
864 let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
865 (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
866 (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
867 (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
868 let f_def = Global.lookup_constant (destConst f) in
869 let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
870 let f_body =
871 force (out_some f_def.const_body)
872 in
873 let params,f_body_with_params = decompose_lam_n nb_params f_body in
874 let (_,num),(_,_,bodies) = destFix f_body_with_params in
875 let fnames_with_params =
876 let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in
877 let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in
878 fnames
879 in
880 (* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *)
881 (* observe (str "body " ++ pr_lconstr bodies.(num)); *)
882 let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in
883 (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *)
884 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
885 (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *)
886 let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) f_def.const_type in
887 let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
888 let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
889 let f_id = id_of_label (con_label (destConst f)) in
890 let prove_replacement =
891 tclTHENSEQ
892 [
893 tclDO (nb_params + rec_args_num + 1) intro;
894 observe_tac "" (fun g ->
895 let rec_id = pf_nth_hyp_id g 1 in
896 tclTHENSEQ
897 [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id);
898 observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings));
899 intros_reflexivity] g
900 )
901 ]
902 in
903 Command.start_proof
904 (*i The next call to mk_equation_id is valid since we are constructing the lemma
905 Ensures by: obvious
906 i*)
907 (mk_equation_id f_id)
908 (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
909 lemma_type
910 (fun _ _ -> ());
911 Pfedit.by (prove_replacement);
912 Command.save_named false
913
914
915
916
917 let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
918 let equation_lemma =
919 try
920 let finfos = find_Function_infos (destConst f) in
921 mkConst (out_some finfos.equation_lemma)
922 with (Not_found | Failure "out_some" as e) ->
923 let f_id = id_of_label (con_label (destConst f)) in
924 (*i The next call to mk_equation_id is valid since we will construct the lemma
925 Ensures by: obvious
926 i*)
927 let equation_lemma_id = (mk_equation_id f_id) in
928 generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
929 let _ =
930 match e with
931 | Failure "out_some" ->
932 let finfos = find_Function_infos (destConst f) in
933 update_Function
934 {finfos with
935 equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with
936 ConstRef c -> c
937 | _ -> Util.anomaly "Not a constant"
938 )
939 }
940 | _ -> ()
941
942 in
943 Tacinterp.constr_of_id (pf_env g) equation_lemma_id
944 in
945 let nb_intro_to_do = nb_prod (pf_concl g) in
870946 tclTHEN
871947 (tclDO nb_intro_to_do intro)
872948 (
873949 fun g' ->
874950 let just_introduced = nLastHyps nb_intro_to_do g' in
875951 let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
876 let old_rev_args_id = rev_args_id in
877 let rev_args_id = just_introduced_id@rev_args_id in
878 let to_replace =
879 Reductionops.nf_betaiota (substl (List.map mkVar rev_args_id) fun_to_replace )
880 and by =
881 Reductionops.nf_betaiota (applist(body,List.rev_map mkVar rev_args_id))
882 in
883 (* observe (str "to_replace := " ++ pr_lconstr_env (pf_env g') to_replace); *)
884 (* observe (str "by := " ++ pr_lconstr_env (pf_env g') by); *)
885 let prove_replacement =
886 let rec_id = List.nth (List.rev old_rev_args_id) (rec_arg_num) in
887 observe_tac "prove_replacement"
888 (tclTHENSEQ
889 [
890 revert just_introduced_id;
891 keep ((List.map id_of_decl params)@ old_rev_args_id);
892 generalize_non_dep rec_id;
893 observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings));
894 intros_reflexivity
895 ]
896 )
897 in
898 tclTHENS
899 (observe_tac "replacement" (Equality.replace to_replace by))
900 [ revert just_introduced_id;
901 tclSOLVE [prove_replacement]]
902 g'
952 tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
903953 )
904954 g
905
906
907955
908956 let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
909957 fun g ->
10101058 nb_realargs =
10111059 List.length
10121060 (fst (decompose_lam bodies.(i))) - fix_offset;
1013 body_with_param = bodies_with_all_params.(i)
1061 body_with_param = bodies_with_all_params.(i);
1062 num_in_block = i
10141063 }
10151064 )
10161065 typess
10261075 let app_f = mkApp(f,first_args) in
10271076 let pte_args = (Array.to_list first_args)@[app_f] in
10281077 let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
1029 let body_with_param =
1078 let body_with_param,num =
10301079 let body = get_body fnames.(i) in
10311080 let body_with_full_params =
10321081 Reductionops.nf_betaiota (
10421091 (Array.to_list all_funs_with_full_params))
10431092 bs.(num),
10441093 List.rev_map var_of_decl princ_params))
1045 )
1094 ),num
10461095 | _ -> error "Not a mutual block"
10471096 in
10481097 let info =
10491098 {infos with
10501099 types = compose_prod type_args app_pte;
1051 body_with_param = body_with_param
1100 body_with_param = body_with_param;
1101 num_in_block = num
10521102 }
10531103 in
10541104 (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *)
11171167 tclTHENSEQ
11181168 [
11191169 observe_tac "do_replace"
1120 (do_replace princ_info.params fix_info.idx args_id
1121 (List.hd (List.rev pte_args)) fix_body);
1170 (do_replace
1171 full_params
1172 (fix_info.idx + List.length princ_params)
1173 (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
1174 (all_funs.(fix_info.num_in_block))
1175 fix_info.num_in_block
1176 all_funs
1177 );
1178 (* observe_tac "do_replace" *)
1179 (* (do_replace princ_info.params fix_info.idx args_id *)
1180 (* (List.hd (List.rev pte_args)) fix_body); *)
11221181 let do_prove =
11231182 build_proof
11241183 interactive_proof
11321191 nb_rec_hyps = List.length branches
11331192 }
11341193 in
1135 clean_goal_with_heq
1194 observe_tac "cleaning" (clean_goal_with_heq
11361195 (Idmap.map prove_rec_hyp ptes_to_fix)
11371196 do_prove
1138 dyn_infos
1197 dyn_infos)
11391198 in
1140 (* observe (str "branches := " ++ *)
1141 (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches); *)
1199 (* observe (str "branches := " ++ *)
1200 (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *)
1201 (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *)
1202
1203 (* ); *)
11421204 observe_tac "instancing" (instanciate_hyps_with_args prove_tac
11431205 (List.rev_map id_of_decl princ_info.branches)
11441206 (List.rev args_id))
+1
-2
contrib/funind/functional_principles_proofs.mli less more
1515 Tacmach.tactic
1616
1717
18 val is_pte : rel_declaration -> bool
19 val do_observe : unit -> bool
18 (* val is_pte : rel_declaration -> bool *)
+330
-213
contrib/funind/functional_principles_types.ml less more
1818 exception Toberemoved
1919
2020
21
22
21 let pr_elim_scheme el =
22 let env = Global.env () in
23 let msg = str "params := " ++ Printer.pr_rel_context env el.params in
24 let env = Environ.push_rel_context el.params env in
25 let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
26 let env = Environ.push_rel_context el.predicates env in
27 let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
28 let env = Environ.push_rel_context el.branches env in
29 let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
30 let env = Environ.push_rel_context el.args env in
31 msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
32
33
34 let observe s =
35 if do_observe ()
36 then Pp.msgnl s
37
38
39 let pr_elim_scheme el =
40 let env = Global.env () in
41 let msg = str "params := " ++ Printer.pr_rel_context env el.params in
42 let env = Environ.push_rel_context el.params env in
43 let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
44 let env = Environ.push_rel_context el.predicates env in
45 let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
46 let env = Environ.push_rel_context el.branches env in
47 let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
48 let env = Environ.push_rel_context el.args env in
49 msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
50
51
52 let observe s =
53 if do_observe ()
54 then Pp.msgnl s
2355
2456 (*
2557 Transform an inductive induction principle into
2860 let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
2961 let princ_type_info = compute_elim_sig princ_type in
3062 let env = Global.env () in
63 let env_with_params = Environ.push_rel_context princ_type_info.params env in
64 let tbl = Hashtbl.create 792 in
65 let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context) : Sign.rel_context =
66 match predicates with
67 | [] -> []
68 |(Name x,v,t)::predicates ->
69 let id = Nameops.next_ident_away x avoid in
70 Hashtbl.add tbl id x;
71 (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
72 | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
73 in
74 let avoid = (Termops.ids_of_context env_with_params ) in
75 let princ_type_info =
76 { princ_type_info with
77 predicates = change_predicates_names avoid princ_type_info.predicates
78 }
79 in
80 (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
81 (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
3182 let change_predicate_sort i (x,_,t) =
3283 let new_sort = sorts.(i) in
3384 let args,_ = decompose_prod t in
3687 then List.tl args
3788 else args
3889 in
39 x,None,compose_prod real_args (mkSort new_sort)
90 Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
4091 in
4192 let new_predicates =
4293 list_map_i
4495 0
4596 princ_type_info.predicates
4697 in
47 let env_with_params_and_predicates =
48 Environ.push_rel_context
49 new_predicates
50 (Environ.push_rel_context
51 princ_type_info.params
52 env
53 )
54 in
98 let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
5599 let rel_as_kn =
56100 fst (match princ_type_info.indref with
57101 | Some (Libnames.IndRef ind) -> ind
58 | _ -> failwith "Not a valid predicate"
102 | _ -> error "Not a valid predicate"
59103 )
104 in
105 let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
106 let is_pte =
107 let set = List.fold_right Idset.add ptes_vars Idset.empty in
108 fun t ->
109 match kind_of_term t with
110 | Var id -> Idset.mem id set
111 | _ -> false
60112 in
61113 let pre_princ =
62114 it_mkProd_or_LetIn
71123 )
72124 princ_type_info.branches
73125 in
126 let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
74127 let is_dom c =
75128 match kind_of_term c with
76129 | Ind((u,_)) -> u = rel_as_kn
107160 | Prod(x,t,b) ->
108161 compute_new_princ_type_for_binder remove mkProd env x t b
109162 | Lambda(x,t,b) ->
110 compute_new_princ_type_for_binder remove mkLambda env x t b
163 compute_new_princ_type_for_binder remove mkLambda env x t b
111164 | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
112165 | App(f,args) when is_dom f ->
113166 let var_to_be_removed = destRel (array_last args) in
114167 let num = get_fun_num f in
115168 raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
116169 | App(f,args) ->
117 let is_pte =
118 match kind_of_term f with
119 | Rel n ->
120 is_pte (Environ.lookup_rel n env)
121 | _ -> false
122 in
123170 let args =
124 if is_pte && remove
171 if is_pte f && remove
125172 then array_get_start args
126173 else args
127174 in
137184 compute_new_princ_type_for_letin remove env x v t b
138185 | _ -> pre_princ,[]
139186 in
140 (* observennl ( *)
141 (* match kind_of_term pre_princ with *)
142 (* | Prod _ -> *)
143 (* str "compute_new_princ_type for "++ *)
187 (* let _ = match kind_of_term pre_princ with *)
188 (* | Prod _ -> *)
189 (* observe(str "compute_new_princ_type for "++ *)
144190 (* pr_lconstr_env env pre_princ ++ *)
145191 (* str" is "++ *)
146 (* pr_lconstr_env env new_princ_type ++ fnl () *)
147 (* | _ -> str "" *)
148 (* ); *)
192 (* pr_lconstr_env env new_princ_type ++ fnl ()) *)
193 (* | _ -> () in *)
149194 res
150195
151196 and compute_new_princ_type_for_binder remove bind_fun env x t b =
155200 let new_x : name = get_name (ids_of_context env) x in
156201 let new_env = Environ.push_rel (x,None,t) env in
157202 let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
158 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
159 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
160 else
161 (
162 bind_fun(new_x,new_t,new_b),
163 list_union_eq
164 eq_constr
165 binders_to_remove_from_t
166 (List.map pop binders_to_remove_from_b)
167 )
168
169 with
170 | Toberemoved ->
171 (* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
172 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in
203 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
204 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
205 else
206 (
207 bind_fun(new_x,new_t,new_b),
208 list_union_eq
209 eq_constr
210 binders_to_remove_from_t
211 (List.map pop binders_to_remove_from_b)
212 )
213
214 with
215 | Toberemoved ->
216 (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
217 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in
173218 new_b, List.map pop binders_to_remove_from_b
174219 | Toberemoved_with_rel (n,c) ->
175 (* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
176 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in
220 (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
221 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in
177222 new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
178223 end
179224 and compute_new_princ_type_for_letin remove env x v t b =
183228 let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
184229 let new_x : name = get_name (ids_of_context env) x in
185230 let new_env = Environ.push_rel (x,Some v,t) env in
186 let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
231 let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
187232 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
188233 then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b
189234 else
197242
198243 with
199244 | Toberemoved ->
200 (* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
245 (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
201246 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in
202247 new_b, List.map pop binders_to_remove_from_b
203248 | Toberemoved_with_rel (n,c) ->
204 (* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
249 (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
205250 let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in
206251 new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b)
207252 end
208253 and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) =
209 let new_e,to_remove_from_e = compute_new_princ_type remove env e
210 in
211 new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
254 let new_e,to_remove_from_e = compute_new_princ_type remove env e
255 in
256 new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
212257 in
213258 (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *)
214259 let pre_res,_ =
215 compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in
260 compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ
261 in
262 let pre_res =
263 replace_vars
264 (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
265 (lift (List.length ptes_vars) pre_res)
266 in
216267 it_mkProd_or_LetIn
217 ~init:(it_mkProd_or_LetIn ~init:pre_res new_predicates)
268 ~init:(it_mkProd_or_LetIn
269 ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
270 new_predicates)
271 )
218272 princ_type_info.params
219273
220274
245299 let pp_dur time time' =
246300 str (string_of_float (System.time_difference time time'))
247301
248 (* End of things to be removed latter : just here to compare
249 saving proof with and without normalizing the proof
250 *)
251
252 let qed () = Command.save_named true
302 (* let qed () = save_named true *)
253303 let defined () = Command.save_named false
254 let generate_functional_principle
304
305
306
307
308
309 let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
310 (* First we get the type of the old graph principle *)
311 let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
312 (* let time1 = System.get_time () in *)
313 let new_principle_type =
314 compute_new_princ_type_from_rel
315 (Array.map mkConst funs)
316 sorts
317 old_princ_type
318 in
319 (* let time2 = System.get_time () in *)
320 (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
321 (* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *)
322 let new_princ_name =
323 next_global_ident_away true (id_of_string "___________princ_________") []
324 in
325 begin
326 Command.start_proof
327 new_princ_name
328 (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
329 new_principle_type
330 (hook new_principle_type)
331 ;
332 (* let _tim1 = System.get_time () in *)
333 Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams);
334 (* let _tim2 = System.get_time () in *)
335 (* begin *)
336 (* let dur1 = System.time_difference tim1 tim2 in *)
337 (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
338 (* end; *)
339 get_proof_clean true
340 end
341
342
343
344 let generate_functional_principle
255345 interactive_proof
256 old_princ_type sorts new_princ_name funs i proof_tac
257 =
258 let f = funs.(i) in
259 let type_sort = Termops.new_sort_in_family InType in
260 let new_sorts =
261 match sorts with
346 old_princ_type sorts new_princ_name funs i proof_tac
347 =
348 let f = funs.(i) in
349 let type_sort = Termops.new_sort_in_family InType in
350 let new_sorts =
351 match sorts with
262352 | None -> Array.make (Array.length funs) (type_sort)
263353 | Some a -> a
264354 in
265 (* First we get the type of the old graph principle *)
266 let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
267 (* First we get the type of the old graph principle *)
268 let new_principle_type =
269 compute_new_princ_type_from_rel
270 (Array.map mkConst funs)
271 new_sorts
272 old_princ_type
273 in
274 (* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *)
275355 let base_new_princ_name,new_princ_name =
276356 match new_princ_name with
277357 | Some (id) -> id,id
279359 let id_of_f = id_of_label (con_label f) in
280360 id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
281361 in
282 let names = ref [new_princ_name] in
283 let hook _ _ =
284 if sorts = None
362 let names = ref [new_princ_name] in
363 let hook new_principle_type _ _ =
364 if sorts = None
285365 then
286 (* let id_of_f = id_of_label (con_label f) in *)
287 let register_with_sort fam_sort =
288 let s = Termops.new_sort_in_family fam_sort in
289 let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
290 let value =
291 change_property_sort s new_principle_type new_princ_name
366 (* let id_of_f = id_of_label (con_label f) in *)
367 let register_with_sort fam_sort =
368 let s = Termops.new_sort_in_family fam_sort in
369 let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
370 let value = change_property_sort s new_principle_type new_princ_name in
371 (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
372 let ce =
373 { const_entry_body = value;
374 const_entry_type = None;
375 const_entry_opaque = false;
376 const_entry_boxed = Options.boxed_definitions()
377 }
378 in
379 ignore(
380 Declare.declare_constant
381 name
382 (Entries.DefinitionEntry ce,
383 Decl_kinds.IsDefinition (Decl_kinds.Scheme)
384 )
385 );
386 names := name :: !names
292387 in
293 (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
294 let ce =
295 { const_entry_body = value;
296 const_entry_type = None;
297 const_entry_opaque = false;
298 const_entry_boxed = Options.boxed_definitions()
299 }
300 in
301 ignore(
302 Declare.declare_constant
303 name
304 (Entries.DefinitionEntry ce,
305 Decl_kinds.IsDefinition (Decl_kinds.Scheme)
306 )
307 );
308 names := name :: !names
309 in
310 register_with_sort InProp;
311 register_with_sort InSet
312 in
313 begin
314 Command.start_proof
315 new_princ_name
316 (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
317 new_principle_type
318 hook
319 ;
320 try
321 let _tim1 = System.get_time () in
322 Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams);
323 let _tim2 = System.get_time () in
324 (* begin *)
325 (* let dur1 = System.time_difference tim1 tim2 in *)
326 (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
327 (* end; *)
328 let do_save = not (do_observe ()) && not interactive_proof in
329 let _ =
330 try
331 (* Vernacentries.show_script (); *)
332 Options.silently defined ();
333 let _dur2 = System.time_difference _tim2 (System.get_time ()) in
334 (* Pp.msgnl (str ("Time to check proof: ") ++ str (string_of_float dur2)); *)
335 Options.if_verbose
336 (fun () ->
337 Pp.msgnl (
338 prlist_with_sep
339 (fun () -> str" is defined " ++ fnl ())
340 Ppconstr.pr_id
341 (List.rev !names) ++ str" is defined "
342 )
343 )
344 ()
345 with e when do_save ->
346 msg_warning
347 (
348 Cerrors.explain_exn e
349 );
350 if not (do_observe ())
351 then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end
352 in
353 ()
354
355 (* let tim3 = Sys.time () in *)
356 (* Pp.msgnl (str ("Time to save proof: ") ++ str (string_of_float (tim3 -. tim2))); *)
357
358 with
359 | e ->
360 msg_warning
361 (
362 Cerrors.explain_exn e
363 );
364 if not ( do_observe ())
365 then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end
366 end
367
368
388 register_with_sort InProp;
389 register_with_sort InSet
390 in
391 let (id,(entry,g_kind,hook)) =
392 build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
393 in
394 save false new_princ_name entry g_kind hook
395 (* defined () *)
369396
370397
371398 exception Not_Rec
440467 l_const
441468
442469 exception No_graph_found
443
444 let make_scheme fas =
470 exception Found_type of int
471
472 let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
445473 let env = Global.env ()
446474 and sigma = Evd.empty in
447 let id_to_constr id =
448 Tacinterp.constr_of_id env id
449 in
450 let funs =
451 List.map
452 (fun (_,f,_) ->
453 try id_to_constr f
454 with Not_found ->
455 Util.error ("Cannot find "^ string_of_id f)
456 )
457 fas
458 in
459 let first_fun = destConst (List.hd funs) in
460 let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in
461 let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in
475 let funs = List.map fst fas in
476 let first_fun = List.hd funs in
477
478
479 let funs_mp,funs_dp,_ = Names.repr_con first_fun in
462480 let first_fun_kn =
463481 try
464 (* Fixme: take into account funs_mp and funs_dp *)
465 fst (destInd (id_to_constr first_fun_rel_id))
466 with Not_found -> raise No_graph_found
482 fst (find_Function_infos first_fun).graph_ind
483 with Not_found -> raise No_graph_found
467484 in
468485 let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
469486 let this_block_funs = Array.map fst this_block_funs_indexes in
471488 let funs_indexes =
472489 let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
473490 List.map
474 (function const -> List.assoc (destConst const) this_block_funs_indexes)
491 (function const -> List.assoc const this_block_funs_indexes)
475492 funs
476493 in
477494 let ind_list =
483500 )
484501 funs_indexes
485502 in
486 let l_schemes = List.map (Typing.type_of env sigma ) (Indrec.build_mutual_indrec env sigma ind_list) in
503 let l_schemes =
504 List.map
505 (Typing.type_of env sigma)
506 (Indrec.build_mutual_indrec env sigma ind_list)
507 in
487508 let i = ref (-1) in
488509 let sorts =
489 List.rev_map (fun (_,_,x) ->
510 List.rev_map (fun (_,x) ->
490511 Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
491512 )
492513 fas
493514 in
494 let princ_names = List.map (fun (x,_,_) -> x) fas in
495 let _ = List.map2
496 (fun princ_name scheme_type ->
497 incr i;
498 (* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *)
499 (* 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 *)
500 (* ); *)
501 generate_functional_principle
502 false
503 scheme_type
504 (Some (Array.of_list sorts))
505 (Some princ_name)
506 this_block_funs
507 !i
508 (prove_princ_for_struct false !i (Array.of_list (List.map destConst funs)))
515 (* We create the first priciple by tactic *)
516 let first_type,other_princ_types =
517 match l_schemes with
518 s::l_schemes -> s,l_schemes
519 | _ -> anomaly ""
520 in
521 let (_,(const,_,_)) =
522 build_functional_principle false
523 first_type
524 (Array.of_list sorts)
525 this_block_funs
526 0
527 (prove_princ_for_struct false 0 (Array.of_list funs))
528 (fun _ _ _ -> ())
529 in
530 incr i;
531 (* The others are just deduced *)
532 if other_princ_types = []
533 then
534 [const]
535 else
536 let other_fun_princ_types =
537 let funs = Array.map mkConst this_block_funs in
538 let sorts = Array.of_list sorts in
539 List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
540 in
541 let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
542 let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
543 let (idxs,_),(_,ta,_ as decl) = destFix fix in
544 let other_result =
545 List.map (* we can now compute the other principles *)
546 (fun scheme_type ->
547 incr i;
548 observe (Printer.pr_lconstr scheme_type);
549 let type_concl = snd (Sign.decompose_prod_assum scheme_type) in
550 let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
551 let f = fst (decompose_app applied_f) in
552 try (* we search the number of the function in the fix block (name of the function) *)
553 Array.iteri
554 (fun j t ->
555 let t = snd (Sign.decompose_prod_assum t) in
556 let applied_g = List.hd (List.rev (snd (decompose_app t))) in
557 let g = fst (decompose_app applied_g) in
558 if eq_constr f g
559 then raise (Found_type j);
560 observe (Printer.pr_lconstr f ++ str " <> " ++
561 Printer.pr_lconstr g)
562
563 )
564 ta;
565 (* If we reach this point, the two principle are not mutually recursive
566 We fall back to the previous method
567 *)
568 let (_,(const,_,_)) =
569 build_functional_principle
570 false
571 (List.nth other_princ_types (!i - 1))
572 (Array.of_list sorts)
573 this_block_funs
574 !i
575 (prove_princ_for_struct false !i (Array.of_list funs))
576 (fun _ _ _ -> ())
577 in
578 const
579 with Found_type i ->
580 let princ_body =
581 Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
582 in
583 {const with
584 Entries.const_entry_body = princ_body;
585 Entries.const_entry_type = Some scheme_type
586 }
587 )
588 other_fun_princ_types
589 in
590 const::other_result
591
592 let build_scheme fas =
593 (* (fun (f,_) -> *)
594 (* try Libnames.constr_of_global (Nametab.global f) *)
595 (* with Not_found -> *)
596 (* Util.error ("Cannot find "^ Libnames.string_of_reference f) *)
597 (* ) *)
598 (* fas *)
599
600 let bodies_types =
601 make_scheme
602 (List.map
603 (fun (_,f,sort) ->
604 let f_as_constant =
605 try
606 match Nametab.global f with
607 | Libnames.ConstRef c -> c
608 | _ -> Util.error "Functional Scheme can only be used with functions"
609 with Not_found ->
610 Util.error ("Cannot find "^ Libnames.string_of_reference f)
611 in
612 (f_as_constant,sort)
613 )
614 fas
615 )
616 in
617 List.iter2
618 (fun (princ_id,_,_) def_entry ->
619 ignore (Declare.declare_constant
620 princ_id
621 (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
622 Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
509623 )
510 princ_names
511 l_schemes
512 in
513 ()
514
515 let make_case_scheme fa =
624 fas
625 bodies_types
626
627
628
629 let build_case_scheme fa =
516630 let env = Global.env ()
517631 and sigma = Evd.empty in
518 let id_to_constr id =
519 Tacinterp.constr_of_id env id
520 in
521 let funs = (fun (_,f,_) -> id_to_constr f) fa in
632 (* let id_to_constr id = *)
633 (* Tacinterp.constr_of_id env id *)
634 (* in *)
635 let funs = (fun (_,f,_) ->
636 try Libnames.constr_of_global (Nametab.global f)
637 with Not_found ->
638 Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
522639 let first_fun = destConst funs in
523 let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in
524 let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in
525 let first_fun_kn =
526 (* Fixme: take into accour funs_mp and funs_dp *)
527 fst (destInd (id_to_constr first_fun_rel_id))
528 in
640
641 let funs_mp,funs_dp,_ = Names.repr_con first_fun in
642 let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in
643
644
645
529646 let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
530647 let this_block_funs = Array.map fst this_block_funs_indexes in
531648 let prop_sort = InProp in
+7
-4
contrib/funind/functional_principles_types.mli less more
00 open Names
11 open Term
2
3
24 val generate_functional_principle :
35 (* do we accept interactive proving *)
46 bool ->
1820 (constr array -> int -> Tacmach.tactic) ->
1921 unit
2022
21
22
2323 val compute_new_princ_type_from_rel : constr array -> sorts array ->
2424 types -> types
2525
2626
2727 exception No_graph_found
2828
29 val make_scheme : (identifier*identifier*Rawterm.rawsort) list -> unit
30 val make_case_scheme : (identifier*identifier*Rawterm.rawsort) -> unit
29 val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list
30
31 val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list -> unit
32 val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort) -> unit
33
+171
-49
contrib/funind/indfun.ml less more
55 open Libnames
66 open Rawterm
77 open Declarations
8
9 let is_rec_info scheme_info =
10 let test_branche min acc (_,_,br) =
11 acc || (
12 let new_branche =
13 Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in
14 let free_rels_in_br = Termops.free_rels new_branche in
15 let max = min + scheme_info.Tactics.npredicates in
16 Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
17 )
18 in
19 Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
20
21
22 let choose_dest_or_ind scheme_info =
23 if is_rec_info scheme_info
24 then Tactics.new_induct
25 else Tactics.new_destruct
26
27
28 let functional_induction with_clean c princl pat =
29 let f,args = decompose_app c in
30 fun g ->
31 let princ,bindings, princ_type =
32 match princl with
33 | None -> (* No principle is given let's find the good one *)
34 begin
35 match kind_of_term f with
36 | Const c' ->
37 let princ_option =
38 let finfo = (* we first try to find out a graph on f *)
39 try find_Function_infos c'
40 with Not_found ->
41 errorlabstrm "" (str "Cannot find induction information on "++Printer.pr_lconstr (mkConst c') )
42 in
43 match Tacticals.elimination_sort_of_goal g with
44 | InProp -> finfo.prop_lemma
45 | InSet -> finfo.rec_lemma
46 | InType -> finfo.rect_lemma
47 in
48 let princ = (* then we get the principle *)
49 try mkConst (out_some princ_option )
50 with Failure "out_some" ->
51 (*i If there is not default lemma defined then, we cross our finger and try to
52 find a lemma named f_ind (or f_rec, f_rect) i*)
53 let princ_name =
54 Indrec.make_elimination_ident
55 (id_of_label (con_label c'))
56 (Tacticals.elimination_sort_of_goal g)
57 in
58 try
59 mkConst(const_of_id princ_name )
60 with Not_found -> (* This one is neither defined ! *)
61 errorlabstrm "" (str "Cannot find induction principle for "
62 ++Printer.pr_lconstr (mkConst c') )
63 in
64 (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
65 | _ -> raise (UserError("",str "functional induction must be used with a function" ))
66
67 end
68 | Some ((princ,binding)) ->
69 princ,binding,Tacmach.pf_type_of g princ
70 in
71 let princ_infos = Tactics.compute_elim_sig princ_type in
72 let args_as_induction_constr =
73 let c_list =
74 if princ_infos.Tactics.farg_in_concl
75 then [c] else []
76 in
77 List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list)
78 in
79 let princ' = Some (princ,bindings) in
80 let princ_vars =
81 List.fold_right
82 (fun a acc ->
83 try Idset.add (destVar a) acc
84 with _ -> acc
85 )
86 args
87 Idset.empty
88 in
89 let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
90 let old_idl = Idset.diff old_idl princ_vars in
91 let subst_and_reduce g =
92 let idl =
93 map_succeed
94 (fun id ->
95 if Idset.mem id old_idl then failwith "subst_and_reduce";
96 id
97 )
98 (Tacmach.pf_ids_of_hyps g)
99 in
100 let flag =
101 Rawterm.Cbv
102 {Rawterm.all_flags
103 with Rawterm.rDelta = false;
104 }
105 in
106 if with_clean
107 then
108 Tacticals.tclTHEN
109 (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
110 (Hiddentac.h_reduce flag Tacticals.allClauses)
111 g
112 else Tacticals.tclIDTAC g
113
114 in
115 Tacticals.tclTHEN
116 (choose_dest_or_ind
117 princ_infos
118 args_as_induction_constr
119 princ'
120 pat)
121 subst_and_reduce
122 g
123
124
125
8126
9127 type annot =
10128 Struct of identifier
119237 (fun_args,rt')
120238
121239
240 let derive_inversion fix_names =
241 try
242 Invfun.derive_correctness
243 Functional_principles_types.make_scheme
244 functional_induction
245 (List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names)
246 (*i The next call to mk_rel_id is valid since we have just construct the graph
247 Ensures by : register_built
248 i*)
249 (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names)
250 with e ->
251 msg_warning (str "Cannot define correction of function and graph" ++ Cerrors.explain_exn e)
252
122253 let generate_principle
123254 do_built fix_rec_l recdefs interactive_proof parametrize
124 (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) =
255 (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit =
125256 let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in
126257 let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
127258 let funs_args = List.map fst fun_bodies in
132263 if do_built
133264 then
134265 begin
266 (*i The next call to mk_rel_id is valid since we have just construct the graph
267 Ensures by : do_built
268 i*)
135269 let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
136270 let ind_kn =
137271 fst (locate_with_msg
148282 in
149283 let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
150284 let _ =
151 Util.list_map_i
285 list_map_i
152286 (fun i x ->
153287 let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
154288 let princ_type =
166300 0
167301 fix_rec_l
168302 in
303 Array.iter add_Function funs_kn;
169304 ()
170305 end
171306 with e ->
209344 if List.length names = 1 then 1
210345 else error "Recursive argument must be specified"
211346 | Some wf_arg ->
212 Util.list_index (Name wf_arg) names
347 list_index (Name wf_arg) names
213348 in
214349 let unbounded_eq =
215350 let f_app_args =
235370 (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
236371 functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
237372 );
238 Command.save_named true
373 derive_inversion [fname]
239374 with e ->
240375 (* No proof done *)
241376 ()
332467 (Topconstr.names_of_local_assums args)
333468 in
334469 let annot =
335 try Some (Util.list_index (Name id) names - 1), Topconstr.CStructRec
470 try Some (list_index (Name id) names - 1), Topconstr.CStructRec
336471 with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id))
337472 in
338473 (name,annot,args,types,body),(None:Vernacexpr.decl_notation)
339474 | (name,None,args,types,body),recdef ->
340475 let names = (Topconstr.names_of_local_assums args) in
341476 if is_one_rec recdef && List.length names > 1 then
342 Util.user_err_loc
343 (Util.dummy_loc,"Function",
477 user_err_loc
478 (dummy_loc,"Function",
344479 Pp.str "the recursive argument needs to be specified in Function")
345480 else
346481 (name,(Some 0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation)
363498 interactive_proof
364499 true
365500 (Functional_principles_proofs.prove_princ_for_struct interactive_proof);
366 true
367
501 if register_built then derive_inversion fix_names;
502 true;
368503 in
369504 ()
370505
396531 | CApp(loc,(pf,b),bl) ->
397532 CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl)
398533 | CCases(loc,b_option,cel,cal) ->
399 CCases(loc,Util.option_map (add_args id new_args) b_option,
400 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,
534 CCases(loc,option_map (add_args id new_args) b_option,
535 List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,option_map (add_args id new_args) b_option)) cel,
401536 List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
402537 )
403538 | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
404 CLetTuple(loc,nal,(na,Util.option_map (add_args id new_args) b_option),
539 CLetTuple(loc,nal,(na,option_map (add_args id new_args) b_option),
405540 add_args id new_args b1,
406541 add_args id new_args b2
407542 )
408543
409544 | CIf(loc,b1,(na,b_option),b2,b3) ->
410545 CIf(loc,add_args id new_args b1,
411 (na,Util.option_map (add_args id new_args) b_option),
546 (na,option_map (add_args id new_args) b_option),
412547 add_args id new_args b2,
413548 add_args id new_args b3
414549 )
425560
426561
427562
428 let make_graph (id:identifier) =
429 let c_body =
430 try
431 let c = const_of_id id in
432 Global.lookup_constant c
433 with Not_found ->
434 raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id) )
435 in
436
563 let make_graph (f_ref:global_reference) =
564 let c,c_body =
565 match f_ref with
566 | ConstRef c ->
567 begin try c,Global.lookup_constant c
568 with Not_found ->
569 raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
570 end
571 | _ -> raise (UserError ("", str "Not a function reference") )
572
573 in
437574 match c_body.const_body with
438575 | None -> error "Cannot build a graph over an axiom !"
439576 | Some b ->
493630 (fun n (nal,t'') ->
494631 n+List.length nal) n nal_ta'
495632 in
496 assert (n'<= n);
633 (* assert (n'<= n); *)
497634 chop_n_arrow (n - n') t'
498635 | _ -> anomaly "Not enough products"
499636 else t
510647 let l =
511648 List.map
512649 (fun (id,(n,recexp),bl,t,b) ->
513 (* let nal = *)
514 (* List.flatten *)
515 (* (List.map *)
516 (* (function *)
517 (* | Topconstr.LocalRawDef (na,_)-> [] *)
518 (* | Topconstr.LocalRawAssum (nal,_) -> nal *)
519 (* ) *)
520 (* (nal_tas@bl) *)
521 (* ) *)
522 (* in *)
523650 let bl' =
524651 List.flatten
525652 (List.map
538665 (List.map
539666 (function
540667 | Topconstr.LocalRawDef (na,_)-> []
541 | Topconstr.LocalRawAssum (nal,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal
668 | Topconstr.LocalRawAssum (nal,_) ->
669 List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal
542670 )
543671 nal_tas
544672 )
550678 in
551679 l
552680 | _ ->
681 let id = id_of_label (con_label c) in
553682 [(id,None,nal_tas,t,b)]
554683 in
555 (* List.iter (fun (id,rec_arg,bl,t,b) -> *)
556 (* Pp.msgnl *)
557 (* (Ppconstr.pr_id id ++ *)
558 (* Ppconstr.pr_binders bl ++ *)
559 (* begin match rec_arg with *)
560 (* | Some (Struct id) -> str " { struct " ++ Ppconstr.pr_id id ++ str " }" *)
561 (* | _ -> (mt ()) *)
562 (* end ++ *)
563 (* str " : " ++ Ppconstr.pr_lconstr_expr t ++ *)
564 (* str " := " ++ *)
565 (* Ppconstr.pr_lconstr_expr b *)
566 (* ) *)
567 (* ) *)
568 (* expr_list; *)
569 do_generate_principle false false expr_list
684 do_generate_principle false false expr_list;
685 (* We register the infos *)
686 let mp,dp,_ = repr_con c in
687 List.iter (fun (id,_,_,_,_) -> add_Function (make_con mp dp (label_of_id id))) expr_list
688
689
570690 (* let make_graph _ = assert false *)
571691
572692 let do_generate_principle = do_generate_principle true
693
694
+323
-176
contrib/funind/indfun_common.ml less more
44
55 let mk_prefix pre id = id_of_string (pre^(string_of_id id))
66 let mk_rel_id = mk_prefix "R_"
7 let mk_correct_id id = Nameops.add_suffix id "_correct"
8 let mk_complete_id id = Nameops.add_suffix id "_complete"
9 let mk_equation_id id = Nameops.add_suffix id "_equation"
710
811 let msgnl m =
912 ()
1013
1114 let invalid_argument s = raise (Invalid_argument s)
12
13 (* let idtbl = Hashtbl.create 29 *)
14 (* let reset_name () = Hashtbl.clear idtbl *)
15
16 (* let fresh_id s = *)
17 (* try *)
18 (* let id = Hashtbl.find idtbl s in *)
19 (* incr id; *)
20 (* id_of_string (s^(string_of_int !id)) *)
21 (* with Not_found -> *)
22 (* Hashtbl.add idtbl s (ref (-1)); *)
23 (* id_of_string s *)
24
25 (* let fresh_name s = Name (fresh_id s) *)
26 (* let get_name ?(default="H") = function *)
27 (* | Anonymous -> fresh_name default *)
28 (* | Name n -> Name n *)
29
3015
3116
3217 let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid
158143 let eq = lazy(coq_constant "eq")
159144 let refl_equal = lazy(coq_constant "refl_equal")
160145
161
162 (* (\************************************************\) *)
163 (* (\* Should be removed latter *\) *)
164 (* (\* Comes from new induction (cf Pierre) *\) *)
165 (* (\************************************************\) *)
166
167 (* open Sign *)
168 (* open Term *)
169
170 (* type elim_scheme = *)
171
172 (* (\* { (\\* lists are in reverse order! *\\) *\) *)
173 (* (\* params: rel_context; (\\* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *\\) *\) *)
174 (* (\* predicates: rel_context; (\\* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *\\) *\) *)
175 (* (\* branches: rel_context; (\\* branchr,...,branch1 *\\) *\) *)
176 (* (\* args: rel_context; (\\* (xni, Ti_ni) ... (x1, Ti_1) *\\) *\) *)
177 (* (\* indarg: rel_declaration option; (\\* Some (H,I prm1..prmp x1...xni) if present, None otherwise *\\) *\) *)
178 (* (\* concl: types; (\\* Qi x1...xni HI, some prmis may not be present *\\) *\) *)
179 (* (\* indarg_in_concl:bool; (\\* true if HI appears at the end of conclusion (dependent scheme) *\\) *\) *)
180 (* (\* } *\) *)
181
182
183
184 (* let occur_rel n c = *)
185 (* let res = not (noccurn n c) in *)
186 (* res *)
187
188 (* let list_filter_firsts f l = *)
189 (* let rec list_filter_firsts_aux f acc l = *)
190 (* match l with *)
191 (* | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l' *)
192 (* | _ -> acc,l *)
193 (* in *)
194 (* list_filter_firsts_aux f [] l *)
195
196 (* let count_rels_from n c = *)
197 (* let rels = Termops.free_rels c in *)
198 (* let cpt,rg = ref 0, ref n in *)
199 (* while Util.Intset.mem !rg rels do *)
200 (* cpt:= !cpt+1; rg:= !rg+1; *)
201 (* done; *)
202 (* !cpt *)
203
204 (* let count_nonfree_rels_from n c = *)
205 (* let rels = Termops.free_rels c in *)
206 (* if Util.Intset.exists (fun x -> x >= n) rels then *)
207 (* let cpt,rg = ref 0, ref n in *)
208 (* while not (Util.Intset.mem !rg rels) do *)
209 (* cpt:= !cpt+1; rg:= !rg+1; *)
210 (* done; *)
211 (* !cpt *)
212 (* else raise Not_found *)
213
214 (* (\* cuts a list in two parts, first of size n. Size must be greater than n *\) *)
215 (* let cut_list n l = *)
216 (* let rec cut_list_aux acc n l = *)
217 (* if n<=0 then acc,l *)
218 (* else match l with *)
219 (* | [] -> assert false *)
220 (* | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in *)
221 (* let res = cut_list_aux [] n l in *)
222 (* res *)
223
224 (* let exchange_hd_prod subst_hd t = *)
225 (* let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) *)
226
227 (* let compute_elim_sig elimt = *)
228 (* (\* conclusion is the final (Qi ...) *\) *)
229 (* let hyps,conclusion = decompose_prod_assum elimt in *)
230 (* (\* ccl is conclusion where Qi (that is rel <something>) is replaced *)
231 (* by a constant (Prop) to avoid it being counted as an arg or *)
232 (* parameter in the following. *\) *)
233 (* let ccl = exchange_hd_prod mkProp conclusion in *)
234 (* (\* indarg is the inductive argument if it exists. If it exists it is *)
235 (* the last hyp before the conclusion, so it is the first element of *)
236 (* hyps. To know the first elmt is an inductive arg, we check if the *)
237 (* it appears in the conclusion (as rel 1). If yes, then it is not *)
238 (* an inductive arg, otherwise it is. There is a pathological case *)
239 (* with False_inf where Qi is rel 1, so we first get rid of Qi in *)
240 (* ccl. *\) *)
241 (* (\* if last arg of ccl is an application then this a functional ind *)
242 (* principle *\) let last_arg_ccl = *)
243 (* try List.hd (List.rev (snd (decompose_app ccl))) *)
244 (* with Failure "hd" -> mkProp in (\* dummy constr that is not an app *)
245 (* *\) let hyps',indarg,dep = *)
246 (* if isApp last_arg_ccl *)
247 (* then *)
248 (* hyps,None , false (\* no HI at all *\) *)
249 (* else *)
250 (* try *)
251 (* if noccurn 1 ccl (\* rel 1 does not occur in ccl *\) *)
252 (* then *)
253 (* List.tl hyps , Some (List.hd hyps), false (\* it does not *)
254 (* occur in concl *\) else *)
255 (* List.tl hyps , Some (List.hd hyps) , true (\* it does occur in concl *\) *)
256 (* with Failure s -> Util.error "cannot recognise an induction schema" *)
257 (* in *)
258
259 (* (\* Arguments [xni...x1] must appear in the conclusion, so we count *)
260 (* successive rels appearing in conclusion **Qi is not considered a *)
261 (* rel** *\) let nargs = count_rels_from *)
262 (* (match indarg with *)
263 (* | None -> 1 *)
264 (* | Some _ -> 2) ccl in *)
265 (* let args,hyps'' = cut_list nargs hyps' in *)
266 (* let rel_is_pred (_,_,c) = isSort (snd(decompose_prod_assum c)) in *)
267 (* let branches,hyps''' = *)
268 (* list_filter_firsts (function x -> not (rel_is_pred x)) hyps'' *)
269 (* in *)
270 (* (\* Now we want to know which hyps remaining are predicates and which *)
271 (* are parameters *\) *)
272 (* (\* We rebuild *)
273
274 (* forall (x1:Ti_1) (xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY *)
275 (* x1...xni HI ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^ *)
276 (* optional *)
277 (* opt *)
278
279 (* Free rels appearing in this term are parameters. We catch all of *)
280 (* them if HI is present. In this case the number of parameters is *)
281 (* the number of free rels. Otherwise (principle generated by *)
282 (* functional induction or by hand) WE GUESS that all parameters *)
283 (* appear in Ti_js, IS THAT TRUE??. *)
284
285 (* TODO: if we want to generalize to the case where arges are merged *)
286 (* with branches (?) and/or where several predicates are cited in *)
287 (* the conclusion, we should do something more precise than just *)
288 (* counting free rels. *)
289 (* *\) *)
290 (* let concl_with_indarg = *)
291 (* match indarg with *)
292 (* | None -> ccl *)
293 (* | Some c -> it_mkProd_or_LetIn ccl [c] in *)
294 (* let concl_with_args = it_mkProd_or_LetIn concl_with_indarg args in *)
295 (* (\* let nparams2 = Util.Intset.cardinal (Termops.free_rels concl_with_args) in *\) *)
296 (* let nparams = *)
297 (* try List.length (hyps'''@branches) - count_nonfree_rels_from 1 *)
298 (* concl_with_args with Not_found -> 0 in *)
299 (* let preds,params = cut_list (List.length hyps''' - nparams) hyps''' in *)
300 (* let elimscheme = { *)
301 (* params = params; *)
302 (* predicates = preds; *)
303 (* branches = branches; *)
304 (* args = args; *)
305 (* indarg = indarg; *)
306 (* concl = conclusion; *)
307 (* indarg_in_concl = dep; *)
308 (* } *)
309 (* in *)
310 (* elimscheme *)
311
312 (* let get_params elimt = *)
313 (* (compute_elim_sig elimt).params *)
314 (* (\************************************************\) *)
315 (* (\* end of Should be removed latter *\) *)
316 (* (\* Comes from new induction (cf Pierre) *\) *)
317 (* (\************************************************\) *)
318
146 (*****************************************************************)
147 (* Copy of the standart save mechanism but without the much too *)
148 (* slow reduction function *)
149 (*****************************************************************)
150 open Declarations
151 open Entries
152 open Decl_kinds
153 open Declare
154 let definition_message id =
155 Options.if_verbose message ((string_of_id id) ^ " is defined")
156
157
158 let save with_clean id const (locality,kind) hook =
159 let {const_entry_body = pft;
160 const_entry_type = tpo;
161 const_entry_opaque = opacity } = const in
162 let l,r = match locality with
163 | Local when Lib.sections_are_opened () ->
164 let k = logical_kind_of_goal_kind kind in
165 let c = SectionLocalDef (pft, tpo, opacity) in
166 let _ = declare_variable id (Lib.cwd(), c, k) in
167 (Local, VarRef id)
168 | Local ->
169 let k = logical_kind_of_goal_kind kind in
170 let kn = declare_constant id (DefinitionEntry const, k) in
171 (Global, ConstRef kn)
172 | Global ->
173 let k = logical_kind_of_goal_kind kind in
174 let kn = declare_constant id (DefinitionEntry const, k) in
175 (Global, ConstRef kn) in
176 if with_clean then Pfedit.delete_current_proof ();
177 hook l r;
178 definition_message id
179
180
181
182
183 let extract_pftreestate pts =
184 let pfterm,subgoals = Refiner.extract_open_pftreestate pts in
185 let tpfsigma = Refiner.evc_of_pftreestate pts in
186 let exl = Evarutil.non_instantiated tpfsigma in
187 if subgoals <> [] or exl <> [] then
188 Util.errorlabstrm "extract_proof"
189 (if subgoals <> [] then
190 str "Attempt to save an incomplete proof"
191 else
192 str "Attempt to save a proof with existential variables still non-instantiated");
193 let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in
194 env,tpfsigma,pfterm
195
196
197 let nf_betaiotazeta =
198 let clos_norm_flags flgs env sigma t =
199 Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
200 clos_norm_flags Closure.betaiotazeta
201
202 let nf_betaiota =
203 let clos_norm_flags flgs env sigma t =
204 Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
205 clos_norm_flags Closure.betaiota
206
207 let cook_proof do_reduce =
208 let pfs = Pfedit.get_pftreestate ()
209 (* and ident = Pfedit.get_current_proof_name () *)
210 and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in
211 let env,sigma,pfterm = extract_pftreestate pfs in
212 let pfterm =
213 if do_reduce
214 then nf_betaiota env sigma pfterm
215 else pfterm
216 in
217 (ident,
218 ({ const_entry_body = pfterm;
219 const_entry_type = Some concl;
220 const_entry_opaque = false;
221 const_entry_boxed = false},
222 strength, hook))
223
224
225 let new_save_named opacity =
226 let id,(const,persistence,hook) = cook_proof true in
227 let const = { const with const_entry_opaque = opacity } in
228 save true id const persistence hook
229
230 let get_proof_clean do_reduce =
231 let result = cook_proof do_reduce in
232 Pfedit.delete_current_proof ();
233 result
234
235
236
237
238 (**********************)
239
240 type function_info =
241 {
242 function_constant : constant;
243 graph_ind : inductive;
244 equation_lemma : constant option;
245 correctness_lemma : constant option;
246 completeness_lemma : constant option;
247 rect_lemma : constant option;
248 rec_lemma : constant option;
249 prop_lemma : constant option;
250 }
251
252
253 type function_db = function_info list
254
255 let function_table = ref ([] : function_db)
256
257
258 let rec do_cache_info finfo = function
259 | [] -> raise Not_found
260 | (finfo'::finfos as l) ->
261 if finfo' == finfo then l
262 else if finfo'.function_constant = finfo.function_constant
263 then finfo::finfos
264 else
265 let res = do_cache_info finfo finfos in
266 if res == finfos then l else finfo'::l
267
268
269 let cache_Function (_,(finfos)) =
270 let new_tbl =
271 try do_cache_info finfos !function_table
272 with Not_found -> finfos::!function_table
273 in
274 if new_tbl != !function_table
275 then function_table := new_tbl
276
277 let load_Function _ = cache_Function
278 let open_Function _ = cache_Function
279 let subst_Function (_,subst,finfos) =
280 let do_subst_con c = fst (Mod_subst.subst_con subst c)
281 and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i)
282 in
283 let function_constant' = do_subst_con finfos.function_constant in
284 let graph_ind' = do_subst_ind finfos.graph_ind in
285 let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in
286 let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in
287 let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in
288 let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in
289 let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in
290 let prop_lemma' = Util.option_smartmap do_subst_con finfos.prop_lemma in
291 if function_constant' == finfos.function_constant &&
292 graph_ind' == finfos.graph_ind &&
293 equation_lemma' == finfos.equation_lemma &&
294 correctness_lemma' == finfos.correctness_lemma &&
295 completeness_lemma' == finfos.completeness_lemma &&
296 rect_lemma' == finfos.rect_lemma &&
297 rec_lemma' == finfos.rec_lemma &&
298 prop_lemma' == finfos.prop_lemma
299 then finfos
300 else
301 { function_constant = function_constant';
302 graph_ind = graph_ind';
303 equation_lemma = equation_lemma' ;
304 correctness_lemma = correctness_lemma' ;
305 completeness_lemma = completeness_lemma' ;
306 rect_lemma = rect_lemma' ;
307 rec_lemma = rec_lemma';
308 prop_lemma = prop_lemma';
309 }
310
311 let classify_Function (_,infos) = Libobject.Substitute infos
312
313 let export_Function infos = Some infos
314
315
316 let discharge_Function (_,finfos) =
317 let function_constant' = Lib.discharge_con finfos.function_constant
318 and graph_ind' = Lib.discharge_inductive finfos.graph_ind
319 and equation_lemma' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma
320 and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma
321 and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma
322 and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma
323 and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma
324 and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma
325 in
326 if function_constant' == finfos.function_constant &&
327 graph_ind' == finfos.graph_ind &&
328 equation_lemma' == finfos.equation_lemma &&
329 correctness_lemma' == finfos.correctness_lemma &&
330 completeness_lemma' == finfos.completeness_lemma &&
331 rect_lemma' == finfos.rect_lemma &&
332 rec_lemma' == finfos.rec_lemma &&
333 prop_lemma' == finfos.prop_lemma
334 then Some finfos
335 else
336 Some { function_constant = function_constant' ;
337 graph_ind = graph_ind' ;
338 equation_lemma = equation_lemma' ;
339 correctness_lemma = correctness_lemma' ;
340 completeness_lemma = completeness_lemma';
341 rect_lemma = rect_lemma';
342 rec_lemma = rec_lemma';
343 prop_lemma = prop_lemma' ;
344 }
345
346 open Term
347 let pr_info f_info =
348 str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
349 str "function_constant_type := " ++
350 (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
351 str "equation_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
352 str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
353 str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
354 str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
355 str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
356 str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
357 str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
358
359 let pr_table l =
360 Util.prlist_with_sep fnl pr_info l
361
362 let in_Function,out_Function =
363 Libobject.declare_object
364 {(Libobject.default_object "FUNCTIONS_DB") with
365 Libobject.cache_function = cache_Function;
366 Libobject.load_function = load_Function;
367 Libobject.classify_function = classify_Function;
368 Libobject.subst_function = subst_Function;
369 Libobject.export_function = export_Function;
370 Libobject.discharge_function = discharge_Function
371 (* Libobject.open_function = open_Function; *)
372 }
373
374
375
376 (* Synchronisation with reset *)
377 let freeze () =
378 let tbl = !function_table in
379 (* Pp.msgnl (str "freezing function_table : " ++ pr_table tbl); *)
380 tbl
381
382 let unfreeze l =
383 (* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
384 function_table :=
385 l
386 let init () =
387 (* Pp.msgnl (str "reseting function_table"); *)
388 function_table := []
389
390 let _ =
391 Summary.declare_summary "functions_db_sum"
392 { Summary.freeze_function = freeze;
393 Summary.unfreeze_function = unfreeze;
394 Summary.init_function = init;
395 Summary.survive_module = false;
396 Summary.survive_section = false }
397
398 let find_or_none id =
399 try Some
400 (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
401 )
402 with Not_found -> None
403
404
405
406 let find_Function_infos f =
407 List.find (fun finfo -> finfo.function_constant = f) !function_table
408
409
410 let find_Function_of_graph ind =
411 List.find (fun finfo -> finfo.graph_ind = ind) !function_table
412
413 let update_Function finfo =
414 (* Pp.msgnl (pr_info finfo); *)
415 Lib.add_anonymous_leaf (in_Function finfo)
416
417
418 let add_Function f =
419 let f_id = id_of_label (con_label f) in
420 let equation_lemma = find_or_none (mk_equation_id f_id)
421 and correctness_lemma = find_or_none (mk_correct_id f_id)
422 and completeness_lemma = find_or_none (mk_complete_id f_id)
423 and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
424 and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
425 and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
426 and graph_ind =
427 match Nametab.locate (make_short_qualid (mk_rel_id f_id))
428 with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
429 in
430 let finfos =
431 { function_constant = f;
432 equation_lemma = equation_lemma;
433 completeness_lemma = completeness_lemma;
434 correctness_lemma = correctness_lemma;
435 rect_lemma = rect_lemma;
436 rec_lemma = rec_lemma;
437 prop_lemma = prop_lemma;
438 graph_ind = graph_ind
439 }
440 in
441 update_Function finfos
442
443 let pr_table () = pr_table !function_table
444 (*********************************)
445 (* Debuging *)
446 let function_debug = ref false
447 open Goptions
448
449 let function_debug_sig =
450 {
451 optsync = false;
452 optname = "Function debug";
453 optkey = PrimaryTable("Function_debug");
454 optread = (fun () -> !function_debug);
455 optwrite = (fun b -> function_debug := b)
456 }
457
458 let _ = declare_bool_option function_debug_sig
459
460
461 let do_observe () =
462 !function_debug = true
463
464
465
+64
-0
contrib/funind/indfun_common.mli less more
00 open Names
11 open Pp
22
3 (*
4 The mk_?_id function build different name w.r.t. a function
5 Each of their use is justified in the code
6 *)
37 val mk_rel_id : identifier -> identifier
8 val mk_correct_id : identifier -> identifier
9 val mk_complete_id : identifier -> identifier
10 val mk_equation_id : identifier -> identifier
11
412
513 val msgnl : std_ppcmds -> unit
614
3846 val const_of_id: identifier -> constant
3947
4048
49 (* [save_named] is a copy of [Command.save_named] but uses
50 [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
51
52
53
54 DON'T USE IT if you cannot ensure that there is no VMcast in the proof
55
56 *)
57
58 (* val nf_betaiotazeta : Reductionops.reduction_function *)
59
60 val new_save_named : bool -> unit
61
62 val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind ->
63 Tacexpr.declaration_hook -> unit
64
65 (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
66 abort the proof
67 *)
68 val get_proof_clean : bool ->
69 Names.identifier *
70 (Entries.definition_entry * Decl_kinds.goal_kind *
71 Tacexpr.declaration_hook)
72
73
74
75
76 (*****************)
77
78 type function_info =
79 {
80 function_constant : constant;
81 graph_ind : inductive;
82 equation_lemma : constant option;
83 correctness_lemma : constant option;
84 completeness_lemma : constant option;
85 rect_lemma : constant option;
86 rec_lemma : constant option;
87 prop_lemma : constant option;
88 }
89
90 val find_Function_infos : constant -> function_info
91 val find_Function_of_graph : inductive -> function_info
92 (* WARNING: To be used just after the graph definition !!! *)
93 val add_Function : constant -> unit
94
95 val update_Function : function_info -> unit
96
97
98 (** debugging *)
99 val pr_info : function_info -> Pp.std_ppcmds
100 val pr_table : unit -> Pp.std_ppcmds
101
102
103 val function_debug : bool ref
104 val do_observe : unit -> bool
+187
-117
contrib/funind/indfun_main.ml4 less more
1313 open Indfun
1414 open Genarg
1515 open Pcoq
16 open Tacticals
1617
1718 let pr_binding prc = function
1819 | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
3536 let pr_fun_ind_using prc prlc _ opt_c =
3637 match opt_c with
3738 | None -> mt ()
38 | Some c -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc c)
39 | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b))
40
3941
4042 ARGUMENT EXTEND fun_ind_using
4143 TYPED AS constr_with_bindings_opt
4648
4749
4850 TACTIC EXTEND newfuninv
49 [ "functional" "inversion" ident(hyp) ident(fname) fun_ind_using(princl)] ->
51 [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] ->
5052 [
51 fun g ->
52 let fconst = const_of_id fname in
53 let princ =
54 match princl with
55 | None ->
56 let f_ind_id =
57 (
58 Indrec.make_elimination_ident
59 fname
60 (Tacticals.elimination_sort_of_goal g)
61 )
62 in
63 let princ = const_of_id f_ind_id in
64 princ
65 | Some princ -> destConst (fst princ)
66 in
67 Invfun.invfun hyp fconst princ g
53 Invfun.invfun hyp fname
6854 ]
6955 END
7056
8167 END
8268
8369
84 let is_rec scheme_info =
85 let test_branche min acc (_,_,br) =
86 acc ||
87 (let new_branche = Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in
88 let free_rels_in_br = Termops.free_rels new_branche in
89 let max = min + scheme_info.Tactics.npredicates in
90 Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br)
91 in
92 Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
93
94
95 let choose_dest_or_ind scheme_info =
96 if is_rec scheme_info
97 then Tactics.new_induct
98 else Tactics.new_destruct
9970
10071
10172 TACTIC EXTEND newfunind
10273 ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
103 [
74 [
10475 let pat =
10576 match pat with
10677 | None -> IntroAnonymous
11182 | [c] -> c
11283 | c::cl -> applist(c,cl)
11384 in
114 let f,args = decompose_app c in
115 fun g ->
116 let princ,bindings =
117 match princl with
118 | None -> (* No principle is given let's find the good one *)
119 let fname =
120 match kind_of_term f with
121 | Const c' ->
122 id_of_label (con_label c')
123 | _ -> Util.error "Must be used with a function"
124 in
125 let princ_name =
126 (
127 Indrec.make_elimination_ident
128 fname
129 (Tacticals.elimination_sort_of_goal g)
130 )
131 in
132 mkConst(const_of_id princ_name ),Rawterm.NoBindings
133 | Some princ -> princ
134 in
135 let princ_type = Tacmach.pf_type_of g princ in
136 let princ_infos = Tactics.compute_elim_sig princ_type in
137 let args_as_induction_constr =
138 let c_list =
139 if princ_infos.Tactics.farg_in_concl
140 then [c] else []
141 in
142 List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list)
143 in
144 let princ' = Some (princ,bindings) in
145 let princ_vars =
146 List.fold_right
147 (fun a acc ->
148 try Idset.add (destVar a) acc
149 with _ -> acc
150 )
151 args
152 Idset.empty
153 in
154 let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
155 let old_idl = Idset.diff old_idl princ_vars in
156 let subst_and_reduce g =
157 let idl =
158 Util.map_succeed
159 (fun id ->
160 if Idset.mem id old_idl then failwith "";
161 id
162 )
163 (Tacmach.pf_ids_of_hyps g)
164 in
165 let flag =
166 Rawterm.Cbv
167 {Rawterm.all_flags
168 with Rawterm.rDelta = false;
169 }
170 in
171 Tacticals.tclTHEN
172 (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
173 (Hiddentac.h_reduce flag Tacticals.allClauses)
174 g
175 in
176 Tacticals.tclTHEN
177 (choose_dest_or_ind
178 princ_infos
179 args_as_induction_constr
180 princ'
181 pat)
182 subst_and_reduce
183 g
184 ]
85 functional_induction true c princl pat ]
86 END
87 (***** debug only ***)
88 TACTIC EXTEND snewfunind
89 ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
90 [
91 let pat =
92 match pat with
93 | None -> IntroAnonymous
94 | Some pat -> pat
95 in
96 let c = match cl with
97 | [] -> assert false
98 | [c] -> c
99 | c::cl -> applist(c,cl)
100 in
101 functional_induction false c princl pat ]
185102 END
186103
187104
212129 in
213130 let check_exists_args an =
214131 try
215 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
132 let id = match an with
133 | Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id
134 | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args"
135 in
216136 (try ignore(Util.list_index (Name id) names - 1); annot
217137 with Not_found -> Util.user_err_loc
218138 (Util.dummy_loc,"Function",
239159
240160 VERNAC COMMAND EXTEND Function
241161 ["Function" rec_definitions2(recsl)] ->
242 [ do_generate_principle false recsl]
162 [
163 do_generate_principle false recsl;
164
165 ]
243166 END
244167
245168
246169 VERNAC ARGUMENT EXTEND fun_scheme_arg
247 | [ ident(princ_name) ":=" "Induction" "for" ident(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
170 | [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
248171 END
249172
250173 VERNAC ARGUMENT EXTEND fun_scheme_args
256179 ["Functional" "Scheme" fun_scheme_args(fas) ] ->
257180 [
258181 try
259 Functional_principles_types.make_scheme fas
182 Functional_principles_types.build_scheme fas
260183 with Functional_principles_types.No_graph_found ->
261184 match fas with
262185 | (_,fun_name,_)::_ ->
263186 begin
264 make_graph fun_name;
265 try Functional_principles_types.make_scheme fas
187 make_graph (Nametab.global fun_name);
188 try Functional_principles_types.build_scheme fas
266189 with Functional_principles_types.No_graph_found ->
267190 Util.error ("Cannot generate induction principle(s)")
268191 end
269192 | _ -> assert false (* we can only have non empty list *)
270193 ]
271194 END
272
195 (***** debug only ***)
273196
274197 VERNAC COMMAND EXTEND NewFunctionalCase
275198 ["Functional" "Case" fun_scheme_arg(fas) ] ->
276199 [
277 Functional_principles_types.make_case_scheme fas
200 Functional_principles_types.build_case_scheme fas
278201 ]
279202 END
280203
281
204 (***** debug only ***)
282205 VERNAC COMMAND EXTEND GenerateGraph
283 ["Generate" "graph" "for" ident(c)] -> [ make_graph c ]
284 END
206 ["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
207 END
208
209
210
211
212
213 (* FINDUCTION *)
214
215 (* comment this line to see debug msgs *)
216 (* let msg x = () ;; let pr_lconstr c = str "" *)
217 (* uncomment this to see debugging *)
218 let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n")
219 let prlistconstr lc = List.iter prconstr lc
220 let prstr s = msg(str s)
221
222
223
224 (** Information about an occurrence of a function call (application)
225 inside a term. *)
226 type fapp_info = {
227 fname: constr; (** The function applied *)
228 largs: constr list; (** List of arguments *)
229 free: bool; (** [true] if all arguments are debruijn free *)
230 max_rel: int; (** max debruijn index in the funcall *)
231 onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *)
232 }
233
234
235 (** [constr_head_match(a b c) a] returns true, false otherwise. *)
236 let constr_head_match u t=
237 if isApp u
238 then
239 let uhd,args= destApp u in
240 uhd=t
241 else false
242
243 (** [hdMatchSub inu t] returns the list of occurrences of [t] in
244 [inu]. DeBruijn are not pushed, so some of them may be unbound in
245 the result. *)
246 let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
247 let subres =
248 match kind_of_term inu with
249 | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) ->
250 hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
251 | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *)
252 Array.fold_left
253 (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test)
254 [] bl
255 | _ -> (* Cofix will be wrong *)
256 fold_constr
257 (fun l cstr ->
258 l @ hdMatchSub cstr test) [] inu in
259 if not (test inu) then subres
260 else
261 let f,args = decompose_app inu in
262 let freeset = Termops.free_rels inu in
263 let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
264 {fname = f; largs = args; free = Util.Intset.is_empty freeset;
265 max_rel = max_rel; onlyvars = List.for_all isVar args }
266 ::subres
267
268
269 (** [find_fapp test g] returns the list of [app_info] of all calls to
270 functions that satisfy [test] in the conclusion of goal g. Trivial
271 repetition (not modulo conversion) are deleted. *)
272 let find_fapp (test:constr -> bool) g : fapp_info list =
273 let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
274 let res =
275 List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
276 (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
277 res)
278
279
280
281 (** [finduction id filter g] tries to apply functional induction on
282 an occurence of function [id] in the conclusion of goal [g]. If
283 [id]=[None] then calls to any function are selected. In any case
284 [heuristic] is used to select the most pertinent occurrence. *)
285 let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
286 (nexttac:Proof_type.tactic) g =
287 let test = match oid with
288 | Some id ->
289 let idconstr = mkConst (const_of_id id) in
290 (fun u -> constr_head_match u idconstr) (* select only id *)
291 | None -> (fun u -> isApp u) in (* select calls to any function *)
292 let info_list = find_fapp test g in
293 let ordered_info_list = heuristic info_list in
294 prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
295 if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
296 let taclist: Proof_type.tactic list =
297 List.map
298 (fun info ->
299 (tclTHEN
300 (functional_induction true (applist (info.fname, info.largs))
301 None IntroAnonymous)
302 nexttac)) ordered_info_list in
303 tclFIRST taclist g
304
305
306
307
308 (** [chose_heuristic oi x] returns the heuristic for reordering
309 (and/or forgetting some elts of) a list of occurrences of
310 function calls infos to chose first with functional induction. *)
311 let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
312 match oi with
313 | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
314 | None ->
315 (* Default heuristic: keep only occurrence where all arguments
316 are *bound* (meaning already introduced) variables *)
317 (* TODO: put other funcalls at the end instead of deleting them *)
318 let ordering x y =
319 if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *)
320 else if x.free && x.onlyvars then -1
321 else if y.free && y.onlyvars then 1
322 else 0 (* both not pertinent *)
323 in
324 List.sort ordering
325
326
327 TACTIC EXTEND finduction
328 ["finduction" ident(id) natural_opt(oi)] ->
329 [
330 match oi with
331 | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
332 | _ ->
333 let heuristic = chose_heuristic oi in
334 finduction (Some id) heuristic tclIDTAC
335 ]
336 END
337
338
339
340 TACTIC EXTEND fauto
341 [ "fauto" tactic(tac)] ->
342 [
343 let heuristic = chose_heuristic None in
344 finduction None heuristic (snd tac)
345 ]
346 |
347 [ "fauto" ] ->
348 [
349 let heuristic = chose_heuristic None in
350 finduction None heuristic tclIDTAC
351 ]
352
353 END
354
+967
-127
contrib/funind/invfun.ml less more
0 (************************************************************************)
1 (* v * The Coq Proof Assistant / The Coq Development Team *)
2 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
3 (* \VV/ **************************************************************)
4 (* // * This file is distributed under the terms of the *)
5 (* * GNU Lesser General Public License Version 2.1 *)
6 (************************************************************************)
7 open Tacexpr
8 open Declarations
09 open Util
110 open Names
211 open Term
3 open Tacinvutils
412 open Pp
513 open Libnames
614 open Tacticals
816 open Indfun_common
917 open Tacmach
1018 open Sign
11
12
13 let tac_pattern l =
14 (Hiddentac.h_reduce
15 (Rawterm.Pattern l)
16 Tacticals.onConcl
17 )
18
19
20 let rec nb_prod x =
21 let rec count n c =
22 match kind_of_term c with
23 Prod(_,_,t) -> count (n+1) t
24 | LetIn(_,a,_,t) -> count n (subst1 a t)
25 | Cast(c,_,_) -> count n c
26 | _ -> n
27 in count 0 x
28
29 let intro_discr_until n tac : tactic =
30 let rec intro_discr_until acc : tactic =
19 open Hiddentac
20
21 (* Some pretty printing function for debugging purpose *)
22
23 let pr_binding prc =
24 function
25 | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
26 | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
27
28 let pr_bindings prc prlc = function
29 | Rawterm.ImplicitBindings l ->
30 brk (1,1) ++ str "with" ++ brk (1,1) ++
31 Util.prlist_with_sep spc prc l
32 | Rawterm.ExplicitBindings l ->
33 brk (1,1) ++ str "with" ++ brk (1,1) ++
34 Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
35 | Rawterm.NoBindings -> mt ()
36
37
38 let pr_with_bindings prc prlc (c,bl) =
39 prc c ++ hv 0 (pr_bindings prc prlc bl)
40
41
42
43 let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds =
44 pr_with_bindings prc prc (c,bl)
45
46 let pr_elim_scheme el =
47 let env = Global.env () in
48 let msg = str "params := " ++ Printer.pr_rel_context env el.params in
49 let env = Environ.push_rel_context el.params env in
50 let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
51 let env = Environ.push_rel_context el.predicates env in
52 let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
53 let env = Environ.push_rel_context el.branches env in
54 let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
55 let env = Environ.push_rel_context el.args env in
56 let msg =
57 Util.option_fold_right
58 (fun o msg -> msg ++ fnl () ++ str "indarg := " ++ Printer.pr_rel_context env [o])
59 el.indarg
60 msg
61 in
62 let env = Util.option_fold_right (fun o env -> Environ.push_rel_context [o] env) el.indarg env in
63 msg ++ fnl () ++ str "concl := " ++ Printer.pr_lconstr_env env el.concl
64
65 (* The local debuging mechanism *)
66 let msgnl = Pp.msgnl
67
68 let observe strm =
69 if do_observe ()
70 then Pp.msgnl strm
71 else ()
72
73 let observennl strm =
74 if do_observe ()
75 then begin Pp.msg strm;Pp.pp_flush () end
76 else ()
77
78
79 let do_observe_tac s tac g =
80 try let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
81 let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
82 with e ->
83 let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
84 msgnl (str "observation "++ s++str " raised exception " ++
85 Cerrors.explain_exn e ++ str " on goal " ++ goal );
86 raise e;;
87
88
89 let observe_tac s tac g =
90 if do_observe ()
91 then do_observe_tac (str s) tac g
92 else tac g
93
94 (* [nf_zeta] $\zeta$-normalization of a term *)
95 let nf_zeta =
96 Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
97 Environ.empty_env
98 Evd.empty
99
100
101 (* [id_to_constr id] finds the term associated to [id] in the global environment *)
102 let id_to_constr id =
103 try
104 Tacinterp.constr_of_id (Global.env ()) id
105 with Not_found ->
106 raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
107
108 (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
109 (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block.
110
111 [generate_type true f i] returns
112 \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
113 graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion
114
115 [generate_type false f i] returns
116 \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
117 res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion
118 *)
119
120 let generate_type g_to_f f graph i =
121 (*i we deduce the number of arguments of the function and its returned type from the graph i*)
122 let graph_arity = Inductive.type_of_inductive (Global.lookup_inductive (destInd graph)) in
123 let ctxt,_ = decompose_prod_assum graph_arity in
124 let fun_ctxt,res_type =
125 match ctxt with
126 | [] | [_] -> anomaly "Not a valid context"
127 | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
128 in
129 let nb_args = List.length fun_ctxt in
130 let args_from_decl i decl =
131 match decl with
132 | (_,Some _,_) -> incr i; failwith "args_from_decl"
133 | _ -> let j = !i in incr i;mkRel (nb_args - j + 1)
134 in
135 (*i We need to name the vars [res] and [fv] i*)
136 let res_id =
137 Termops.next_global_ident_away
138 true
139 (id_of_string "res")
140 (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
141 in
142 let fv_id =
143 Termops.next_global_ident_away
144 true
145 (id_of_string "fv")
146 (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
147 in
148 (*i we can then type the argument to be applied to the function [f] i*)
149 let args_as_rels =
150 let i = ref 0 in
151 Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
152 in
153 let args_as_rels = Array.map Termops.pop args_as_rels in
154 (*i
155 the hypothesis [res = fv] can then be computed
156 We will need to lift it by one in order to use it as a conclusion
157 i*)
158 let res_eq_f_of_args =
159 mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
160 in
161 (*i
162 The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
163 We will need to lift it by one in order to use it as a conclusion
164 i*)
165 let graph_applied =
166 let args_and_res_as_rels =
167 let i = ref 0 in
168 Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
169 in
170 let args_and_res_as_rels =
171 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
172 in
173 mkApp(graph,args_and_res_as_rels)
174 in
175 (*i The [pre_context] is the defined to be the context corresponding to
176 \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \]
177 i*)
178 let pre_ctxt =
179 (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt
180 in
181 (*i and we can return the solution depending on which lemma type we are defining i*)
182 if g_to_f
183 then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
184 else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
185
186
187 (*
188 [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
189
190 WARNING: while convertible, [type_of body] and [type] can be non equal
191 *)
192 let find_induction_principle f =
193 let f_as_constant = match kind_of_term f with
194 | Const c' -> c'
195 | _ -> error "Must be used with a function"
196 in
197 let infos = find_Function_infos f_as_constant in
198 match infos.rect_lemma with
199 | None -> raise Not_found
200 | Some rect_lemma ->
201 let rect_lemma = mkConst rect_lemma in
202 let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in
203 rect_lemma,typ
204
205
206
207 (* let fname = *)
208 (* match kind_of_term f with *)
209 (* | Const c' -> *)
210 (* id_of_label (con_label c') *)
211 (* | _ -> error "Must be used with a function" *)
212 (* in *)
213
214 (* let princ_name = *)
215 (* ( *)
216 (* Indrec.make_elimination_ident *)
217 (* fname *)
218 (* InType *)
219 (* ) *)
220 (* in *)
221 (* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *)
222 (* c,Typing.type_of (Global.env ()) Evd.empty c *)
223
224
225 let rec generate_fresh_id x avoid i =
226 if i == 0
227 then []
228 else
229 let id = Termops.next_global_ident_away true x avoid in
230 id::(generate_fresh_id x (id::avoid) (pred i))
231
232
233 (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
234 is the tactic used to prove correctness lemma.
235
236 [functional_induction] is the tactic defined in [indfun] (dependency problem)
237 [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
238 (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
239
240 [i] is the indice of the function to prove correct
241
242 The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
243 it looks like~:
244 [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
245 res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
246
247
248 The sketch of the proof is the following one~:
249 \begin{enumerate}
250 \item intros until $x_n$
251 \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
252 \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the
253 apply the corresponding constructor of the corresponding graph inductive.
254 \end{enumerate}
255
256 *)
257 let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
258 fun g ->
259 (* first of all we recreate the lemmas types to be used as predicates of the induction principle
260 that is~:
261 \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
262 *)
263 let lemmas =
264 Array.map
265 (fun (_,(ctxt,concl)) ->
266 match ctxt with
267 | [] | [_] | [_;_] -> anomaly "bad context"
268 | hres::res::(x,_,t)::ctxt ->
269 Termops.it_mkLambda_or_LetIn
270 ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res])
271 ((x,None,t)::ctxt)
272 )
273 lemmas_types_infos
274 in
275 (* we the get the definition of the graphs block *)
276 let graph_ind = destInd graphs_constr.(i) in
277 let kn = fst graph_ind in
278 let mib,_ = Global.lookup_inductive graph_ind in
279 (* and the principle to use in this lemma in $\zeta$ normal form *)
280 let f_principle,princ_type = schemes.(i) in
281 let princ_type = nf_zeta princ_type in
282 let princ_infos = Tactics.compute_elim_sig princ_type in
283 (* The number of args of the function is then easilly computable *)
284 let nb_fun_args = nb_prod (pf_concl g) - 2 in
285 let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
286 let ids = args_names@(pf_ids_of_hyps g) in
287 (* Since we cannot ensure that the funcitonnal principle is defined in the
288 environement and due to the bug #1174, we will need to pose the principle
289 using a name
290 *)
291 let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in
292 let ids = principle_id :: ids in
293 (* We get the branches of the principle *)
294 let branches = List.rev princ_infos.branches in
295 (* and built the intro pattern for each of them *)
296 let intro_pats =
297 List.map
298 (fun (_,_,br_type) ->
299 List.map
300 (fun id -> Genarg.IntroIdentifier id)
301 (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
302 )
303 branches
304 in
305 (* before building the full intro pattern for the principle *)
306 let pat = Genarg.IntroOrAndPattern intro_pats in
307 let eq_ind = Coqlib.build_coq_eq () in
308 let eq_construct = mkConstruct((destInd eq_ind),1) in
309 (* The next to referencies will be used to find out which constructor to apply in each branch *)
310 let ind_number = ref 0
311 and min_constr_number = ref 0 in
312 (* The tactic to prove the ith branch of the principle *)
313 let prove_branche i g =
314 (* We get the identifiers of this branch *)
315 let this_branche_ids =
316 List.fold_right
317 (fun pat acc ->
318 match pat with
319 | Genarg.IntroIdentifier id -> Idset.add id acc
320 | _ -> anomaly "Not an identifier"
321 )
322 (List.nth intro_pats (pred i))
323 Idset.empty
324 in
325 (* and get the real args of the branch by unfolding the defined constant *)
326 let pre_args,pre_tac =
327 List.fold_right
328 (fun (id,b,t) (pre_args,pre_tac) ->
329 if Idset.mem id this_branche_ids
330 then
331 match b with
332 | None -> (id::pre_args,pre_tac)
333 | Some b ->
334 (pre_args,
335 tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac
336 )
337
338 else (pre_args,pre_tac)
339 )
340 (pf_hyps g)
341 ([],tclIDTAC)
342 in
343 (*
344 We can then recompute the arguments of the constructor.
345 For each [hid] introduced by this branch, if [hid] has type
346 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
347 [ fv (hid fv (refl_equal fv)) ].
348
349 If [hid] has another type the corresponding argument of the constructor is [hid]
350 *)
351 let constructor_args =
352 List.fold_right
353 (fun hid acc ->
354 let type_of_hid = pf_type_of g (mkVar hid) in
355 match kind_of_term type_of_hid with
356 | Prod(_,_,t') ->
357 begin
358 match kind_of_term t' with
359 | Prod(_,t'',t''') ->
360 begin
361 match kind_of_term t'',kind_of_term t''' with
362 | App(eq,args), App(graph',_)
363 when
364 (eq_constr eq eq_ind) &&
365 array_exists (eq_constr graph') graphs_constr ->
366 ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
367 ::args.(2)::acc)
368 | _ -> mkVar hid :: acc
369 end
370 | _ -> mkVar hid :: acc
371 end
372 | _ -> mkVar hid :: acc
373 ) pre_args []
374 in
375 (* in fact we must also add the parameters to the constructor args *)
376 let constructor_args =
377 let params_id = fst (list_chop princ_infos.nparams args_names) in
378 (List.map mkVar params_id)@(List.rev constructor_args)
379 in
380 (* We then get the constructor corresponding to this branch and
381 modifies the references has needed i.e.
382 if the constructor is the last one of the current inductive then
383 add one the number of the inductive to take and add the number of constructor of the previous
384 graph to the minimal constructor number
385 *)
386 let constructor =
387 let constructor_num = i - !min_constr_number in
388 let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
389 if constructor_num <= length
390 then
391 begin
392 (kn,!ind_number),constructor_num
393 end
394 else
395 begin
396 incr ind_number;
397 min_constr_number := !min_constr_number + length ;
398 (kn,!ind_number),1
399 end
400 in
401 (* we can then build the final proof term *)
402 let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
403 (* an apply the tactic *)
404 let res,hres =
405 match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
406 | [res;hres] -> res,hres
407 | _ -> assert false
408 in
409 observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
410 (
411 tclTHENSEQ
412 [
413 (* unfolding of all the defined variables introduced by this branch *)
414 observe_tac "unfolding" pre_tac;
415 (* $zeta$ normalizing of the conclusion *)
416 h_reduce
417 (Rawterm.Cbv
418 { Rawterm.all_flags with
419 Rawterm.rDelta = false ;
420 Rawterm.rConst = []
421 }
422 )
423 onConcl;
424 (* introducing the the result of the graph and the equality hypothesis *)
425 observe_tac "introducing" (tclMAP h_intro [res;hres]);
426 (* replacing [res] with its value *)
427 observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
428 (* Conclusion *)
429 observe_tac "exact" (h_exact app_constructor)
430 ]
431 )
432 g
433 in
434 (* end of branche proof *)
435 let param_names = fst (list_chop princ_infos.nparams args_names) in
436 let params = List.map mkVar param_names in
437 let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
438 (* The bindings of the principle
439 that is the params of the principle and the different lemma types
440 *)
441 let bindings =
442 let params_bindings,avoid =
443 List.fold_left2
444 (fun (bindings,avoid) (x,_,_) p ->
445 let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in
446 (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
447 )
448 ([],[])
449 princ_infos.params
450 (List.rev params)
451 in
452 let lemmas_bindings =
453 List.rev (fst (List.fold_left2
454 (fun (bindings,avoid) (x,_,_) p ->
455 let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in
456 (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid)
457 ([],avoid)
458 princ_infos.predicates
459 (lemmas)))
460 in
461 Rawterm.ExplicitBindings (params_bindings@lemmas_bindings)
462 in
463 tclTHENSEQ
464 [ observe_tac "intro args_names" (tclMAP h_intro args_names);
465 observe_tac "principle" (forward
466 (Some (h_exact f_principle))
467 (Genarg.IntroIdentifier principle_id)
468 princ_type);
469 tclTHEN_i
470 (observe_tac "functional_induction" (
471 fun g ->
472 observe
473 (str "princ" ++ pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings));
474 functional_induction false (applist(funs_constr.(i),List.map mkVar args_names))
475 (Some (mkVar principle_id,bindings))
476 pat g
477 ))
478 (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
479 ]
480 g
481
482 (* [generalize_depedent_of x hyp g]
483 generalize every hypothesis which depends of [x] but [hyp]
484 *)
485 let generalize_depedent_of x hyp g =
486 tclMAP
487 (function
488 | (id,None,t) when not (id = hyp) &&
489 (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id]
490 | _ -> tclIDTAC
491 )
492 (pf_hyps g)
493 g
494
495 (* [prove_fun_complete funs graphs schemes lemmas_types_infos i]
496 is the tactic used to prove completness lemma.
497
498 [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
499 (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct.
500
501 [i] is the indice of the function to prove complete
502
503 The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
504 it looks like~:
505 [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
506 graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in]
507
508
509 The sketch of the proof is the following one~:
510 \begin{enumerate}
511 \item intros until $H:graph\ x_1\ldots x_n\ res$
512 \item $elim\ H$ using schemes.(i)
513 \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has
514 type [x=?] with [x] a variable, then subst [x],
515 if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else
516 if [h] is a match then destruct it, else do just introduce it,
517 after all intros, the conclusion should be a reflexive equality.
518 \end{enumerate}
519
520 *)
521
522
523 let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
524 fun g ->
525 (* We compute the types of the different mutually recursive lemmas
526 in $\zeta$ normal form
527 *)
528 let lemmas =
529 Array.map
530 (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
531 lemmas_types_infos
532 in
533 (* We get the constant and the principle corresponding to this lemma *)
534 let f = funcs.(i) in
535 let graph_principle = nf_zeta schemes.(i) in
536 let princ_type = pf_type_of g graph_principle in
537 let princ_infos = Tactics.compute_elim_sig princ_type in
538 (* Then we get the number of argument of the function
539 and compute a fresh name for each of them
540 *)
541 let nb_fun_args = nb_prod (pf_concl g) - 2 in
542 let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
543 let ids = args_names@(pf_ids_of_hyps g) in
544 (* and fresh names for res H and the principle (cf bug bug #1174) *)
545 let res,hres,graph_principle_id =
546 match generate_fresh_id (id_of_string "z") ids 3 with
547 | [res;hres;graph_principle_id] -> res,hres,graph_principle_id
548 | _ -> assert false
549 in
550 let ids = res::hres::graph_principle_id::ids in
551 (* we also compute fresh names for each hyptohesis of each branche of the principle *)
552 let branches = List.rev princ_infos.branches in
553 let intro_pats =
554 List.map
555 (fun (_,_,br_type) ->
556 List.map
557 (fun id -> id)
558 (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
559 )
560 branches
561 in
562 let eq_ind = Coqlib.build_coq_eq () in
563 (* We will need to change the function by its body
564 using [f_equation] if it is recursive (that is the graph is infinite
565 or unfold if the graph is finite
566 *)
567 let rewrite_tac j ids : tactic =
568 let graph_def = graphs.(j) in
569 if Rtree.is_infinite graph_def.mind_recargs
570 then
571 let eq_lemma =
572 try out_some (find_Function_infos (destConst funcs.(j))).equation_lemma
573 with Failure "out_some" | Not_found -> anomaly "Cannot find equation lemma"
574 in
575 tclTHENSEQ[
576 tclMAP h_intro ids;
577 Equality.rewriteLR (mkConst eq_lemma);
578 (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
579 h_reduce
580 (Rawterm.Cbv
581 {Rawterm.all_flags
582 with Rawterm.rDelta = false;
583 })
584 onConcl
585 ;
586 h_generalize (List.map mkVar ids);
587 thin ids
588 ]
589 else unfold_in_concl [([],Names.EvalConstRef (destConst f))]
590 in
591 (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
592 (unfolding, substituting, destructing cases \ldots)
593 *)
594 let rec intros_with_rewrite_aux : tactic =
595 fun g ->
596 match kind_of_term (pf_concl g) with
597 | Prod(_,t,t') ->
598 begin
599 match kind_of_term t with
600 | App(eq,args) when (eq_constr eq eq_ind) ->
601 if isVar args.(1)
602 then
603 let id = pf_get_new_id (id_of_string "y") g in
604 tclTHENSEQ [ h_intro id;
605 generalize_depedent_of (destVar args.(1)) id;
606 tclTRY (Equality.rewriteLR (mkVar id));
607 intros_with_rewrite
608 ]
609 g
610 else
611 begin
612 let id = pf_get_new_id (id_of_string "y") g in
613 tclTHENSEQ[
614 h_intro id;
615 tclTRY (Equality.rewriteLR (mkVar id));
616 intros_with_rewrite
617 ] g
618 end
619 | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
620 Tauto.tauto g
621 | Case(_,_,v,_) ->
622 tclTHENSEQ[
623 h_case (v,Rawterm.NoBindings);
624 intros_with_rewrite
625 ] g
626 | LetIn _ ->
627 tclTHENSEQ[
628 h_reduce
629 (Rawterm.Cbv
630 {Rawterm.all_flags
631 with Rawterm.rDelta = false;
632 })
633 onConcl
634 ;
635 intros_with_rewrite
636 ] g
637 | _ ->
638 let id = pf_get_new_id (id_of_string "y") g in
639 tclTHENSEQ [ h_intro id;intros_with_rewrite] g
640 end
641 | LetIn _ ->
642 tclTHENSEQ[
643 h_reduce
644 (Rawterm.Cbv
645 {Rawterm.all_flags
646 with Rawterm.rDelta = false;
647 })
648 onConcl
649 ;
650 intros_with_rewrite
651 ] g
652 | _ -> tclIDTAC g
653 and intros_with_rewrite g =
654 observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
655 in
656 (* The proof of each branche itself *)
657 let ind_number = ref 0 in
658 let min_constr_number = ref 0 in
659 let prove_branche i g =
660 (* we fist compute the inductive corresponding to the branch *)
661 let this_ind_number =
662 let constructor_num = i - !min_constr_number in
663 let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in
664 if constructor_num <= length
665 then !ind_number
666 else
667 begin
668 incr ind_number;
669 min_constr_number := !min_constr_number + length;
670 !ind_number
671 end
672 in
673 let this_branche_ids = List.nth intro_pats (pred i) in
674 tclTHENSEQ[
675 (* we expand the definition of the function *)
676 observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
677 (* introduce hypothesis with some rewrite *)
678 (intros_with_rewrite);
679 (* The proof is complete *)
680 observe_tac "reflexivity" (reflexivity)
681 ]
682 g
683 in
684 let params_names = fst (list_chop princ_infos.nparams args_names) in
685 let params = List.map mkVar params_names in
686 tclTHENSEQ
687 [ tclMAP h_intro (args_names@[res;hres]);
688 observe_tac "h_generalize"
689 (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
690 h_intro graph_principle_id;
691 observe_tac "" (tclTHEN_i
692 (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
693 (fun i g -> prove_branche i g ))
694 ]
695 g
696
697
698
699
700 let do_save () = Command.save_named false
701
702
703 (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
704 lemmas for each function in [funs] w.r.t. [graphs]
705
706 [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
707 [functional_induction] is Indfun.functional_induction (same pb)
708 *)
709
710 let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
711 let funs = Array.of_list funs and graphs = Array.of_list graphs in
712 let funs_constr = Array.map mkConst funs in
713 try
714 let graphs_constr = Array.map mkInd graphs in
715 let lemmas_types_infos =
716 Util.array_map2_i
717 (fun i f_constr graph ->
718 let const_of_f = destConst f_constr in
719 let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
720 generate_type false const_of_f graph i
721 in
722 let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
723 let type_of_lemma = nf_zeta type_of_lemma in
724 observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
725 type_of_lemma,type_info
726 )
727 funs_constr
728 graphs_constr
729 in
730 let schemes =
731 (* The functional induction schemes are computed and not saved if there is more that one function
732 if the block contains only one function we can safely reuse [f_rect]
733 *)
734 try
735 if Array.length funs_constr <> 1 then raise Not_found;
736 [| find_induction_principle funs_constr.(0) |]
737 with Not_found ->
738 Array.of_list
739 (List.map
740 (fun entry ->
741 (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type )
742 )
743 (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs))
744 )
745 in
746 let proving_tac =
747 prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
748 in
749 Array.iteri
750 (fun i f_as_constant ->
751 let f_id = id_of_label (con_label f_as_constant) in
752 Command.start_proof
753 (*i The next call to mk_correct_id is valid since we are constructing the lemma
754 Ensures by: obvious
755 i*)
756 (mk_correct_id f_id)
757 (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
758 (fst lemmas_types_infos.(i))
759 (fun _ _ -> ());
760 Pfedit.by (observe_tac ("procve correctness ("^(string_of_id f_id)^")") (proving_tac i));
761 do_save ();
762 let finfo = find_Function_infos f_as_constant in
763 update_Function
764 {finfo with
765 correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
766 }
767
768 )
769 funs;
770 let lemmas_types_infos =
771 Util.array_map2_i
772 (fun i f_constr graph ->
773 let const_of_f = destConst f_constr in
774 let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
775 generate_type true const_of_f graph i
776 in
777 let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
778 let type_of_lemma = nf_zeta type_of_lemma in
779 observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
780 type_of_lemma,type_info
781 )
782 funs_constr
783 graphs_constr
784 in
785 let kn,_ as graph_ind = destInd graphs_constr.(0) in
786 let mib,mip = Global.lookup_inductive graph_ind in
787 let schemes =
788 Array.of_list
789 (Indrec.build_mutual_indrec (Global.env ()) Evd.empty
790 (Array.to_list
791 (Array.mapi
792 (fun i mip -> (kn,i),mib,mip,true,InType)
793 mib.Declarations.mind_packets
794 )
795 )
796 )
797 in
798 let proving_tac =
799 prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
800 in
801 Array.iteri
802 (fun i f_as_constant ->
803 let f_id = id_of_label (con_label f_as_constant) in
804 Command.start_proof
805 (*i The next call to mk_complete_id is valid since we are constructing the lemma
806 Ensures by: obvious
807 i*)
808 (mk_complete_id f_id)
809 (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
810 (fst lemmas_types_infos.(i))
811 (fun _ _ -> ());
812 Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
813 do_save ();
814 let finfo = find_Function_infos f_as_constant in
815 update_Function
816 {finfo with
817 completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
818 }
819 )
820 funs;
821 with e ->
822 (* In case of problem, we reset all the lemmas *)
823 (*i The next call to mk_correct_id is valid since we are erasing the lemmas
824 Ensures by: obvious
825 i*)
826 let first_lemma_id =
827 let f_id = id_of_label (con_label funs.(0)) in
828
829 mk_correct_id f_id
830 in
831 ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
832 raise e
833
834
835
836
837
838 (***********************************************)
839
840 (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
841 when [kn] denotes a graph block into
842 f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result
843
844 if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
845 *)
846 let revert_graph kn post_tac hid g =
847 let typ = pf_type_of g (mkVar hid) in
848 match kind_of_term typ with
849 | App(i,args) when isInd i ->
850 let ((kn',num) as ind') = destInd i in
851 if kn = kn'
852 then (* We have generated a graph hypothesis so that we must change it if we can *)
853 let info =
854 try find_Function_of_graph ind'
855 with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
856 anomaly "Cannot retrieve infos about a mutual block"
857 in
858 (* if we can find a completeness lemma for this function
859 then we can come back to the functional form. If not, we do nothing
860 *)
861 match info.completeness_lemma with
862 | None -> tclIDTAC g
863 | Some f_complete ->
864 let f_args,res = array_chop (Array.length args - 1) args in
865 tclTHENSEQ
866 [
867 h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
868 thin [hid];
869 h_intro hid;
870 post_tac hid
871 ]
872 g
873
874 else tclIDTAC g
875 | _ -> tclIDTAC g
876
877
878 (*
879 [functional_inversion hid fconst f_correct ] is the functional version of [inversion]
880
881 [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct]
882 is the correctness lemma for [fconst].
883
884 The sketch is the follwing~:
885 \begin{enumerate}
886 \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$
887 (fails if it is not possible)
888 \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
889 \item apply [inversion] on [hid]
890 \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever
891 such a lemma exists)
892 \end{enumerate}
893 *)
894
895 let functional_inversion kn hid fconst f_correct : tactic =
31896 fun g ->
32 if nb_prod (pf_concl g) <= n then tac (List.rev acc) g
33 else
34 tclTHEN
35 intro
36 (fun g' ->
37 let id,_,t = pf_last_hyp g' in
38 tclORELSE
39 (tclABSTRACT None (Extratactics.h_discrHyp (Rawterm.NamedHyp id)))
40 (intro_discr_until ((id,t)::acc))
41 g'
42 )
43 g
897 let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in
898 let type_of_h = pf_type_of g (mkVar hid) in
899 match kind_of_term type_of_h with
900 | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
901 let pre_tac,f_args,res =
902 match kind_of_term args.(1),kind_of_term args.(2) with
903 | App(f,f_args),_ when eq_constr f fconst ->
904 ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
905 |_,App(f,f_args) when eq_constr f fconst ->
906 ((fun hid -> tclIDTAC),f_args,args.(1))
907 | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
908 in
909 tclTHENSEQ[
910 pre_tac hid;
911 h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
912 thin [hid];
913 h_intro hid;
914 Inv.inv FullInversion Genarg.IntroAnonymous (Rawterm.NamedHyp hid);
915 (fun g ->
916 let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
917 tclMAP (revert_graph kn pre_tac) (hid::new_ids) g
918 );
919 ] g
920 | _ -> tclFAIL 1 (mt ()) g
921
922
923
924 let invfun qhyp f =
925 let f =
926 match f with
927 | ConstRef f -> f
928 | _ -> raise (Util.UserError("",str "Not a function"))
44929 in
45 intro_discr_until []
46
47
48 let rec discr_rew_in_H hypname idl : tactic =
49 match idl with
50 | [] -> (Extratactics.h_discrHyp (Rawterm.NamedHyp hypname))
51 | ((id,t)::idl') ->
52 match kind_of_term t with
53 | App(eq',[| _ ; arg1 ; _ |]) when eq_constr eq' (Lazy.force eq) ->
54 begin
55 let constr,_ = decompose_app arg1 in
56 if isConstruct constr
57 then
58 (discr_rew_in_H hypname idl')
59 else
60 tclTHEN
61 (tclTRY (Equality.general_rewrite_in true hypname (mkVar id)))
62 (discr_rew_in_H hypname idl')
63 end
64 | _ -> discr_rew_in_H hypname idl'
65
66 let finalize fname hypname idl : tactic =
67 tclTRY (
68 (tclTHEN
69 (Hiddentac.h_reduce
70 (Rawterm.Unfold [[],EvalConstRef fname])
71 (Tacticals.onHyp hypname)
72 )
73 (discr_rew_in_H hypname idl)
74 ))
75
76 let gen_fargs fargs : tactic =
77 fun g ->
78 generalize
79 (List.map
80 (fun arg ->
81 let targ = pf_type_of g arg in
82 let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in
83 refl_arg
84 )
85 (Array.to_list fargs)
86 )
87 g
88
89
90 let invfun (hypname:identifier) fname princ : tactic=
91 fun g ->
92 let nprod_goal = nb_prod (pf_concl g) in
93 let princ_info =
94 let princ_type =
95 (try (match (Global.lookup_constant princ) with
96 {Declarations.const_type=t} -> t
97 )
98 with _ -> assert false)
99 in
100 Tactics.compute_elim_sig princ_type
101 in
102 let _,_,typhyp = List.find (fun (id,_,_) -> hypname=id) (pf_hyps g) in
103 let do_invert fargs appf : tactic =
104 let frealargs = (snd (array_chop (List.length princ_info.params) fargs))
105 in
106 let pat_args =
107 (List.map (fun e -> ([Rawterm.ArgArg (-1)],e)) (Array.to_list frealargs)) @ [[],appf]
108 in
109 tclTHENSEQ
110 [
111 gen_fargs frealargs;
112 tac_pattern pat_args;
113 Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings);
114 intro_discr_until nprod_goal (finalize fname hypname)
115
116 ]
117 in
118 match kind_of_term typhyp with
119 | App(eq',[| _ ; arg1 ; arg2 |]) when eq_constr eq' (Lazy.force eq) ->
120 (* let valf = def_of_const (mkConst fname) in *)
121 let eq_arg1 , eq_arg2 , good_eq_form , fargs =
122 match kind_of_term arg1 , kind_of_term arg2 with
123 | App(f, args),_ when eq_constr f (mkConst fname) ->
124 arg1 , arg2 , tclIDTAC , args
125 | _,App(f, args) when eq_constr f (mkConst fname) ->
126 arg2 , arg1 , symmetry_in hypname , args
127 | _ , _ -> error "inversion impossible"
128 in
129 tclTHEN
130 good_eq_form
131 (do_invert fargs eq_arg1)
132 g
133 | App(f',fargs) when eq_constr f' (mkConst fname) ->
134 do_invert fargs typhyp g
135
136
137 | _ -> error "inversion impossible"
138
930 try
931 let finfos = find_Function_infos f in
932 let f_correct = mkConst(out_some finfos.correctness_lemma)
933 and kn = fst finfos.graph_ind
934 in
935 Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp
936 with
937 | Not_found -> error "No graph found"
938 | Failure "out_some" -> error "Cannot use equivalence with graph!"
939
940
941 let invfun qhyp f g =
942 match f with
943 | Some f -> invfun qhyp f g
944 | None ->
945 Tactics.try_intros_until
946 (fun hid g ->
947 let hyp_typ = pf_type_of g (mkVar hid) in
948 match kind_of_term hyp_typ with
949 | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
950 begin
951 let f1,_ = decompose_app args.(1) in
952 try
953 if not (isConst f1) then failwith "";
954 let finfos = find_Function_infos (destConst f1) in
955 let f_correct = mkConst(out_some finfos.correctness_lemma)
956 and kn = fst finfos.graph_ind
957 in
958 functional_inversion kn hid f1 f_correct g
959 with | Failure "" | Failure "out_some" | Not_found ->
960 try
961 let f2,_ = decompose_app args.(2) in
962 if not (isConst f2) then failwith "";
963 let finfos = find_Function_infos (destConst f2) in
964 let f_correct = mkConst(out_some finfos.correctness_lemma)
965 and kn = fst finfos.graph_ind
966 in
967 functional_inversion kn hid f2 f_correct g
968 with
969 | Failure "" ->
970 errorlabstrm "" (Ppconstr.pr_id hid ++ str " must contain at leat one function")
971 | Failure "out_some" ->
972 error "Cannot use equivalence with graph for any side of equality"
973 | Not_found -> error "No graph found for any side of equality"
974 end
975 | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
976 )
977 qhyp
978 g
+477
-295
contrib/funind/rawterm_to_relation.ml less more
88 open Rawtermops
99
1010 let observe strm =
11 if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false
11 if do_observe ()
1212 then Pp.msgnl strm
1313 else ()
1414 let observennl strm =
15 if Tacinterp.get_debug () <> Tactic_debug.DebugOff &&false
15 if do_observe ()
1616 then Pp.msg strm
1717 else ()
1818
4343 (*
4444 The main part deals with building a list of raw constructor expressions
4545 from the rhs of a fixpoint equation.
46
47
4846 *)
49
50
5147
5248 type 'a build_entry_pre_return =
5349 {
6056 result : 'a build_entry_pre_return list;
6157 to_avoid : identifier list
6258 }
63
6459
6560 (*
6661 [combine_results combine_fun res1 res2] combine two results [res1] and [res2]
112107 let ids_of_binder = function
113108 | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
114109 | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id]
115 (* | LetTuple(nal,_) -> *)
116 (* map_succeed (function Name id -> id | _ -> failwith "ids_of_binder") nal *)
117110
118111 let rec change_vars_in_binder mapping = function
119112 [] -> []
215208 (* Note that the binding context of [args] MUST be placed before the one of
216209 the applied value in order to preserve possible type dependencies
217210 *)
218
219211 context = args.context@new_ctxt;
220212 value = new_value;
221213 }
244236 ;
245237 to_avoid = avoid
246238 }
247
248
239 (*************************************************
240 Some functions to deal with overlapping patterns
241 **************************************************)
242
243 let coq_True_ref =
244 lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True")
245
246 let coq_False_ref =
247 lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False")
248
249 (*
250 [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
251 (the list of expresions on which we will do the matching)
252 *)
249253 let make_discr_match_el =
250254 List.map (fun e -> (e,(Anonymous,None)))
251255
252 let coq_True_ref =
253 lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True")
254
255 let coq_False_ref =
256 lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False")
257
256 (*
257 [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression.
258 that is.
259 match ?????? with \\
260 | pat_1 => False \\
261 | pat_{i-1} => False \\
262 | pat_i => True \\
263 | pat_{i+1} => False \\
264 \vdots
265 | pat_n => False
266 end
267 *)
258268 let make_discr_match_brl i =
259269 list_map_i
260270 (fun j (_,idl,patl,_) ->
263273 else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
264274 )
265275 0
266
276 (*
277 [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff
278 brl_{i} is the first branch matched by [el]
279
280 Used when we want to simulate the coq pattern matching algorithm
281 *)
267282 let make_discr_match brl =
268283 fun el i ->
269284 mkRCases(None,
270285 make_discr_match_el el,
271286 make_discr_match_brl i brl)
272
273
274
275 let rec make_pattern_eq_precond id e pat : identifier * (binder_type * Rawterm.rawconstr) list =
276 match pat with
277 | PatVar(_,Anonymous) -> assert false
278 | PatVar(_,Name x) ->
279 id,[Prod (Name x),mkRHole ();Prod Anonymous,raw_make_eq (mkRVar x) e]
280 | PatCstr(_,constr,patternl,_) ->
281 let new_id,new_patternl,patternl_eq_precond =
282 List.fold_right
283 (fun pat' (id,new_patternl,preconds) ->
284 match pat' with
285 | PatVar (_,Name id) -> (id,id::new_patternl,preconds)
286 | _ ->
287 let new_id = Nameops.lift_ident id in
288 let new_id',pat'_precond =
289 make_pattern_eq_precond new_id (mkRVar id) pat'
290 in
291 (new_id',id::new_patternl,preconds@pat'_precond)
292 )
293 patternl
294 (id,[],[])
295 in
296 let cst_narg =
297 Inductiveops.mis_constructor_nargs_env
298 (Global.env ())
299 constr
300 in
301 let implicit_args =
302 Array.to_list
303 (Array.init
304 (cst_narg - List.length patternl)
305 (fun _ -> mkRHole ())
306 )
307 in
308 let cst_as_term =
309 mkRApp(mkRRef(Libnames.ConstructRef constr),
310 implicit_args@(List.map mkRVar new_patternl)
311 )
312 in
313 let precond' =
314 (Prod Anonymous, raw_make_eq cst_as_term e)::patternl_eq_precond
315 in
316 let precond'' =
317 List.fold_right
318 (fun id acc ->
319 (Prod (Name id),(mkRHole ()))::acc
320 )
321 new_patternl
322 precond'
323 in
324 new_id,precond''
325287
326288 let pr_name = function
327289 | Name id -> Ppconstr.pr_id id
328290 | Anonymous -> str "_"
329291
330 let make_pattern_eq_precond id e pat =
331 let res = make_pattern_eq_precond id e pat in
332 observe
333 (prlist_with_sep spc
334 (function (Prod na,t) ->
335 str "forall " ++ pr_name na ++ str ":" ++ pr_rawconstr t
336 | _ -> assert false
337 )
338 (snd res)
339 );
340 res
341
342
343 let build_constructors_of_type msg ind' argl =
292 (**********************************************************************)
293 (* functions used to build case expression from lettuple and if ones *)
294 (**********************************************************************)
295
296 (* [build_constructors_of_type] construct the array of pattern of its inductive argument*)
297 let build_constructors_of_type ind' argl =
344298 let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
345299 let npar = mib.Declarations.mind_nparams in
346300 Array.mapi (fun i _ ->
365319 let pat_as_term =
366320 mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
367321 in
368 (* Pp.msgnl (str "new constructor := " ++ Printer.pr_rawconstr pat_as_term); *)
369322 cases_pattern_of_rawconstr Anonymous pat_as_term
370323 )
371324 ind.Declarations.mind_consnames
372325
373 let find_constructors_of_raw_type msg t argl : Rawterm.cases_pattern array =
374 let ind,args = raw_decompose_app t in
375 match ind with
376 | RRef(_,IndRef ind') ->
377 (* let _,ind = Global.lookup_inductive ind' in *)
378 build_constructors_of_type msg ind' argl
379 | _ -> error msg
380
381
382
326 (* [find_type_of] very naive attempts to discover the type of an if or a letin *)
383327 let rec find_type_of nb b =
384328 let f,_ = raw_decompose_app b in
385329 match f with
411355 | _ -> raise (Invalid_argument "not a ref")
412356
413357
414 let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return =
415 (* Pp.msgnl (str " Entering : " ++ Printer.pr_rawconstr rt); *)
358
359
360 (******************)
361 (* Main functions *)
362 (******************)
363
364
365
366 let raw_push_named (na,raw_value,raw_typ) env =
367 match na with
368 | Anonymous -> env
369 | Name id ->
370 let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in
371 let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
372 Environ.push_named (id,value,typ) env
373
374
375 let add_pat_variables pat typ env : Environ.env =
376 let rec add_pat_variables env pat typ : Environ.env =
377 observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
378
379 match pat with
380 | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
381 | PatCstr(_,c,patl,na) ->
382 let Inductiveops.IndType(indf,indargs) =
383 try Inductiveops.find_rectype env Evd.empty typ
384 with Not_found -> assert false
385 in
386 let constructors = Inductiveops.get_constructors env indf in
387 let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
388 let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
389 List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
390 in
391 let new_env = add_pat_variables env pat typ in
392 let res =
393 fst (
394 Sign.fold_rel_context
395 (fun (na,v,t) (env,ctxt) ->
396 match na with
397 | Anonymous -> assert false
398 | Name id ->
399 let new_t = substl ctxt t in
400 let new_v = option_map (substl ctxt) v in
401 observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++
402 str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++
403 str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++
404 option_fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
405 option_fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
406 );
407 (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
408 )
409 (Environ.rel_context new_env)
410 ~init:(env,[])
411 )
412 in
413 observe (str "new var env := " ++ Printer.pr_named_context_of res);
414 res
415
416
417
418
419 let rec pattern_to_term_and_type env typ = function
420 | PatVar(loc,Anonymous) -> assert false
421 | PatVar(loc,Name id) ->
422 mkRVar id
423 | PatCstr(loc,constr,patternl,_) ->
424 let cst_narg =
425 Inductiveops.mis_constructor_nargs_env
426 (Global.env ())
427 constr
428 in
429 let Inductiveops.IndType(indf,indargs) =
430 try Inductiveops.find_rectype env Evd.empty typ
431 with Not_found -> assert false
432 in
433 let constructors = Inductiveops.get_constructors env indf in
434 let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
435 let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
436 let _,cstl = Inductiveops.dest_ind_family indf in
437 let csta = Array.of_list cstl in
438 let implicit_args =
439 Array.to_list
440 (Array.init
441 (cst_narg - List.length patternl)
442 (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
443 )
444 in
445 let patl_as_term =
446 List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl
447 in
448 mkRApp(mkRRef(Libnames.ConstructRef constr),
449 implicit_args@patl_as_term
450 )
451
452 (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
453 of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
454 corresponding graphs.
455
456
457 The idea to transform a term [t] into a list of constructors [lc] is the following:
458 \begin{itemize}
459 \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding
460 to [body] and add (bind x. _) to each elements of [lc]
461 \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames)
462 then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
463 then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn],
464 [g c1 ... cn] is an element of [lc]
465 \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then
466 compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
467 then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
468 create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
469 \item if the term is a cast just treat its body part
470 \item
471 if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case
472 and concatenate them (informally, each branch of a match produces a new constructor)
473 \end{itemize}
474
475 WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
476 We must wait to have complete all the current calculi to set the recursive calls.
477 At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by
478 a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
479 We in fact not create a constructor list since then end of each constructor has not the expected form
480 but only the value of the function
481 *)
482
483
484 let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
485 observe (str " Entering : " ++ Printer.pr_rawconstr rt);
416486 match rt with
417487 | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ ->
418 mk_result [] rt avoid
488 (* do nothing (except changing type of course) *)
489 mk_result [] rt avoid
419490 | RApp(_,_,_) ->
420491 let f,args = raw_decompose_app rt in
421492 let args_res : (rawconstr list) build_entry_return =
422 List.fold_right
493 List.fold_right (* create the arguments lists of constructors and combine them *)
423494 (fun arg ctxt_argsl ->
424 let arg_res = build_entry_lc funnames ctxt_argsl.to_avoid arg in
425 combine_results combine_args arg_res ctxt_argsl
495 let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
496 combine_results combine_args arg_res ctxt_argsl
426497 )
427498 args
428499 (mk_result [] [] avoid)
430501 begin
431502 match f with
432503 | RVar(_,id) when Idset.mem id funnames ->
504 (* if we have [f t1 ... tn] with [f]$\in$[fnames]
505 then we create a fresh variable [res],
506 add [res] and its "value" (i.e. [res v1 ... vn]) to each
507 pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and
508 a pseudo value "v1 ... vn".
509 The "value" of this branch is then simply [res]
510 *)
511 let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
512 let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
513 let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
433514 let res = fresh_id args_res.to_avoid "res" in
434515 let new_avoid = res::args_res.to_avoid in
435516 let res_rt = mkRVar res in
437518 List.map
438519 (fun arg_res ->
439520 let new_hyps =
440 [Prod (Name res),mkRHole ();
521 [Prod (Name res),res_raw_type;
441522 Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
442523 in
443524 {context = arg_res.context@new_hyps; value = res_rt }
446527 in
447528 { result = new_result; to_avoid = new_avoid }
448529 | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
530 (* if have [g t1 ... tn] with [g] not appearing in [funnames]
531 then
532 foreach [ctxt,v1 ... vn] in [args_res] we return
533 [ctxt, g v1 .... vn]
534 *)
449535 {
450536 args_res with
451537 result =
454540 {args_res with value = mkRApp(f,args_res.value)})
455541 args_res.result
456542 }
457 | RApp _ -> assert false (* we have collected all the app *)
543 | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
458544 | RLetIn(_,n,t,b) ->
545 (* if we have [(let x := v in b) t1 ... tn] ,
546 we discard our work and compute the list of constructor for
547 [let x = v in (b t1 ... tn)] up to alpha conversion
548 *)
459549 let new_n,new_b,new_avoid =
460550 match n with
461551 | Name id when List.exists (is_free_in id) args ->
472562 | _ -> n,b,avoid
473563 in
474564 build_entry_lc
565 env
475566 funnames
476567 avoid
477568 (mkRLetIn(new_n,t,mkRApp(new_b,args)))
478569 | RCases _ | RLambda _ | RIf _ | RLetTuple _ ->
479 let f_res = build_entry_lc funnames args_res.to_avoid f in
570 (* we have [(match e1, ...., en with ..... end) t1 tn]
571 we first compute the result from the case and
572 then combine each of them with each of args one
573 *)
574 let f_res = build_entry_lc env funnames args_res.to_avoid f in
480575 combine_results combine_app f_res args_res
481 | RDynamic _ ->error "Not handled RDynamic"
576 | RDynamic _ ->error "Not handled RDynamic"
482577 | RCast(_,b,_,_) ->
483 build_entry_lc funnames avoid (mkRApp(b,args))
578 (* for an applied cast we just trash the cast part
579 and restart the work.
580
581 WARNING: We need to restart since [b] itself should be an application term
582 *)
583 build_entry_lc env funnames avoid (mkRApp(b,args))
484584 | RRec _ -> error "Not handled RRec"
485585 | RProd _ -> error "Cannot apply a type"
486 end
586 end (* end of the application treatement *)
587
487588 | RLambda(_,n,t,b) ->
488 let b_res = build_entry_lc funnames avoid b in
489 let t_res = build_entry_lc funnames avoid t in
589 (* we first compute the list of constructor
590 corresponding to the body of the function,
591 then the one corresponding to the type
592 and combine the two result
593 *)
594 let t_res = build_entry_lc env funnames avoid t in
490595 let new_n =
491596 match n with
492597 | Name _ -> n
493598 | Anonymous -> Name (Indfun_common.fresh_id [] "_x")
494599 in
600 let new_env = raw_push_named (new_n,None,t) env in
601 let b_res = build_entry_lc new_env funnames avoid b in
495602 combine_results (combine_lam new_n) t_res b_res
496603 | RProd(_,n,t,b) ->
497 let b_res = build_entry_lc funnames avoid b in
498 let t_res = build_entry_lc funnames avoid t in
604 (* we first compute the list of constructor
605 corresponding to the body of the function,
606 then the one corresponding to the type
607 and combine the two result
608 *)
609 let t_res = build_entry_lc env funnames avoid t in
610 let new_env = raw_push_named (n,None,t) env in
611 let b_res = build_entry_lc new_env funnames avoid b in
499612 combine_results (combine_prod n) t_res b_res
500 | RLetIn(_,n,t,b) ->
501 let b_res = build_entry_lc funnames avoid b in
502 let t_res = build_entry_lc funnames avoid t in
503 combine_results (combine_letin n) t_res b_res
613 | RLetIn(_,n,v,b) ->
614 (* we first compute the list of constructor
615 corresponding to the body of the function,
616 then the one corresponding to the value [t]
617 and combine the two result
618 *)
619 let v_res = build_entry_lc env funnames avoid v in
620 let v_as_constr = Pretyping.Default.understand Evd.empty env v in
621 let v_type = Typing.type_of env Evd.empty v_as_constr in
622 let new_env =
623 match n with
624 Anonymous -> env
625 | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
626 in
627 let b_res = build_entry_lc new_env funnames avoid b in
628 combine_results (combine_letin n) v_res b_res
504629 | RCases(_,_,el,brl) ->
630 (* we create the discrimination function
631 and treat the case itself
632 *)
505633 let make_discr = make_discr_match brl in
506 build_entry_lc_from_case funnames make_discr el brl avoid
634 build_entry_lc_from_case env funnames make_discr el brl avoid
507635 | RIf(_,b,(na,e_option),lhs,rhs) ->
636 let b_as_constr = Pretyping.Default.understand Evd.empty env b in
637 let b_typ = Typing.type_of env Evd.empty b_as_constr in
638 let (ind,_) =
639 try Inductiveops.find_inductive env Evd.empty b_typ
640 with Not_found ->
641 errorlabstrm "" (str "Cannot find the inductive associated to " ++
642 Printer.pr_rawconstr b ++ str " in " ++
643 Printer.pr_rawconstr rt ++ str ". try again with a cast")
644 in
645 let case_pats = build_constructors_of_type ind [] in
646 assert (Array.length case_pats = 2);
647 let brl =
648 list_map_i
649 (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
650 0
651 [lhs;rhs]
652 in
653 let match_expr =
654 mkRCases(None,[(b,(Anonymous,None))],brl)
655 in
656 (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
657 build_entry_lc env funnames avoid match_expr
658 | RLetTuple(_,nal,_,b,e) ->
508659 begin
509 match b with
510 | RCast(_,b,_,t) ->
511 let msg = "If construction must be used with cast" in
512 let case_pat = find_constructors_of_raw_type msg t [] in
513 assert (Array.length case_pat = 2);
514 let brl =
515 list_map_i
516 (fun i x -> (dummy_loc,[],[case_pat.(i)],x))
517 0
518 [lhs;rhs]
519 in
520 let match_expr =
521 mkRCases(None,[(b,(Anonymous,None))],brl)
522 in
523 (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
524 build_entry_lc funnames avoid match_expr
525 | _ ->
526 try
527 let ind = find_type_of 2 b in
528 let case_pat = build_constructors_of_type (str "") ind [] in
529 let brl =
530 list_map_i
531 (fun i x -> (dummy_loc,[],[case_pat.(i)],x))
532 0
533 [lhs;rhs]
534 in
535 let match_expr =
536 mkRCases(None,[(b,(Anonymous,None))],brl)
537 in
538 (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
539 build_entry_lc funnames avoid match_expr
540 with Invalid_argument s ->
541 let msg = "If construction must be used with cast : "^ s in
542 error msg
543
544 end
545 | RLetTuple(_,nal,_,b,e) ->
546 begin
547 let nal_as_rawconstr =
548 List.map
549 (function
550 Name id -> mkRVar id
660 let nal_as_rawconstr =
661 List.map
662 (function
663 Name id -> mkRVar id
551664 | Anonymous -> mkRHole ()
552665 )
553 nal
666 nal
554667 in
555 match b with
556 | RCast(_,b,_,t) ->
557 let case_pat =
558 find_constructors_of_raw_type
559 "LetTuple construction must be used with cast" t nal_as_rawconstr in
560 assert (Array.length case_pat = 1);
561 let br =
562 (dummy_loc,[],[case_pat.(0)],e)
563 in
564 let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
565 build_entry_lc funnames avoid match_expr
566 | _ ->
567 try
568 let ind = find_type_of 1 b in
569 let case_pat =
570 build_constructors_of_type
571 (str "LetTuple construction must be used with cast") ind nal_as_rawconstr in
572 let br =
573 (dummy_loc,[],[case_pat.(0)],e)
574 in
575 let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
576 build_entry_lc funnames avoid match_expr
577 with Invalid_argument s ->
578 let msg = "LetTuple construction must be used with cast : "^ s in
579 error msg
580
668 let b_as_constr = Pretyping.Default.understand Evd.empty env b in
669 let b_typ = Typing.type_of env Evd.empty b_as_constr in
670 let (ind,_) =
671 try Inductiveops.find_inductive env Evd.empty b_typ
672 with Not_found ->
673 errorlabstrm "" (str "Cannot find the inductive associated to " ++
674 Printer.pr_rawconstr b ++ str " in " ++
675 Printer.pr_rawconstr rt ++ str ". try again with a cast")
676 in
677 let case_pats = build_constructors_of_type ind nal_as_rawconstr in
678 assert (Array.length case_pats = 1);
679 let br =
680 (dummy_loc,[],[case_pats.(0)],e)
681 in
682 let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
683 build_entry_lc env funnames avoid match_expr
684
581685 end
582686 | RRec _ -> error "Not handled RRec"
583687 | RCast(_,b,_,_) ->
584 build_entry_lc funnames avoid b
688 build_entry_lc env funnames avoid b
585689 | RDynamic _ -> error "Not handled RDynamic"
586 and build_entry_lc_from_case funname make_discr
690 and build_entry_lc_from_case env funname make_discr
587691 (el:tomatch_tuple)
588692 (brl:Rawterm.cases_clauses) avoid :
589693 rawconstr build_entry_return =
590694 match el with
591 | [] -> assert false (* matched on Nothing !*)
695 | [] -> assert false (* this case correspond to match <nothing> with .... !*)
592696 | el ->
697 (* this case correspond to
698 match el with brl end
699 we first compute the list of lists corresponding to [el] and
700 combine them .
701 Then for each elemeent of the combinations,
702 we compute the result we compute one list per branch in [brl] and
703 finally we just concatenate those list
704 *)
593705 let case_resl =
594706 List.fold_right
595707 (fun (case_arg,_) ctxt_argsl ->
596 let arg_res = build_entry_lc funname avoid case_arg in
708 let arg_res = build_entry_lc env funname avoid case_arg in
597709 combine_results combine_args arg_res ctxt_argsl
598710 )
599711 el
600712 (mk_result [] [] avoid)
601713 in
714 (****** The next works only if the match is not dependent ****)
715 let types =
716 List.map (fun (case_arg,_) ->
717 let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
718 Typing.type_of env Evd.empty case_arg_as_constr
719 ) el
720 in
602721 let results =
603722 List.map
604 (build_entry_lc_from_case_term funname (make_discr (List.map fst el)) [] brl case_resl.to_avoid)
723 (build_entry_lc_from_case_term
724 env types
725 funname (make_discr (* (List.map fst el) *))
726 [] brl
727 case_resl.to_avoid)
605728 case_resl.result
606729 in
607730 {
610733 List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
611734 }
612735
613 and build_entry_lc_from_case_term funname make_discr patterns_to_prevent brl avoid
736 and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
614737 matched_expr =
615738 match brl with
616739 | [] -> (* computed_branches *) {result = [];to_avoid = avoid}
617740 | br::brl' ->
741 (* alpha convertion to prevent name clashes *)
618742 let _,idl,patl,return = alpha_br avoid br in
619 let new_avoid = idl@avoid in
620 (* let e_ctxt,el = (matched_expr.context,matched_expr.value) in *)
621 (* if (List.length patl) <> (List.length el) *)
622 (* then error ("Pattern matching on product: not yet implemented"); *)
743 let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *)
744 (* building a list of precondition stating that we are not in this branch
745 (will be used in the following recursive calls)
746 *)
747 let new_env = List.fold_right2 add_pat_variables patl types env in
623748 let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
624 List.map
625 (fun pat ->
749 List.map2
750 (fun pat typ ->
626751 fun avoid pat'_as_term ->
627752 let renamed_pat,_,_ = alpha_pat avoid pat in
628753 let pat_ids = get_pattern_id renamed_pat in
629 List.fold_right
630 (fun id acc -> mkRProd (Name id,mkRHole (),acc))
754 let env_with_pat_ids = add_pat_variables pat typ new_env in
755 List.fold_right
756 (fun id acc ->
757 let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in
758 let raw_typ_of_id =
759 Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
760 in
761 mkRProd (Name id,raw_typ_of_id,acc))
631762 pat_ids
632763 (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
633764 )
634765 patl
635 in
766 types
767 in
768 (* Checking if we can be in this branch
769 (will be used in the following recursive calls)
770 *)
636771 let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
637772 List.map
638773 (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat')
639774 patl
640775 in
776 (*
777 we first compute the other branch result (in ordrer to keep the order of the matching
778 as much as possible)
779 *)
641780 let brl'_res =
642781 build_entry_lc_from_case_term
782 env
783 types
643784 funname
644785 make_discr
645786 ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent)
647788 avoid
648789 matched_expr
649790 in
791 (* We know create the precondition of this branch i.e.
792
793 1- the list of variable appearing in the different patterns of this branch and
794 the list of equation stating than el = patl (List.flatten ...)
795 2- If there exists a previous branch which pattern unify with the one of this branch
796 then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
797 *)
650798 let those_pattern_preconds =
651 ( List.flatten
799 (List.flatten
652800 (
653 List.map2
654 (fun pat e ->
801 list_map3
802 (fun pat e typ_as_constr ->
655803 let this_pat_ids = ids_of_pat pat in
804 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
656805 let pat_as_term = pattern_to_term pat in
657806 List.fold_right
658807 (fun id acc ->
659808 if Idset.mem id this_pat_ids
660 then (Prod (Name id),mkRHole ())::acc
809 then (Prod (Name id),
810 let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
811 let raw_typ_of_id =
812 Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
813 in
814 raw_typ_of_id
815 )::acc
661816 else acc
662817
663818 )
664819 idl
665 [(Prod Anonymous,raw_make_eq pat_as_term e)]
820 [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
666821 )
667822 patl
668823 matched_expr.value
824 types
669825 )
670 )
826 )
671827 @
672 (if List.exists (function (unifl,neql) ->
673 let (unif,eqs) =
674 List.split (List.map2 (fun x y -> x y) unifl patl)
675 in
676 List.for_all (fun x -> x) unif) patterns_to_prevent
677 then
678 let i = List.length patterns_to_prevent in
679 [(Prod Anonymous,make_discr i )]
680 else
681 []
682 )
683 in
684 let return_res = build_entry_lc funname new_avoid return in
828 (if List.exists (function (unifl,_) ->
829 let (unif,_) =
830 List.split (List.map2 (fun x y -> x y) unifl patl)
831 in
832 List.for_all (fun x -> x) unif) patterns_to_prevent
833 then
834 let i = List.length patterns_to_prevent in
835 let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
836 [(Prod Anonymous,make_discr pats_as_constr i )]
837 else
838 []
839 )
840 in
841 (* We compute the result of the value returned by the branch*)
842 let return_res = build_entry_lc new_env funname new_avoid return in
843 (* and combine it with the preconds computed for this branch *)
685844 let this_branch_res =
686845 List.map
687846 (fun res ->
688 { context =
689 matched_expr.context@
690 (* ids@ *)
691 those_pattern_preconds@res.context ;
847 { context = matched_expr.context@those_pattern_preconds@res.context ;
692848 value = res.value}
693849 )
694850 return_res.result
701857 String.sub (string_of_id id) 0 3 = "res"
702858 with Invalid_argument _ -> false
703859
704 (* rebuild the raw constructors expression.
860 (*
861 The second phase which reconstruct the real type of the constructor.
862 rebuild the raw constructors expression.
705863 eliminates some meaningless equalities, applies some rewrites......
706864 *)
707865 let rec rebuild_cons nb_args relname args crossed_types depth rt =
721879 args new_crossed_types
722880 (depth + 1) b
723881 in
882 (*i The next call to mk_rel_id is valid since we are constructing the graph
883 Ensures by: obvious
884 i*)
885
724886 let new_t =
725887 mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
726888 in mkRProd(n,new_t,new_b),
729891 assert false
730892 end
731893 | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt])
732 when eq_as_ref = Lazy.force Coqlib.coq_eq_ref
894 when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous
733895 ->
734896 let is_in_b = is_free_in id b in
735897 let _keep_eq =
747909 (depth + 1) subst_b
748910 in
749911 mkRProd(n,t,new_b),id_to_exclude
750 (* if keep_eq then *)
751 (* mkRProd(n,t,new_b),id_to_exclude *)
752 (* else new_b, Idset.add id id_to_exclude *)
912 (* J.F:. keep this comment it explain how to remove some meaningless equalities
913 if keep_eq then
914 mkRProd(n,t,new_b),id_to_exclude
915 else new_b, Idset.add id id_to_exclude
916 *)
753917 | _ ->
754918 let new_b,id_to_exclude =
755919 rebuild_cons
765929 end
766930 | RLambda(_,n,t,b) ->
767931 begin
768 (* let not_free_in_t id = not (is_free_in id t) in *)
769 (* let new_crossed_types = t :: crossed_types in *)
770 (* let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types b in *)
771 (* match n with *)
772 (* | Name id when Idset.mem id id_to_exclude -> *)
773 (* new_b, *)
774 (* Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
775 (* | _ -> *)
776 (* RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude *)
777932 let not_free_in_t id = not (is_free_in id t) in
778933 let new_crossed_types = t :: crossed_types in
779 (* let new_b,id_to_exclude = rebuild_cons relname (args new_crossed_types b in *)
780934 match n with
781935 | Name id ->
782936 let new_b,id_to_exclude =
837991 | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty
838992
839993
994 (* debuging wrapper *)
840995 let rebuild_cons nb_args relname args crossed_types rt =
841 observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++
842 str "nb_args := " ++ str (string_of_int nb_args));
996 (* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *)
997 (* str "nb_args := " ++ str (string_of_int nb_args)); *)
843998 let res =
844999 rebuild_cons nb_args relname args crossed_types 0 rt
8451000 in
846 observe (str " leads to "++ pr_rawconstr (fst res));
1001 (* observe (str " leads to "++ pr_rawconstr (fst res)); *)
8471002 res
8481003
1004
1005 (* naive implementation of parameter detection.
1006
1007 A parameter is an argument which is only preceded by parameters and whose
1008 calls are all syntaxically equal.
1009
1010 TODO: Find a valid way to deal with implicit arguments here!
1011 *)
8491012 let rec compute_cst_params relnames params = function
8501013 | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
8511014 | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
8991062 in
9001063 List.rev !l
9011064
902 (* (Topconstr.CProdN
903 (dummy_loc,
904 [[(dummy_loc,Anonymous)],returned_types.(i)],
905 Topconstr.CSort(dummy_loc, RProp Null )
906 )
907 )
908 *)
9091065 let rec rebuild_return_type rt =
9101066 match rt with
9111067 | Topconstr.CProdN(loc,n,t') ->
9141070 Topconstr.CArrow(loc,t,rebuild_return_type t')
9151071 | Topconstr.CLetIn(loc,na,t,t') ->
9161072 Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
917 | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc, RProp Null))
918
919
920 let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) returned_types (rtl:rawconstr list) =
1073 | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
1074
1075
1076 let build_inductive
1077 parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list)
1078 returned_types
1079 (rtl:rawconstr list) =
9211080 let _time1 = System.get_time () in
9221081 (* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
9231082 let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
9241083 let funnames = Array.of_list funnames in
9251084 let funsargs = Array.of_list funsargs in
9261085 let returned_types = Array.of_list returned_types in
1086 (* alpha_renaming of the body to prevent variable capture during manipulation *)
9271087 let rtl_alpha = List.map (function rt -> (alpha_rt [] rt) ) rtl in
9281088 let rta = Array.of_list rtl_alpha in
1089 (*i The next call to mk_rel_id is valid since we are constructing the graph
1090 Ensures by: obvious
1091 i*)
9291092 let relnames = Array.map mk_rel_id funnames in
9301093 let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
931 let resa = Array.map (build_entry_lc funnames_as_set []) rta in
1094 (* Construction of the pseudo constructors *)
1095 let env =
1096 Array.fold_right
1097 (fun id env ->
1098 Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env
1099 )
1100 funnames
1101 (Global.env ())
1102 in
1103 let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
1104 (* and of the real constructors*)
9321105 let constr i res =
9331106 List.map
9341107 (function result (* (args',concl') *) ->
9351108 let rt = compose_raw_context result.context result.value in
9361109 let nb_args = List.length funsargs.(i) in
937 (* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *)
1110 (* let old_implicit_args = Impargs.is_implicit_args () *)
1111 (* and old_strict_implicit_args = Impargs.is_strict_implicit_args () *)
1112 (* and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in *)
1113 (* let old_rawprint = !Options.raw_print in *)
1114 (* Options.raw_print := true; *)
1115 (* Impargs.make_implicit_args false; *)
1116 (* Impargs.make_strict_implicit_args false; *)
1117 (* Impargs.make_contextual_implicit_args false; *)
1118 (* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *)
1119 (* Impargs.make_implicit_args old_implicit_args; *)
1120 (* Impargs.make_strict_implicit_args old_strict_implicit_args; *)
1121 (* Impargs.make_contextual_implicit_args old_contextual_implicit_args; *)
1122 (* Options.raw_print := old_rawprint; *)
9381123 fst (
9391124 rebuild_cons nb_args relnames.(i)
940 (* (List.map *)
941 (* (function *)
942 (* (Anonymous,_,_) -> mkRVar(fresh_id res.to_avoid "x__") *)
943 (* | Name id, _,_ -> mkRVar id *)
944 (* ) *)
945 (* funsargs.(i) *)
946 (* ) *)
9471125 []
9481126 []
9491127 rt
9511129 )
9521130 res.result
9531131 in
954 let next_constructor_id = ref (-1) in
1132 (* adding names to constructors *)
1133 let next_constructor_id = ref (-1) in
9551134 let mk_constructor_id i =
9561135 incr next_constructor_id;
1136 (*i The next call to mk_rel_id is valid since we are constructing the graph
1137 Ensures by: obvious
1138 i*)
9571139 id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
9581140 in
9591141 let rel_constructors i rt : (identifier*rawconstr) list =
1142 next_constructor_id := (-1);
9601143 List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
9611144 in
9621145 let rel_constructors = Array.mapi rel_constructors resa in
1146 (* Computing the set of parameters if asked *)
9631147 let rels_params =
9641148 if parametrize
9651149 then
9671151 else []
9681152 in
9691153 let nrel_params = List.length rels_params in
970 let rel_constructors =
1154 let rel_constructors = (* Taking into account the parameters in constructors *)
9711155 Array.map (List.map
9721156 (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
9731157 rel_constructors
9741158 in
975 let rel_arity i funargs =
1159 let rel_arity i funargs = (* Reduilding arities (with parameters) *)
9761160 let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
9771161 (snd (list_chop nrel_params funargs))
9781162 in
9911175 )
9921176 rel_first_args
9931177 (rebuild_return_type returned_types.(i))
994 (* (Topconstr.CProdN *)
995 (* (dummy_loc, *)
996 (* [[(dummy_loc,Anonymous)],returned_types.(i)], *)
997 (* Topconstr.CSort(dummy_loc, RProp Null ) *)
998 (* ) *)
999 (* ) *)
1000 in
1178 in
1179 (* We need to lift back our work topconstr but only with all information
1180 We mimick a Set Printing All.
1181 Then save the graphs and reset Printing options to their primitive values
1182 *)
10011183 let rel_arities = Array.mapi rel_arity funsargs in
10021184 let old_rawprint = !Options.raw_print in
10031185 Options.raw_print := true;
10161198 let ext_rels_constructors =
10171199 Array.map (List.map
10181200 (fun (id,t) ->
1019 false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty t)
1201 false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty ((* zeta_normalize *) t))
10201202 ))
1021 rel_constructors
1203 (rel_constructors)
10221204 in
10231205 let rel_ind i ext_rel_constructors =
10241206 (dummy_loc,relnames.(i)),
10291211 in
10301212 let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in
10311213 let rel_inds = Array.to_list ext_rel_constructors in
1032 let _ =
1033 observe (
1034 str "Inductive" ++ spc () ++
1035 prlist_with_sep
1036 (fun () -> fnl ()++spc () ++ str "with" ++ spc ())
1037 (function ((_,id),_,params,ar,constr) ->
1038 Ppconstr.pr_id id ++ spc () ++
1039 Ppconstr.pr_binders params ++ spc () ++
1040 str ":" ++ spc () ++
1041 Ppconstr.pr_lconstr_expr ar ++ spc () ++
1042 prlist_with_sep
1043 (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ())
1044 (function (_,((_,id),t)) ->
1045 Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++
1046 Ppconstr.pr_lconstr_expr t)
1047 constr
1048 )
1049 rel_inds
1050 )
1051 in
1214 (* let _ = *)
1215 (* Pp.msgnl (\* observe *\) ( *)
1216 (* str "Inductive" ++ spc () ++ *)
1217 (* prlist_with_sep *)
1218 (* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *)
1219 (* (function ((_,id),_,params,ar,constr) -> *)
1220 (* Ppconstr.pr_id id ++ spc () ++ *)
1221 (* Ppconstr.pr_binders params ++ spc () ++ *)
1222 (* str ":" ++ spc () ++ *)
1223 (* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *)
1224 (* prlist_with_sep *)
1225 (* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *)
1226 (* (function (_,((_,id),t)) -> *)
1227 (* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *)
1228 (* Ppconstr.pr_lconstr_expr t) *)
1229 (* constr *)
1230 (* ) *)
1231 (* rel_inds *)
1232 (* ) *)
1233 (* in *)
10521234 let old_implicit_args = Impargs.is_implicit_args ()
10531235 and old_strict_implicit_args = Impargs.is_strict_implicit_args ()
10541236 and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+11
-11
contrib/funind/rawterm_to_relation.mli less more
00
1 (* val new_build_entry_lc : *)
2 (* Names.identifier list -> *)
3 (* (Names.name*Rawterm.rawconstr) list list -> *)
4 (* Topconstr.constr_expr list -> *)
5 (* Rawterm.rawconstr list -> *)
6 (* unit *)
1
2 (*
3 [build_inductive parametrize funnames funargs returned_types bodies]
4 constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments
5 and returning [returned_types] using bodies [bodies]
6 *)
77
88 val build_inductive :
9 bool ->
10 Names.identifier list ->
11 (Names.name*Rawterm.rawconstr*bool) list list ->
12 Topconstr.constr_expr list ->
13 Rawterm.rawconstr list ->
9 bool -> (* if true try to detect parameter. Always use it as true except for debug *)
10 Names.identifier list -> (* The list of function name *)
11 (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
12 Topconstr.constr_expr list -> (* The list of function returned type *)
13 Rawterm.rawconstr list -> (* the list of body *)
1414 unit
1515
+74
-12
contrib/funind/rawtermops.ml less more
1717 let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl)
1818 let mkRSort s = RSort(dummy_loc,s)
1919 let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
20
20 let mkRCast(b,t) = RCast(dummy_loc,b,CastCoerce,t)
2121
2222 (*
2323 Some basic functions to decompose rawconstrs
4848
4949
5050 (* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
51 let raw_make_eq t1 t2 =
52 mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[mkRHole ();t2;t1])
51 let raw_make_eq ?(typ= mkRHole ()) t1 t2 =
52 mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
5353
5454 (* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
5555 let raw_make_neq t1 t2 =
320320 List.map (alpha_rt excluded) args
321321 )
322322 in
323 if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false
323 if Indfun_common.do_observe () && false
324324 then
325325 Pp.msgnl (str "debug: alpha_rt(" ++ str "[" ++
326326 prlist_with_sep (fun _ -> str";") Ppconstr.pr_id excluded ++
385385
386386
387387
388 let rec pattern_to_term = function
388 let rec pattern_to_term = function
389389 | PatVar(loc,Anonymous) -> assert false
390 | PatVar(loc,Name id) ->
390 | PatVar(loc,Name id) ->
391391 mkRVar id
392 | PatCstr(loc,constr,patternl,_) ->
393 let cst_narg =
392 | PatCstr(loc,constr,patternl,_) ->
393 let cst_narg =
394394 Inductiveops.mis_constructor_nargs_env
395395 (Global.env ())
396396 constr
397397 in
398 let implicit_args =
399 Array.to_list
400 (Array.init
398 let implicit_args =
399 Array.to_list
400 (Array.init
401401 (cst_narg - List.length patternl)
402402 (fun _ -> mkRHole ())
403403 )
404404 in
405 let patl_as_term =
405 let patl_as_term =
406406 List.map pattern_to_term patternl
407407 in
408408 mkRApp(mkRRef(Libnames.ConstructRef constr),
409409 implicit_args@patl_as_term
410410 )
411
412
411413
412414 let replace_var_by_term x_id term =
413415 let rec replace_var_by_pattern rt =
538540 in
539541 ids_of_pat Idset.empty
540542
543
544
545
546
547 let zeta_normalize =
548 let rec zeta_normalize_term rt =
549 match rt with
550 | RRef _ -> rt
551 | RVar _ -> rt
552 | REvar _ -> rt
553 | RPatVar _ -> rt
554 | RApp(loc,rt',rtl) ->
555 RApp(loc,
556 zeta_normalize_term rt',
557 List.map zeta_normalize_term rtl
558 )
559 | RLambda(loc,name,t,b) ->
560 RLambda(loc,
561 name,
562 zeta_normalize_term t,
563 zeta_normalize_term b
564 )
565 | RProd(loc,name,t,b) ->
566 RProd(loc,
567 name,
568 zeta_normalize_term t,
569 zeta_normalize_term b
570 )
571 | RLetIn(_,Name id,def,b) ->
572 zeta_normalize_term (replace_var_by_term id def b)
573 | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
574 | RLetTuple(loc,nal,(na,rto),def,b) ->
575 RLetTuple(loc,
576 nal,
577 (na,option_map zeta_normalize_term rto),
578 zeta_normalize_term def,
579 zeta_normalize_term b
580 )
581 | RCases(loc,infos,el,brl) ->
582 RCases(loc,
583 infos,
584 List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
585 List.map zeta_normalize_br brl
586 )
587 | RIf(loc,b,(na,e_option),lhs,rhs) ->
588 RIf(loc, zeta_normalize_term b,
589 (na,option_map zeta_normalize_term e_option),
590 zeta_normalize_term lhs,
591 zeta_normalize_term rhs
592 )
593 | RRec _ -> raise (UserError("",str "Not handled RRec"))
594 | RSort _ -> rt
595 | RHole _ -> rt
596 | RCast(loc,b,k,t) ->
597 RCast(loc,zeta_normalize_term b,k,zeta_normalize_term t)
598 | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
599 and zeta_normalize_br (loc,idl,patl,res) =
600 (loc,idl,patl,zeta_normalize_term res)
601 in
602 zeta_normalize_term
+8
-2
contrib/funind/rawtermops.mli less more
2424 val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr
2525 val mkRSort : rawsort -> rawconstr
2626 val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
27
27 val mkRCast : rawconstr* rawconstr -> rawconstr
2828 (*
2929 Some basic functions to decompose rawconstrs
3030 These are analogous to the ones constrs
3535
3636
3737 (* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
38 val raw_make_eq : rawconstr -> rawconstr -> rawconstr
38 val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
3939 (* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
4040 val raw_make_neq : rawconstr -> rawconstr -> rawconstr
4141 (* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
105105 returns the set of variables appearing in a pattern
106106 *)
107107 val ids_of_pat : cases_pattern -> Names.Idset.t
108
109
110 (*
111 removing let_in construction in a rawterm
112 *)
113 val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
+4
-11
contrib/funind/tacinv.ml4 less more
00 (*i camlp4deps: "parsing/grammar.cma" i*)
11
22 (*s FunInv Tactic: inversion following the shape of a function. *)
3 (* Use:
4 \begin{itemize}
5 \item The Tacinv directory must be in the path (-I <path> option)
6 \item use the bytecode version of coqtop or coqc (-byte option), or make a
7 coqtop
8 \item Do [Require Tacinv] to be able to use it.
9 \item For syntax see Tacinv.v
10 \end{itemize}
11 *)
12
3
4 (* Deprecated: see indfun_main.ml4 instead *)
5
6 (* Don't delete this file yet, it may be used for other purposes *)
137
148 (*i*)
159 open Termops
861855 (*
862856 *** Local Variables: ***
863857 *** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" ***
864 *** tab-width: 1 ***
865858 *** tuareg-default-indent:1 ***
866859 *** tuareg-begin-indent:1 ***
867860 *** tuareg-let-indent:1 ***
+3
-4
contrib/interface/xlate.ml less more
335335 | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a,
336336 List.map xlate_match_pattern l)
337337 and translate_one_equation = function
338 (_,lp, a) -> CT_eqn ( xlate_match_pattern_ne_list lp,
339 xlate_formula a)
338 (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
339 | _ -> xlate_error "TODO: disjunctive multiple patterns"
340340 and
341341 xlate_binder_ne_list = function
342342 [] -> assert false
977977 let id_opt =
978978 match out_gen Extratactics.rawwit_in_arg_hyp id_opt with
979979 | None -> ctv_ID_OPT_NONE
980 | Some id -> ctf_ID_OPT_SOME (xlate_ident id)
980 | Some (_,id) -> ctf_ID_OPT_SOME (xlate_ident id)
981981 in
982982 let tac_opt =
983983 match out_gen (Extratactics.rawwit_by_arg_tac) tac_opt with
20342034 | VernacExtend (s, l) ->
20352035 CT_user_vernac
20362036 (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l))
2037 | VernacDebug b -> xlate_error "Debug On/Off not supported"
20382037 | VernacList((_, a)::l) ->
20392038 CT_coerce_COMMAND_LIST_to_COMMAND
20402039 (CT_command_list(xlate_vernac a,
+5
-0
contrib/romega/ReflOmegaCore.v less more
4848 | Tvar : nat -> term.
4949
5050 Delimit Scope romega_scope with term.
51 Arguments Scope Tplus [romega_scope romega_scope].
52 Arguments Scope Tmult [romega_scope romega_scope].
53 Arguments Scope Tminus [romega_scope romega_scope].
54 Arguments Scope Topp [romega_scope romega_scope].
55
5156 Infix "+" := Tplus : romega_scope.
5257 Infix "*" := Tmult : romega_scope.
5358 Infix "-" := Tminus : romega_scope.
+24
-0
contrib/subtac/FixSub.v less more
1919 End FixPoint.
2020
2121 End Well_founded.
22
23 Require Import Wf_nat.
24 Require Import Lt.
25
26 Section Well_founded_measure.
27 Variable A : Set.
28 Variable f : A -> nat.
29 Definition R := fun x y => f x < f y.
30
31 Section FixPoint.
32
33 Variable P : A -> Set.
34
35 Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x.
36
37 Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (f x)) {struct r} : P x :=
38 F_sub x (fun y: { y : A | f y < f x} => Fix_measure_F_sub (proj1_sig y)
39 (Acc_inv r (f (proj1_sig y)) (proj2_sig y))).
40
41 Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)).
42
43 End FixPoint.
44
45 End Well_founded_measure.
+10
-0
contrib/subtac/Utils.v less more
3333 simpl ; auto.
3434 Qed.
3535
36 Ltac destruct_one_pair :=
37 match goal with
38 | [H : (ex _) |- _] => destruct H
39 | [H : (ex2 _) |- _] => destruct H
40 | [H : (sig _) |- _] => destruct H
41 | [H : (_ /\ _) |- _] => destruct H
42 end.
43
44 Ltac destruct_exists := repeat (destruct_one_pair) .
45
+30
-26
contrib/subtac/eterm.ml less more
1515 Array.of_list (List.rev (Array.to_list arr))
1616
1717 let trace s =
18 if !Options.debug then msgnl s
18 if !Options.debug then (msgnl s; msgerr s)
1919 else ()
2020
2121 (** Utilities to find indices in lists *)
3636 let subst_evars evs n t =
3737 let evar_info id =
3838 let rec aux i = function
39 (k, h, v) :: tl -> if k = id then (i, h, v) else aux (succ i) tl
39 (k, h, v) :: tl ->
40 trace (str "Searching for " ++ int id ++ str " found: " ++ int k);
41 if k = id then (i, h, v) else aux (succ i) tl
4042 | [] -> raise Not_found
4143 in
4244 let (idx, hyps, v) = aux 0 evs in
4446 in
4547 let rec substrec depth c = match kind_of_term c with
4648 | Evar (k, args) ->
47 (try
48 let index, hyps = evar_info k in
49 (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++
50 int (List.length hyps) ++ str " hypotheses"); with _ -> () );
51
52 let ex = mkRel (index + depth) in
53 (* Evar arguments are created in inverse order,
54 and we must not apply to defined ones (i.e. LetIn's)
55 *)
56 let args =
57 let rec aux hyps args acc =
58 match hyps, args with
59 ((_, None, _) :: tlh), (c :: tla) ->
60 aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
61 | ((_, Some _, _) :: tlh), (_ :: tla) ->
62 aux tlh tla acc
63 | [], [] -> acc
64 | _, _ -> failwith "subst_evars: invalid argument"
65 in aux hyps (Array.to_list args) []
66 in
67 mkApp (ex, Array.of_list args)
68 with Not_found ->
69 anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found"))
49 (let index, hyps =
50 try evar_info k
51 with Not_found ->
52 anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
53 in
54 (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++
55 int (List.length hyps) ++ str " hypotheses"); with _ -> () );
56 let ex = mkRel (index + depth) in
57 (* Evar arguments are created in inverse order,
58 and we must not apply to defined ones (i.e. LetIn's)
59 *)
60 let args =
61 let rec aux hyps args acc =
62 match hyps, args with
63 ((_, None, _) :: tlh), (c :: tla) ->
64 aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
65 | ((_, Some _, _) :: tlh), (_ :: tla) ->
66 aux tlh tla acc
67 | [], [] -> acc
68 | _, _ -> failwith "subst_evars: invalid argument"
69 in aux hyps (Array.to_list args) []
70 in
71 mkApp (ex, Array.of_list args))
7072 | _ -> map_constr_with_binders succ substrec depth c
7173 in
7274 substrec 0 t
105107 let eterm_term evm t tycon =
106108 (* 'Serialize' the evars, we assume that the types of the existentials
107109 refer to previous existentials in the list only *)
108 let evl = to_list evm in
110 let evl = List.rev (to_list evm) in
111 trace (str "Eterm, transformed to list");
109112 let evts =
110113 (* Remove existential variables in types and build the corresponding products *)
111114 fold_right
112115 (fun (id, ev) l ->
116 trace (str "Eterm: " ++ str "treating evar: " ++ int id);
113117 let hyps = Environ.named_context_of_val ev.evar_hyps in
114118 let y' = (id, hyps, etype_of_evar l ev hyps) in
115119 y' :: l)
+3
-3
contrib/subtac/subtac.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: subtac.ml 8889 2006-06-01 20:23:56Z msozeau $ *)
8 (* $Id: subtac.ml 8964 2006-06-20 13:52:21Z msozeau $ *)
99
1010 open Global
1111 open Pp
4242 let require_library dirpath =
4343 let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
4444 Library.require_library [qualid] None
45
45 (*
4646 let subtac_one_fixpoint env isevars (f, decl) =
4747 let ((id, n, bl, typ, body), decl) =
4848 Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl)
5252 Ppconstr.pr_constr_expr body)
5353 with _ -> ()
5454 in ((id, n, bl, typ, body), decl)
55
55 *)
5656
5757 let subtac_fixpoint isevars l =
5858 (* TODO: Copy command.build_recursive *)
+0
-11
contrib/subtac/subtac.mli less more
00 val require_library : string -> unit
1 val subtac_one_fixpoint :
2 'a ->
3 'b ->
4 (Names.identifier * (int * Topconstr.recursion_order_expr) *
5 Topconstr.local_binder list * Topconstr.constr_expr *
6 Topconstr.constr_expr) *
7 'c ->
8 (Names.identifier * (int * Topconstr.recursion_order_expr) *
9 Topconstr.local_binder list * Topconstr.constr_expr *
10 Topconstr.constr_expr) *
11 'c
121 val subtac_fixpoint : 'a -> 'b -> unit
132 val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
+9
-9
contrib/subtac/subtac_coercion.ml less more
44 (* // * This file is distributed under the terms of the *)
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
7 (* $Id: subtac_coercion.ml 8889 2006-06-01 20:23:56Z msozeau $ *)
7 (* $Id: subtac_coercion.ml 8964 2006-06-20 13:52:21Z msozeau $ *)
88
99 open Util
1010 open Names
105105 : (Term.constr -> Term.constr) option
106106 =
107107 let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in
108 (try trace (str "Coerce called for " ++ (my_print_constr env x) ++
108 (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++
109109 str " and "++ my_print_constr env y ++
110110 str " with evars: " ++ spc () ++
111111 my_print_evardefs !isevars);
112112 with _ -> ());
113113 let rec coerce_unify env x y =
114 (try trace (str "coerce_unify from " ++ (my_print_constr env x) ++
114 (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++
115115 str " to "++ my_print_constr env y)
116116 with _ -> ());
117117 try
118118 isevars := the_conv_x_leq env x y !isevars;
119 (try (trace (str "Unified " ++ (my_print_constr env x) ++
120 str " and "++ my_print_constr env y));
119 (try debug 1 (str "Unified " ++ (my_print_constr env x) ++
120 str " and "++ my_print_constr env y);
121121 with _ -> ());
122122 None
123123 with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y)
124124 and coerce' env x y : (Term.constr -> Term.constr) option =
125125 let subco () = subset_coerce env isevars x y in
126 (try trace (str "coerce' from " ++ (my_print_constr env x) ++
126 (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++
127127 str " to "++ my_print_constr env y);
128128 with _ -> ());
129129 match (kind_of_term x, kind_of_term y) with
369369
370370 let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
371371 (try
372 trace (str "inh_conv_coerce_to_fail called for " ++
372 debug 1 (str "inh_conv_coerce_to_fail called for " ++
373373 Termops.print_constr_env env t ++ str " and "++ spc () ++
374374 Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++
375375 Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
435435 (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
436436 let inh_conv_coerce_to loc env isevars cj ((n, t) as tycon) =
437437 (try
438 trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++
438 debug 1 (str "Subtac_coercion.inh_conv_coerce_to called for " ++
439439 Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++
440440 Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++
441441 Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
460460
461461 let inh_conv_coerces_to loc env isevars t ((abs, t') as tycon) =
462462 (try
463 trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++
463 debug 1 (str "Subtac_coercion.inh_conv_coerces_to called for " ++
464464 Termops.print_constr_env env t ++ str " and "++ spc () ++
465465 Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++
466466 Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++
+203
-68
contrib/subtac/subtac_command.ml less more
116116
117117 let list_chop_hd i l = match list_chop i l with
118118 | (l1,x::l2) -> (l1,x,l2)
119 | _ -> assert false
119 | (x :: [], l2) -> ([], x, [])
120 | _ -> assert(false)
120121
121122 let collect_non_rec env =
122123 let rec searchrec lnonrec lnamerec ldefrec larrec nrec =
172173 | [] -> List.rev acc
173174 in aux [] l
174175
175 let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed =
176 let lift_binders k n l =
177 let rec aux n = function
178 | (id, t, c) :: tl -> (id, option_map (liftn k n) t, liftn k n c) :: aux (pred n) tl
179 | [] -> []
180 in aux n l
181
182 let rec gen_rels = function
183 0 -> []
184 | n -> mkRel n :: gen_rels (pred n)
185
186 let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
187 let sigma = Evd.empty in
188 let isevars = ref (Evd.create_evar_defs sigma) in
189 let env = Global.env() in
190 let pr c = my_print_constr env c in
191 let prr = Printer.pr_rel_context env in
192 let pr_rel env = Printer.pr_rel_context env in
193 let _ =
194 try debug 2 (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++
195 Ppconstr.pr_binders bl ++ str " : " ++
196 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++
197 Ppconstr.pr_constr_expr body)
198 with _ -> ()
199 in
200 let env', binders_rel = interp_context isevars env bl in
201 let after, ((argname, _, argtyp) as arg), before = list_chop_hd (succ n) binders_rel in
202 let before_length, after_length = List.length before, List.length after in
203 let argid = match argname with Name n -> n | _ -> assert(false) in
204 let _liftafter = lift_binders 1 after_length after in
205 let envwf = push_rel_context before env in
206 let wf_rel, measure_fn =
207 let rconstr = interp_constr isevars envwf r in
208 if measure then
209 let lt_rel = constr_of_global (Lazy.force lt_ref) in
210 let name s = Name (id_of_string s) in
211 mkLambda (name "x", argtyp,
212 mkLambda (name "y", argtyp,
213 mkApp (lt_rel,
214 [| mkApp (rconstr, [| mkRel 2 |]) ;
215 mkApp (rconstr, [| mkRel 1 |]) |]))),
216 Some rconstr
217 else rconstr, None
218 in
219 let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |])
220 in
221 let argid' = id_of_string (string_of_id argid ^ "'") in
222 let wfarg len = (Name argid', None,
223 mkSubset (Name argid') argtyp
224 (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|])))
225 in
226 let top_bl = after @ (arg :: before) in
227 let intern_bl = after @ (wfarg 1 :: arg :: before) in
228 let top_env = push_rel_context top_bl env in
229 let intern_env = push_rel_context intern_bl env in
230 let top_arity = interp_type isevars top_env arityc in
231 (try debug 2 (str "Intern bl: " ++ prr intern_bl) with _ -> ());
232 let proj = (Lazy.force sig_).Coqlib.proj1 in
233 let projection =
234 mkApp (proj, [| argtyp ;
235 (mkLambda (Name argid', argtyp,
236 (mkApp (wf_rel, [|mkRel 1; mkRel 3|])))) ;
237 mkRel 1
238 |])
239 in
240 (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ());
241 let intern_arity = substnl [projection] after_length top_arity in
242 (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ());
243 let intern_before_env = push_rel_context before env in
244 let intern_fun_bl = after @ [wfarg 1] in
245 (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ());
246 let intern_fun_arity = intern_arity in
247 (try debug 2 (str "Intern fun arity: " ++
248 my_print_constr intern_env intern_fun_arity) with _ -> ());
249 let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in
250 let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
251 let fun_bl = after @ (intern_fun_binder :: [arg]) in
252 (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ());
253 let fun_env = push_rel_context fun_bl intern_before_env in
254 let fun_arity = interp_type isevars fun_env arityc in
255 let intern_body = interp_casted_constr isevars fun_env body fun_arity in
256 let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in
257 let _ =
258 try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++
259 str "Intern bl" ++ prr intern_bl ++ spc () ++
260 str "Top bl" ++ prr top_bl ++ spc () ++
261 str "Intern arity: " ++ pr intern_arity ++
262 str "Top arity: " ++ pr top_arity ++ spc () ++
263 str "Intern body " ++ pr intern_body_lam)
264 with _ -> ()
265 in
266 let _impl =
267 if Impargs.is_implicit_args()
268 then Impargs.compute_implicits top_env top_arity
269 else []
270 in
271 let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in
272 let fix_def =
273 match measure_fn with
274 None ->
275 mkApp (constr_of_reference (Lazy.force fix_sub_ref),
276 [| argtyp ;
277 wf_rel ;
278 make_existential dummy_loc intern_before_env isevars wf_proof ;
279 prop ;
280 intern_body_lam |])
281 | Some f ->
282 mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref),
283 [| argtyp ; f ; prop ;
284 intern_body_lam |])
285 in
286 let def_appl = applist (fix_def, gen_rels (after_length + 1)) in
287 let def = it_mkLambda_or_LetIn def_appl binders_rel in
288 let typ = it_mkProd_or_LetIn top_arity binders_rel in
289 debug 2 (str "Constructed def");
290 debug 2 (my_print_constr intern_before_env def);
291 debug 2 (str "Type: " ++ my_print_constr env typ);
292 let fullcoqc = Evarutil.nf_isevar !isevars def in
293 let fullctyp = Evarutil.nf_isevar !isevars typ in
294 let _ = try trace (str "After evar normalization: " ++ spc () ++
295 str "Coq term: " ++ my_print_constr env fullcoqc ++ spc ()
296 ++ str "Coq type: " ++ my_print_constr env fullctyp)
297 with _ -> ()
298 in
299 let evm = non_instanciated_map env isevars in
300 let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in
301 let evars_def, evars_typ, evars = Eterm.eterm_term evm fullcoqc (Some fullctyp) in
302 let evars_typ = out_some evars_typ in
303 (try trace (str "Building evars sum for : ");
304 List.iter
305 (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t))
306 evars;
307 with _ -> ());
308 let (sum_tac, sumg) = Subtac_utils.build_dependent_sum evars in
309 (try trace (str "Evars sum: " ++ my_print_constr env sumg);
310 trace (str "Evars type: " ++ my_print_constr env evars_typ);
311 with _ -> ());
312 let proofid = id_of_string (string_of_id recname ^ "_evars_proof") in
313 Command.start_proof proofid goal_proof_kind sumg
314 (fun strength gr ->
315 debug 2 (str "Proof finished");
316 let def = constr_of_global gr in
317 let args = Subtac_utils.destruct_ex def sumg in
318 let _, newdef = decompose_lam_n (List.length args) evars_def in
319 let constr = Term.substl (List.rev args) newdef in
320 debug 2 (str "Applied existentials : " ++ my_print_constr env constr);
321 let ce =
322 { const_entry_body = constr;
323 const_entry_type = Some fullctyp;
324 const_entry_opaque = false;
325 const_entry_boxed = boxed}
326 in
327 let _constant = Declare.declare_constant
328 recname (DefinitionEntry ce,IsDefinition Definition)
329 in
330 definition_message recname);
331 trace (str "Started existentials proof");
332 Pfedit.by sum_tac;
333 trace (str "Applied sum tac")
334
335 let build_mutrec l boxed =
176336 let sigma = Evd.empty
177337 and env0 = Global.env()
178338 in
179339 let lnameargsardef =
180340 (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env0 protos (f, d))*)
181 lnameargsardef
341 l
182342 in
183343 let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef
184344 and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef
185345 in
186 (* Build the recursive context and notations for the recursive types *)
346 (* Build the recursive context and notations for the recursive types *)
187347 let (rec_sign,rec_impls,arityl) =
188348 List.fold_left
189 (fun (env,impls,arl) ((recname,(n, ro),bl,arityc,body),_) ->
190 let isevars = ref (Evd.create_evar_defs sigma) in
191 match ro with
192 CStructRec ->
193 let arityc = Command.generalize_constr_expr arityc bl in
194 let arity = interp_type isevars env0 arityc in
195 let impl =
196 if Impargs.is_implicit_args()
197 then Impargs.compute_implicits env0 arity
198 else [] in
199 let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
200 (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl)
201 | CWfRec r ->
202 let n = out_some n in
203 let _ =
204 try trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++
205 Ppconstr.pr_binders bl ++ str " : " ++
206 Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++
207 Ppconstr.pr_constr_expr body)
208 with _ -> ()
209 in
210 let env', binders_rel = interp_context isevars env0 bl in
211 let after, ((argname, _, argtyp) as arg), before = list_chop_hd n binders_rel in
212 let argid = match argname with Name n -> n | _ -> assert(false) in
213 let after' = List.map (fun (n, c, t) -> (n, option_map (lift 1) c, lift 1 t)) after in
214 let envwf = push_rel_context before env0 in
215 let wf_rel = interp_constr isevars envwf r in
216 let accarg_id = id_of_string ("Acc_" ^ string_of_id argid) in
217 let accarg = (Name accarg_id, None, mkApp (Lazy.force acc_inv, [| argtyp; wf_rel; mkRel 1 |])) in
218 let argid' = id_of_string (string_of_id argid ^ "'") in
219 let before_length, after_length = List.length before, List.length after in
220 let full_length = before_length + 1 + after_length in
221 let wfarg len = (Name argid, None,
222 mkSubset (Name argid') argtyp
223 (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|])))
224 in
225 let new_bl = after' @ (accarg :: arg :: before)
226 and intern_bl = after @ (wfarg (before_length + 1) :: before)
227 in
228 let intern_env = push_rel_context intern_bl env0 in
229 let env' = push_rel_context new_bl env0 in
230 let arity = interp_type isevars intern_env arityc in
231 let intern_arity = it_mkProd_or_LetIn arity intern_bl in
232 let arity' = interp_type isevars env' arityc in
233 let arity' = it_mkProd_or_LetIn arity' new_bl in
234 let fun_bl = after @ ((Name recname, None, intern_arity) :: arg :: before) in
235 let _ =
236 let pr c = my_print_constr env c in
237 let prr = Printer.pr_rel_context env in
238 try trace (str "Fun bl: " ++ prr fun_bl ++ spc () ++
239 str "Intern bl" ++ prr intern_bl ++ spc () ++
240 str "Extern bl" ++ prr new_bl ++ spc () ++
241 str "Intern arity: " ++ pr intern_arity)
242 with _ -> ()
243 in
244 let impl =
245 if Impargs.is_implicit_args()
246 then Impargs.compute_implicits intern_env arity'
247 else [] in
248 let impls' = (recname,([],impl,compute_arguments_scope arity'))::impls in
249 (Environ.push_named (recname,None,arity') env, impls',
250 (isevars, Some (full_length - n, argtyp, wf_rel, fun_bl, intern_bl, intern_arity), arity')::arl))
349 (fun (env,impls,arl) ((recname, n, bl,arityc,body),_) ->
350 let isevars = ref (Evd.create_evar_defs sigma) in
351 let arityc = Command.generalize_constr_expr arityc bl in
352 let arity = interp_type isevars env0 arityc in
353 let impl =
354 if Impargs.is_implicit_args()
355 then Impargs.compute_implicits env0 arity
356 else [] in
357 let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
358 (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl))
251359 (env0,[],[]) lnameargsardef in
252360 let arityl = List.rev arityl in
253361 let notations =
282390
283391 let (lnonrec,(namerec,defrec,arrec,nvrec)) =
284392 collect_non_rec env0 lrecnames recdef arityl nv in
285 let nvrec' = Array.map (function (Some n,_) -> n | _ -> 0) nvrec in(* ignore rec order *)
286393 let declare arrec defrec =
287394 let recvec =
288395 Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in
292399 my_print_constr env0 (recvec.(i)));
293400 with _ -> ());
294401 let ce =
295 { const_entry_body = mkFix ((nvrec',i),recdecls);
402 { const_entry_body = mkFix ((nvrec,i),recdecls);
296403 const_entry_type = Some arrec.(i);
297404 const_entry_opaque = false;
298405 const_entry_boxed = boxed} in
383490 match sum with Some (sumtac, sumg) -> Some (id, kn, sumg, sumtac) | None -> None)
384491 defs
385492 in
493 match real_evars with
494 [] -> declare (List.rev_map (fun (id, c, _) ->
495 snd (decompose_lam_n recdefs c)) defs)
496 | l ->
497
386498 Subtac_utils.and_tac real_evars
387499 (fun f _ gr ->
388500 let _ = trace (str "Got a proof of: " ++ pr_global gr ++
430542 Environ.NoBody -> trace (str "Constant has no body")
431543 | Environ.Opaque -> trace (str "Constant is opaque")
432544 )
545
546 let out_n = function
547 Some n -> n
548 | None -> 0
549
550 let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed =
551 match lnameargsardef with
552 | ((id, (n, CWfRec r), bl, typ, body), no) :: [] ->
553 build_wellfounded (id, out_n n, bl, typ, body) r false no boxed
554 | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] ->
555 build_wellfounded (id, out_n n, bl, typ, body) r true no boxed
556 | l ->
557 let lnameargsardef =
558 List.map (fun ((id, (n, ro), bl, typ, body), no) ->
559 match ro with
560 CStructRec -> (id, out_n n, bl, typ, body), no
561 | CWfRec _ | CMeasureRec _ ->
562 errorlabstrm "Subtac_command.build_recursive"
563 (str "Well-founded fixpoints not allowed in mutually recursive blocks"))
564 lnameargsardef
565 in
566 build_mutrec lnameargsardef boxed;
567 assert(false)
433568
434569
+1
-0
contrib/subtac/subtac_command.mli less more
3737 constr_expr -> unsafe_judgment
3838 val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
3939 val recursive_message : global_reference array -> std_ppcmds
40
4041 val build_recursive :
4142 (fixpoint_expr * decl_notation) list -> bool -> unit
+2
-1
contrib/subtac/subtac_interp_fixpoint.ml less more
5959
6060
6161 let rec rewrite_rec_calls l c = c
62
62 (*
6363 let rewrite_fixpoint env l (f, decl) =
6464 let (id, (n, ro), bl, typ, body) = f in
6565 let body = rewrite_rec_calls l body in
150150 Ppconstr.pr_constr_expr body')
151151 in (id, (succ n, ro), bl', typ, body'), decl
152152
153 *)
+0
-11
contrib/subtac/subtac_interp_fixpoint.mli less more
1414 val pr_binder_list :
1515 (('a * Names.name) * Topconstr.constr_expr) list -> Pp.std_ppcmds
1616 val rewrite_rec_calls : 'a -> 'b -> 'b
17 val rewrite_fixpoint :
18 'a ->
19 'b ->
20 (Names.identifier * (int * Topconstr.recursion_order_expr) *
21 Topconstr.local_binder list * Topconstr.constr_expr *
22 Topconstr.constr_expr) *
23 'c ->
24 (Names.identifier * (int * Topconstr.recursion_order_expr) *
25 Topconstr.local_binder list * Topconstr.constr_expr *
26 Topconstr.constr_expr) *
27 'c
+120
-10
contrib/subtac/subtac_utils.ml less more
2121 let ex_pi1 = lazy (init_constant utils_module "ex_pi1")
2222 let ex_pi2 = lazy (init_constant utils_module "ex_pi2")
2323
24 let make_ref s = Qualid (dummy_loc, (qualid_of_string s))
25 let well_founded_ref = make_ref "Init.Wf.Well_founded"
26 let acc_ref = make_ref "Init.Wf.Acc"
27 let acc_inv_ref = make_ref "Init.Wf.Acc_inv"
28 let fix_sub_ref = make_ref "Coq.subtac.FixSub.Fix_sub"
29 let lt_wf_ref = make_ref "Coq.Wf_nat.lt_wf"
24 let make_ref l s = lazy (init_reference l s)
25 let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
26 let acc_ref = make_ref ["Init";"Wf"] "Acc"
27 let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv"
28 let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub"
29 let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub"
30 let lt_ref = make_ref ["Init";"Peano"] "lt"
31 let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf"
32
33 let make_ref s = Qualid (dummy_loc, qualid_of_string s)
3034 let sig_ref = make_ref "Init.Specif.sig"
3135 let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
3236 let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
8185
8286 let my_print_tycon_type = Evarutil.pr_tycon_type
8387
88 let debug_level = 2
8489
8590 let debug n s =
86 if !Options.debug then
91 if !Options.debug && n >= debug_level then
8792 msgnl s
8893 else ()
8994
9095 let debug_msg n s =
91 if !Options.debug then s
96 if !Options.debug && n >= debug_level then s
9297 else mt ()
9398
9499 let trace s =
95 if !Options.debug then msgnl s
100 if !Options.debug && debug_level > 0 then msgnl s
96101 else ()
97102
98103 let wf_relations = Hashtbl.create 10
152157 let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
153158 let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
154159
160 let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
161 let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
162
155163 let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
156164 let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
157165
163171 (n, t) :: tl ->
164172 let t' = mkLambda (Name n, t, typ) in
165173 trace (spc () ++ str ("treating evar " ^ string_of_id n));
166 (try trace (str " assert: " ++ my_print_constr (Global.env ()) t)
174 (try trace (str " assert: " ++ my_print_constr (Global.env ()) t)
167175 with _ -> ());
168176 let tac' =
169177 tclTHENS (assert_tac true (Name n) t)
182190 (_, hd) :: tl -> aux (intros, hd) tl
183191 | [] -> raise (Invalid_argument "build_dependent_sum")
184192
193 let id x = x
194
195 let build_dependent_sum l =
196 let rec aux names conttac conttype = function
197 (n, t) :: ((_ :: _) as tl) ->
198 let hyptype = substl names t in
199 trace (spc () ++ str ("treating evar " ^ string_of_id n));
200 (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
201 with _ -> ());
202 let tac = assert_tac true (Name n) hyptype in
203 let conttac =
204 (fun cont ->
205 conttac
206 (tclTHENS tac
207 ([intros;
208 (tclTHENSEQ
209 [constructor_tac (Some 1) 1
210 (Rawterm.ImplicitBindings [mkVar n]);
211 cont]);
212 ])))
213 in
214 let conttype =
215 (fun typ ->
216 let tex = mkLambda (Name n, t, typ) in
217 conttype
218 (mkApp (Lazy.force ex_ind, [| t; tex |])))
219 in
220 aux (mkVar n :: names) conttac conttype tl
221 | (n, t) :: [] ->
222 (conttac intros, conttype t)
223 | [] -> raise (Invalid_argument "build_dependent_sum")
224 in aux [] id id (List.rev l)
225
185226 open Proof_type
186227 open Tacexpr
187228
250291 | _ -> [acc]
251292 in aux ex ext
252293
294 open Rawterm
295
296
297 let list_mapi f =
298 let rec aux i = function
299 hd :: tl -> f i hd :: aux (succ i) tl
300 | [] -> []
301 in aux 0
302
303 let rewrite_cases_aux (loc, po, tml, eqns) =
304 let tml = list_mapi (fun i (c, (n, opt)) -> c,
305 ((match n with
306 Name id -> (match c with
307 | RVar (_, id') when id = id' ->
308 Name (id_of_string (string_of_id id ^ "'"))
309 | _ -> n)
310 | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))),
311 opt)) tml
312 in
313 let mkHole = RHole (dummy_loc, InternalHole) in
314 let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)),
315 [mkHole; c; n])
316 in
317 let eqs_types =
318 List.map
319 (fun (c, (n, _)) ->
320 let id = match n with Name id -> id | _ -> assert false in
321 let heqid = id_of_string ("Heq" ^ string_of_id id) in
322 Name heqid, mkeq c (RVar (dummy_loc, id)))
323 tml
324 in
325 let po =
326 List.fold_right
327 (fun (n,t) acc ->
328 RProd (dummy_loc, Anonymous, t, acc))
329 eqs_types (match po with
330 Some e -> e
331 | None -> mkHole)
332 in
333 let eqns =
334 List.map (fun (loc, idl, cpl, c) ->
335 let c' =
336 List.fold_left
337 (fun acc (n, t) ->
338 RLambda (dummy_loc, n, mkHole, acc))
339 c eqs_types
340 in (loc, idl, cpl, c'))
341 eqns
342 in
343 let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref),
344 [mkHole; c])
345 in
346 let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in
347 let case = RCases (loc,Some po,tml,eqns) in
348 let app = RApp (dummy_loc, case, refls) in
349 app
350
351 let rec rewrite_cases c =
352 match c with
353 RCases _ -> let c' = map_rawconstr rewrite_cases c in
354 (match c' with
355 | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w)
356 | _ -> assert(false))
357 | _ -> map_rawconstr rewrite_cases c
358
359 let rewrite_cases env c =
360 let c' = rewrite_cases c in
361 let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in
362 c'
253363
254364 let list_mapi f =
255365 let rec aux i = function
+9
-6
contrib/subtac/subtac_utils.mli less more
1717 val init_constant : string list -> string -> constr
1818 val init_reference : string list -> string -> global_reference
1919 val fixsub : constr lazy_t
20 val make_ref : string -> reference
21 val well_founded_ref : reference
22 val acc_ref : reference
23 val acc_inv_ref : reference
24 val fix_sub_ref : reference
25 val lt_wf_ref : reference
20 val well_founded_ref : global_reference lazy_t
21 val acc_ref : global_reference lazy_t
22 val acc_inv_ref : global_reference lazy_t
23 val fix_sub_ref : global_reference lazy_t
24 val fix_measure_sub_ref : global_reference lazy_t
25 val lt_ref : global_reference lazy_t
26 val lt_wf_ref : global_reference lazy_t
2627 val sig_ref : reference
2728 val proj1_sig_ref : reference
2829 val proj2_sig_ref : reference
6869 val non_instanciated_map : env -> evar_defs ref -> evar_map
6970 val global_kind : logical_kind
7071 val goal_kind : locality_flag * goal_object_kind
72 val global_proof_kind : logical_kind
73 val goal_proof_kind : locality_flag * goal_object_kind
7174 val global_fix_kind : logical_kind
7275 val goal_fix_kind : locality_flag * goal_object_kind
7376
+4
-4
contrib/subtac/test/ListsTest.v less more
44
55 Program Definition myhd : forall { l : list A | length l <> 0 }, A :=
66 fun l =>
7 match l with
7 match `l with
88 | nil => _
99 | hd :: tl => hd
1010 end.
1111 Proof.
12 destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition.
12 destruct l ; simpl ; intro H.
13 rewrite H in n ; intuition.
1314 Defined.
1415
1516
2324 | hd :: tl => tl
2425 end.
2526 Proof.
26 destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition.
27 destruct l ; simpl ; intro H ; rewrite H in n ; intuition.
2728 Defined.
2829
2930 Extraction mytail.
4950 | nil => l'
5051 | hd :: tl => hd :: (append tl l')
5152 end.
52 simpl.
5353 subst ; auto.
5454 simpl ; rewrite (subset_simpl (append tl0 l')).
5555 simpl ; subst.
+10
-4
contrib/subtac/test/Mutind.v less more
0 Fixpoint f (a : nat) : nat := match a with 0 => 0
1 | S a' => g a a'
0 Program Fixpoint f (a : nat) : nat :=
1 match a with
2 | 0 => 0
3 | S a' => g a a'
24 end
35 with g (a b : nat) { struct b } : nat :=
4 match b with 0 => 0
6 match b with
7 | 0 => 0
58 | S b' => f b'
6 end.⏎
9 end.
10
11 Check f.
12 Check g.⏎
+2
-2
contrib/subtac/test/euclid.v less more
1111 Defined.
1212
1313 Extraction testsig.
14 Extraction sigS.
15 Extract Inductive sigS => "" [ "" ].
14 Extraction sig.
15 Extract Inductive sig => "" [ "" ].
1616 Extraction testsig.
1717
1818 Require Import Coq.Arith.Compare_dec.
+24
-0
contrib/subtac/test/measure.v less more
0 Notation "( x & y )" := (@existS _ _ x y) : core_scope.
1 Unset Printing All.
2 Require Import Coq.Arith.Compare_dec.
3
4 Require Import Coq.subtac.Utils.
5
6 Fixpoint size (a : nat) : nat :=
7 match a with
8 0 => 1
9 | S n => S (size n)
10 end.
11
12 Program Fixpoint test_measure (a : nat) {measure a size} : nat :=
13 match a with
14 | S (S n) => S (test_measure n)
15 | x => x
16 end.
17 subst.
18 unfold n0.
19 auto with arith.
20 Qed.
21
22 Check test_measure.
23 Print test_measure.⏎
+48
-0
contrib/subtac/test/wf.v less more
0 Notation "( x & y )" := (@existS _ _ x y) : core_scope.
1 Unset Printing All.
2 Require Import Coq.Arith.Compare_dec.
3
4 Require Import Coq.subtac.Utils.
5
6 Ltac one_simpl_hyp :=
7 match goal with
8 | [H : (`exist _ _ _) = _ |- _] => simpl in H
9 | [H : _ = (`exist _ _ _) |- _] => simpl in H
10 | [H : (`exist _ _ _) < _ |- _] => simpl in H
11 | [H : _ < (`exist _ _ _) |- _] => simpl in H
12 | [H : (`exist _ _ _) <= _ |- _] => simpl in H
13 | [H : _ <= (`exist _ _ _) |- _] => simpl in H
14 | [H : (`exist _ _ _) > _ |- _] => simpl in H
15 | [H : _ > (`exist _ _ _) |- _] => simpl in H
16 | [H : (`exist _ _ _) >= _ |- _] => simpl in H
17 | [H : _ >= (`exist _ _ _) |- _] => simpl in H
18 end.
19
20 Ltac one_simpl_subtac :=
21 destruct_exists ;
22 repeat one_simpl_hyp ; simpl.
23
24 Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl.
25
26 Require Import Omega.
27 Require Import Wf_nat.
28
29 Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} :
30 { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
31 if le_lt_dec b a then let (q', r) := euclid (a - b) b in
32 (S q' & r)
33 else (O & a).
34 destruct b ; simpl_subtac.
35 omega.
36 simpl_subtac.
37 assert(x0 * S q' = x0 + x0 * q').
38 rewrite <- mult_n_Sm.
39 omega.
40 rewrite H2 ; omega.
41 simpl_subtac.
42 split ; auto with arith.
43 omega.
44 apply lt_wf.
45 Defined.
46
47 Check euclid_evars_proof.⏎
+1
-1
contrib/xml/xmlcommand.ml less more
473473 match r with
474474 | Ln.IndRef kn | Ln.ConstructRef (kn,_) ->
475475 let isrecord =
476 try let _ = Recordops.lookup_structure kn in true
476 try let _ = Recordops.lookup_projections kn in true
477477 with Not_found -> false in
478478 kind_of_inductive isrecord (fst kn)
479479 | Ln.VarRef id -> kind_of_variable id
+21
-0
dev/doc/changes.txt less more
1212 Printer: prterm -> pr_lconstr
1313 Printer: prterm_env -> pr_lconstr_env
1414 Ppconstr: pr_sort -> pr_rawsort
15 Evd: in_dom, etc got standard ocaml names (i.e. mem, etc)
16 Pretyping:
17 - understand_gen_tcc and understand_gen_ltac merged into understand_ltac
18 - type_constraints can now say typed by a sort (use OfType to get the
19 previous behavior)
20 Library: import_library -> import_module
1521
1622 ** Constructors
1723
1824 Declarations: mind_consnrealargs -> mind_consnrealdecls
1925 NoRedun -> NoDup
26 Cast and RCast have an extra argument: you can recover the previous
27 behavior by setting the extra argument to "CastConv DEFAULTcast" and
28 "DEFAULTcast" respectively
29 Names: "kernel_name" is now "constant" when argument of Term.Const
30 Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert
31 Tacexpr: TacForward(true,_,_) branched to TacLetTac
2032
2133 ** Modules
2234
2638 module Symbols -> Notation
2739 module Coqast, Ast, Esyntax, Termast, and all other modules related to old
2840 syntax are removed
41 module Instantiate: integrated to Evd
42 module Pretyping now a functor: use Pretyping.Default instead
2943
3044 ** Internal names
3145
3246 OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE
3347
48 ** Tactic extensions
49
50 - printers have an extra parameter which is a constr printer at high precedence
51 - the tactic printers have an extra arg which is the expected precedence
52 - level is now a precedence in declare_extra_tactic_pprule
53 - "interp" functions now of types the actual arg type, not its encapsulation
54 as a generic_argument
3455
3556 =========================================
3657 = CHANGES BETWEEN COQ V7.4 AND COQ V8.0 =
+9
-3
doc/Makefile less more
109109 refman/RefMan-mod.v.tex refman/RefMan-tac.v.tex \
110110 refman/RefMan-cic.v.tex refman/RefMan-lib.v.tex \
111111 refman/RefMan-tacex.v.tex refman/RefMan-syn.v.tex \
112 refman/RefMan-oth.v.tex \
112 refman/RefMan-oth.v.tex refman/RefMan-ltac.v.tex \
113113 refman/Cases.v.tex refman/Coercion.v.tex refman/Extraction.v.tex \
114114 refman/Program.v.tex refman/Omega.v.tex refman/Polynom.v.tex \
115115 refman/Setoid.v.tex refman/Helm.tex # refman/Natural.v.tex
118118 refman/headers.tex \
119119 refman/Reference-Manual.tex refman/RefMan-pre.tex \
120120 refman/RefMan-int.tex refman/RefMan-pro.tex \
121 refman/RefMan-com.tex refman/RefMan-ltac.tex \
121 refman/RefMan-com.tex \
122122 refman/RefMan-uti.tex refman/RefMan-ide.tex \
123123 refman/RefMan-add.tex refman/RefMan-modr.tex \
124124 $(REFMANCOQTEXFILES) \
160160 mkdir refman/html
161161 cp $(REFMANPNGFILES) refman/html
162162 (cd refman/html; hacha -o toc.html ../Reference-Manual.html)
163 cp refman/cover.html refman/html
163 cp refman/cover.html refman/menu.html refman/html
164164 cp refman/index.html refman/html
165
166 refman-quick:
167 (cd refman; \
168 $(PDFLATEX) Reference-Manual.tex; \
169 hevea -fix -exec xxdate.exe ./Reference-Manual.tex)
170
165171
166172 ######################################################################
167173 # Tutorial
+4
-1
doc/common/macros.tex less more
160160 \newcommand{\form}{\textrm{\textsl{form}}}
161161 \newcommand{\entry}{\textrm{\textsl{entry}}}
162162 \newcommand{\proditem}{\textrm{\textsl{production\_item}}}
163 \newcommand{\taclevel}{\textrm{\textsl{tactic\_level}}}
163164 \newcommand{\tacargtype}{\textrm{\textsl{tactic\_argument\_type}}}
164165 \newcommand{\scope}{\textrm{\textsl{scope}}}
165166 \newcommand{\optscope}{\textrm{\textsl{opt\_scope}}}
181182 \newcommand{\name}{\textrm{\textsl{name}}}
182183 \newcommand{\num}{\textrm{\textsl{num}}}
183184 \newcommand{\pattern}{\textrm{\textsl{pattern}}}
185 \newcommand{\orpattern}{\textrm{\textsl{or\_pattern}}}
184186 \newcommand{\intropattern}{\textrm{\textsl{intro\_pattern}}}
185187 \newcommand{\pat}{\textrm{\textsl{pat}}}
186188 \newcommand{\pgs}{\textrm{\textsl{pgms}}}
199201 \newcommand{\str}{\textrm{\textsl{string}}}
200202 \newcommand{\subsequentletter}{\textrm{\textsl{subsequent\_letter}}}
201203 \newcommand{\switch}{\textrm{\textsl{switch}}}
204 \newcommand{\messagetoken}{\textrm{\textsl{message\_token}}}
202205 \newcommand{\tac}{\textrm{\textsl{tactic}}}
203206 \newcommand{\terms}{\textrm{\textsl{terms}}}
204207 \newcommand{\term}{\textrm{\textsl{term}}}
487490 {\begin{center}\begin{rulebox}}
488491 {\end{rulebox}\end{center}}
489492
490 % $Id: macros.tex 8606 2006-02-23 13:58:10Z herbelin $
493 % $Id: macros.tex 9038 2006-07-11 13:53:53Z herbelin $
491494
492495
493496 %%% Local Variables:
+71
-22
doc/refman/Cases.tex less more
00 \achapter{Extended pattern-matching}\defaultheaders
1 \aauthor{Cristina Cornes}
1 \aauthor{Cristina Cornes and Hugo Herbelin}
22
33 \label{Mult-match-full}
44 \ttindex{Cases}
1616 letter.
1717
1818 If a pattern has the form $(c~\vec{x})$ where $c$ is a constructor
19 symbol and $\vec{x}$ is a linear vector of variables, it is called
20 {\em simple}: it is the kind of pattern recognized by the basic
21 version of {\tt match}. If a pattern is
22 not simple we call it {\em nested}.
19 symbol and $\vec{x}$ is a linear vector of (distinct) variables, it is
20 called {\em simple}: it is the kind of pattern recognized by the basic
21 version of {\tt match}. On the opposite, if it is a variable $x$ or
22 has the form $(c~\vec{p})$ with $p$ not only made of variables, the
23 pattern is called {\em nested}.
2324
2425 A variable pattern matches any value, and the identifier is bound to
2526 that value. The pattern ``\texttt{\_}'' (called ``don't care'' or
26 ``wildcard'' symbol) also matches any value, but does not bind anything. It
27 may occur an arbitrary number of times in a pattern. Alias patterns
28 written \texttt{(}{\sl pattern} \texttt{as} {\sl identifier}\texttt{)} are
29 also accepted. This pattern matches the same values as {\sl pattern}
30 does and {\sl identifier} is bound to the matched value. A list of
31 patterns separated with commas
32 is also considered as a pattern and is called {\em multiple
33 pattern}.
27 ``wildcard'' symbol) also matches any value, but does not bind
28 anything. It may occur an arbitrary number of times in a
29 pattern. Alias patterns written \texttt{(}{\sl pattern} \texttt{as}
30 {\sl identifier}\texttt{)} are also accepted. This pattern matches the
31 same values as {\sl pattern} does and {\sl identifier} is bound to the
32 matched value.
33 A pattern of the form {\pattern}{\tt |}{\pattern} is called
34 disjunctive. A list of patterns separated with commas is also
35 considered as a pattern and is called {\em multiple pattern}. However
36 multiple patterns can only occur at the root of pattern-matching
37 equations. Disjunctions of {\em multiple pattern} are allowed though.
3438
3539 Since extended {\tt match} expressions are compiled into the primitive
3640 ones, the expressiveness of the theory remains the same. Once the
37 stage of parsing has finished only simple patterns remain. An easy way
38 to see the result of the expansion is by printing the term with
39 \texttt{Print} if the term is a constant, or using the command
41 stage of parsing has finished only simple patterns remain. Re-nesting
42 of pattern is performed at printing time. An easy way to see the
43 result of the expansion is to toggle off the nesting performed at
44 printing (use here {\tt Set Printing Matching}), then by printing the term
45 with \texttt{Print} if the term is a constant, or using the command
4046 \texttt{Check}.
4147
4248 The extended \texttt{match} still accepts an optional {\em elimination
4349 predicate} given after the keyword \texttt{return}. Given a pattern
44 matching expression, if all the right hand sides of \texttt{=>} ({\em
50 matching expression, if all the right-hand-sides of \texttt{=>} ({\em
4551 rhs} in short) have the same type, then this type can be sometimes
4652 synthesized, and so we can omit the \texttt{return} part. Otherwise
4753 the predicate after \texttt{return} has to be provided, like for the basic
6369 end.
6470 \end{coq_example}
6571
66 Using multiple patterns in the definition allows to write:
72 \paragraph{Multiple patterns}
73
74 Using multiple patterns in the definition of {\tt max} allows to write:
6775
6876 \begin{coq_example}
6977 Reset max.
8896 end).
8997 \end{coq_example}
9098
91 We can also use ``\texttt{as} patterns'' to associate a name to a
99 \paragraph{Aliasing subpatterns}
100
101 We can also use ``\texttt{as} {\ident}'' to associate a name to a
92102 sub-pattern:
93103
94104 \begin{coq_example}
100110 | S n', S m' => S (max n' m')
101111 end.
102112 \end{coq_example}
113
114 \paragraph{Nested patterns}
103115
104116 Here is now an example of nested patterns:
105117
156168 end.
157169 \end{coq_example}
158170
159
160171 Here the last pattern superposes with the first two. Because
161172 of the priority rule, the last pattern
162173 will be used only for values that do not match neither the first nor
179190 end).
180191 \end{coq_example}
181192
193 \paragraph{Disjunctive patterns}
194
195 Multiple patterns that share the same right-hand-side can be
196 factorized using the notation \nelist{\multpattern}{\tt |}. For instance,
197 {\tt max} can be rewritten as follows:
198
199 \begin{coq_eval}
200 Reset max.
201 \end{coq_eval}
202 \begin{coq_example}
203 Fixpoint max (n m:nat) {struct m} : nat :=
204 match n, m with
205 | S n', S m' => S (max n' m')
206 | 0, p | p, 0 => p
207 end.
208 \end{coq_example}
209
210 Similarly, factorization of (non necessary multiple) patterns
211 that share the same variables is possible by using the notation
212 \nelist{\pattern}{\tt |}. Here is an example:
213
214 \begin{coq_example}
215 Definition filter_2_4 (n:nat) : nat :=
216 match n with
217 | 2 as m | 4 as m => m
218 | _ => 0
219 end.
220 \end{coq_example}
221
222 Here is another example using disjunctive subpatterns.
223
224 \begin{coq_example}
225 Definition filter_some_square_corners (p:nat*nat) : nat*nat :=
226 match p with
227 | ((2 as m | 4 as m), (3 as n | 5 as n)) => (m,n)
228 | _ => (0,0)
229 end.
230 \end{coq_example}
231
182232 \asection{About patterns of parametric types}
183233 When matching objects of a parametric type, constructors in patterns
184234 {\em do not expect} the parameter arguments. Their value is deduced
185235 during expansion.
186
187 Consider for example the polymorphic lists:
236 Consider for example the type of polymorphic lists:
188237
189238 \begin{coq_example}
190239 Inductive List (A:Set) : Set :=
+159
-28
doc/refman/RefMan-cic.tex less more
217217 written $x:=t:T$. We use brackets to write contexts. A
218218 typical example is $[x:T;y:=u:U;z:V]$. Notice that the variables
219219 declared in a context must be distinct. If $\Gamma$ declares some $x$,
220 we write $x \in\Gamma$. By writing $(x:T)\in\Gamma$ we mean that
220 we write $x \in \Gamma$. By writing $(x:T) \in \Gamma$ we mean that
221221 either $x:T$ is an assumption in $\Gamma$ or that there exists some $t$ such
222222 that $x:=t:T$ is a definition in $\Gamma$. If $\Gamma$ defines some
223 $x:=t:T$, we also write $(x:=t:T)\in\Gamma$. Contexts must be
223 $x:=t:T$, we also write $(x:=t:T) \in \Gamma$. Contexts must be
224224 themselves {\em well formed}. For the rest of the chapter, the
225225 notation $\Gamma::(y:T)$ (resp. $\Gamma::(y:=t:T)$) denotes the context
226226 $\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The
232232
233233 We define the inclusion of two contexts $\Gamma$ and $\Delta$ (written
234234 as $\Gamma \subset \Delta$) as the property, for all variable $x$,
235 type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T)\in \Delta$
236 and if $(x:=t:T) \in \Gamma$ then $(x:=t:T)\in \Delta$.
235 type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T) \in \Delta$
236 and if $(x:=t:T) \in \Gamma$ then $(x:=t:T) \in \Delta$.
237237 %We write
238238 % $|\Delta|$ for the length of the context $\Delta$, that is for the number
239239 % of declarations (assumptions or definitions) in $\Delta$.
287287 \begin{description}
288288 \item[W-E] \inference{\WF{[]}{[]}}
289289 \item[W-S] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma
290 \inference{\frac{\WTEG{T}{s}~~~~s\in \Sort~~~~x \not\in
290 \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in
291291 \Gamma % \cup E
292292 }
293293 {\WFE{\Gamma::(x:T)}}~~~~~
294294 \frac{\WTEG{t}{T}~~~~x \not\in
295295 \Gamma % \cup E
296296 }{\WFE{\Gamma::(x:=t:T)}}}
297 \item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E\cup \Gamma}
297 \item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E \cup \Gamma}
298298 {\WF{E;\Def{\Gamma}{c}{t}{T}}{\Gamma}}}
299 \item[Assum] \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~c \notin E \cup \Gamma}
300 {\WF{E;\Assum{\Gamma}{c}{T}}{\Gamma}}}
299301 \item[Ax] \index{Typing rules!Ax}
300302 \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(p)}}~~~~~
301303 \frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(q)}}}
302304 \inference{\frac{\WFE{\Gamma}~~~~i<j}{\WTEG{\Type(i)}{\Type(j)}}}
303305 \item[Var]\index{Typing rules!Var}
304 \inference{\frac{ \WFE{\Gamma}~~~~~(x:T)\in\Gamma~~\mbox{or}~~(x:=t:T)\in\Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}}
306 \inference{\frac{ \WFE{\Gamma}~~~~~(x:T) \in \Gamma~~\mbox{or}~~(x:=t:T) \in \Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}}
305307 \item[Const] \index{Typing rules!Const}
306 \inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E}{\WTEG{c}{T}}}
308 \inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E~~\mbox{or}~~(c:=t:T) \in E~\mbox{for some $t$} }{\WTEG{c}{T}}}
307309 \item[Prod] \index{Typing rules!Prod}
308310 \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~
309311 \WTE{\Gamma::(x:T)}{U}{\Prop}}
310312 { \WTEG{\forall~x:T,U}{\Prop}}}
311 \inference{\frac{\WTEG{T}{s}~~~~s\in\{\Prop, \Set\}~~~~~~
313 \inference{\frac{\WTEG{T}{s}~~~~s \in\{\Prop, \Set\}~~~~~~
312314 \WTE{\Gamma::(x:T)}{U}{\Set}}
313315 { \WTEG{\forall~x:T,U}{\Set}}}
314316 \inference{\frac{\WTEG{T}{\Type(i)}~~~~i\leq k~~~
372374 that is to expand (or unfold) it into its value. This
373375 reduction is called $\delta$-reduction and shows as follows.
374376
375 $$\WTEGRED{x}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(x:=t:T)\in\Gamma$}~~~~~~~~~\WTEGRED{c}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(c:=t:T)\in E$}$$
377 $$\WTEGRED{x}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(x:=t:T) \in \Gamma$}~~~~~~~~~\WTEGRED{c}{\triangleright_{\delta}}{t}~~~~~\mbox{if $(c:=t:T) \in E$}$$
376378
377379
378380 \paragraph{$\zeta$-reduction.}
552554 \List}\]
553555 Assuming
554556 $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is
555 $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are:
557 $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are,
558 for $1\leq j\leq k$ and $1\leq i\leq n$:
556559
557560 \bigskip
558 \inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E
559 ~~j=1\ldots k}{(I_j:A_j) \in E}}
560
561 \inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E
562 ~~~~i=1.. n}
563 {(c_i:C_i)\in E}}
561 \inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}}
562
563 \inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}}
564564
565565 \subsubsection{Inductive definitions with parameters}
566566
592592 with $I$ one of the inductive definitions in $\Gamma_I$.
593593 We say that $n$ is the number of real arguments of the constructor
594594 $c$.
595 \paragraph{Context of parameters}
595 \paragraph{Context of parameters.}
596596 If an inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits
597597 $r$ inductive parameters, then there exists a context $\Gamma_P$ of
598 size $r$, such that $\Gamma_P=p_1:P_1;\ldots;\forall p_r:P_r$ and
599 if $(t:A)\in\Gamma_I,\Gamma_C$ then $A$ can be written as
598 size $r$, such that $\Gamma_P=p_1:P_1;\ldots;p_r:P_r$ and
599 if $(t:A) \in \Gamma_I,\Gamma_C$ then $A$ can be written as
600600 $\forall p_1:P_1,\ldots \forall p_r:P_r,A'$.
601601 We call $\Gamma_P$ the context of parameters of the inductive
602602 definition and use the notation $\forall \Gamma_P,A'$ for the term $A$.
740740
741741 \inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E
742742 ~~~~i=1.. n}
743 {(c_i:C_i)\in E}}
743 {(c_i:C_i) \in E}}
744744 \end{description}
745745
746746 \paragraph{Example.}
847847 \begin{description}
848848 \item[W-Ind] Let $E$ be an environment and
849849 $\Gamma,\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that
850 $\Gamma_I$ is $[I_1:\forall \Gamma_p,A_1;\ldots;I_k:\forall
850 $\Gamma_I$ is $[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall
851851 \Gamma_P,A_k]$ and $\Gamma_C$ is
852 $[c_1:\forall \Gamma_p,C_1;\ldots;c_n:\forall \Gamma_p,C_n]$.
852 $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$.
853853 \inference{
854854 \frac{
855855 (\WTE{\Gamma;\Gamma_P}{A_j}{s'_j})_{j=1\ldots k}
856856 ~~ (\WTE{\Gamma;\Gamma_I;\Gamma_P}{C_i}{s_{p_i}})_{i=1\ldots n}
857857 }
858858 {\WF{E;\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}}
859 providing the following side conditions hold:
859 provided that the following side conditions hold:
860860 \begin{itemize}
861861 \item $k>0$, $I_j$, $c_i$ are different names for $j=1\ldots k$ and $i=1\ldots n$,
862862 \item $p$ is the number of parameters of \NInd{\Gamma}{\Gamma_I}{\Gamma_C}
873873 constructors which will always be satisfied for the impredicative sort
874874 (\Prop) but may fail to define inductive definition
875875 on sort \Set{} and generate constraints between universes for
876 inductive definitions in types.
876 inductive definitions in the {\Type} hierarchy.
877877
878878 \paragraph{Examples.}
879879 It is well known that existential quantifier can be encoded as an
906906 %is recursive or not. We shall write the type $(x:_R T)C$ if it is
907907 %a recursive argument and $(x:_P T)C$ if the argument is not recursive.
908908
909 \paragraph{Sort-polymorphism of inductive families.}
910 \index{Sort-polymorphism of inductive families}
911
912 From {\Coq} version 8.1, inductive families declared in {\Type} are
913 polymorphic over their arguments in {\Type}.
914
915 If $A$ is an arity and $s$ a sort, we write $A_{/s}$ for the arity
916 obtained from $A$ by replacing its sort with $s$. Especially, if $A$
917 is well-typed in some environment and context, then $A_{/s}$ is typable
918 by typability of all products in the Calculus of Inductive Constructions.
919 The following typing rule is added to the theory.
920
921 \begin{description}
922 \item[Ind-Family] Let $\Gamma_P$ be a context of parameters
923 $[p_1:P_1;\ldots;p_{m'}:P_{m'}]$ and $m\leq m'$ be the length of the
924 initial prefix of parameters that occur unchanged in the recursive
925 occurrences of the constructor types. Assume that $\Gamma_I$ is
926 $[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ and
927 $\Gamma_C$ is $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall
928 \Gamma_P,C_n]$.
929
930 Let $q_1$, \ldots, $q_r$, with $0\leq r\leq m$, be a possibly partial
931 instantiation of the parameters in $\Gamma_P$. We have:
932
933 \inference{\frac
934 {\left\{\begin{array}{l}
935 \Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E\\
936 (E[\Gamma] \vdash q_s : P'_s)_{s=1\ldots r}\\
937 (E[\Gamma] \vdash \WTEGLECONV{P'_s}{\subst{P_s}{x_u}{q_u}_{u=1\ldots s-1}})_{s=1\ldots r}\\
938 1 \leq j \leq k
939 \end{array}
940 \right.}
941 {(I_j\,q_1\,\ldots\,q_r:\forall \Gamma^{r+1}_p, (A_j)_{/s})}
942 }
943
944 provided that the following side conditions hold:
945
946 \begin{itemize}
947 \item $\Gamma_{P'}$ is the context obtained from $\Gamma_P$ by
948 replacing, each $P_s$ that is an arity with the
949 sort of $P'_s$, as soon as $1\leq s \leq r$ (notice that
950 $P_s$ arity implies $P'_s$ arity since $E[\Gamma]
951 \vdash \WTEGLECONV{P'_s}{ \subst{P_s}{x_u}{q_u}_{u=1\ldots s-1}}$);
952 \item there are sorts $s_i$, for $1 \leq i \leq k$ such that, for
953 $\Gamma_{I'}$ obtained from $\Gamma_I$ by changing each $A_i$ by $(A_i)_{/s_i}$,
954 we have $(\WTE{\Gamma;\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{p_i}})_{i=1\ldots n}$;
955 \item the sorts are such that all elimination are allowed (see
956 section~\ref{elimdep}).
957 \end{itemize}
958 \end{description}
959
960 Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf
961 Ind-Const} and {\bf App}, then it is typable using the rule {\bf
962 Ind-Family}. Conversely, the extended theory is not stronger than the
963 theory without {\bf Ind-Family}. We get an equiconsistency result by
964 mapping each $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ occurring into a
965 given derivation into as many fresh inductive types and constructors
966 as the number of different (partial) replacements of sorts, needed for
967 this derivation, in the parameters that are arities. That is, the
968 changes in the types of each partial instance $q_1\,\ldots\,q_r$ can
969 be characterized by the ordered sets of arity sorts among the types of
970 parameters, and to each signature is associated a new inductive
971 definition with fresh names. Conversion is preserved as any (partial)
972 instance $I_j\,q_1\,\ldots\,q_r$ or $C_i\,q_1\,\ldots\,q_r$ is mapped
973 to the names chosen in the specific instance of
974 $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$.
975
976 \newcommand{\Single}{\mbox{\textsf{Set}}}
977
978 In practice, the rule is used by {\Coq} only with in case the
979 inductive type is declared with an arity of a sort in the $\Type$
980 hierarchy, and, then, the polymorphism is over the parameters whose
981 type is an arity in the {\Type} hierarchy. The sort $s_j$ are then
982 chosen canonically so that each $s_j$ is minimal with respect to the
983 hierarchy ${\Prop_u}\subset{\Set_p}\subset\Type$ where $\Set_p$ is
984 predicative {\Set}, and ${\Prop_u}$ is the sort of small singleton
985 inductive types (i.e. of inductive types with one single constructor
986 and that contains either proofs or inhabitants of singleton types
987 only). More precisely, a small singleton inductive family is set in
988 {\Prop}, a small non singleton inductive family is set in {\Set} (even
989 in case {\Set} is impredicative -- see section~\ref{impredicativity}),
990 and otherwise in the {\Type} hierarchy.
991 % TODO: clarify the case of a partial application ??
992
993 Note that the side-condition about allowed elimination sorts in the
994 rule~{\bf Ind-Family} is just to avoid to recompute the allowed
995 elimination sorts at each instance of a pattern-matching (see
996 section~\ref{elimdep}).
997
998 As an example, let us consider the following definition:
999 \begin{coq_example*}
1000 Inductive option (A:Type) : Type :=
1001 | None : option A
1002 | Some : A -> option A.
1003 \end{coq_example*}
1004
1005 As the definition is set in the {\Type} hierarchy, it is used
1006 polymorphically over its parameters whose types are arities of a sort
1007 in the {\Type} hierarchy. Here, the parameter $A$ has this property,
1008 hence, if \texttt{option} is applied to a type in {\Set}, the result is
1009 in {\Set}. Note that if \texttt{option} is applied to a type in {\Prop},
1010 then, the result is not set in \texttt{Prop} but in \texttt{Set}
1011 still. This is because \texttt{option} is not a singleton type (see
1012 section~\ref{singleton}) and it would loose the elimination to {\Set} and
1013 {\Type} if set in {\Prop}.
1014
1015 \begin{coq_example}
1016 Check (fun A:Set => option A).
1017 Check (fun A:Prop => option A).
1018 \end{coq_example}
1019
1020 Here is another example.
1021
1022 \begin{coq_example*}
1023 Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
1024 \end{coq_example*}
1025
1026 As \texttt{prod} is a singleton type, it will be in {\Prop} if applied
1027 twice to propositions, in {\Set} if applied twice to at least one type
1028 in {\Set} and none in {\Type}, and in {\Type} otherwise. In all cases,
1029 the three kind of eliminations schemes are allowed.
1030
1031 \begin{coq_example}
1032 Check (fun A:Set => prod A).
1033 Check (fun A:Prop => prod A A).
1034 Check (fun (A:Prop) (B:Set) => prod A B).
1035 Check (fun (A:Type) (B:Prop) => prod A B).
1036 \end{coq_example}
1037
9091038 \subsection{Destructors}
9101039 The specification of inductive definitions with arities and
9111040 constructors is quite natural. But we still have to say how to use an
10481177 % \mbox{\tt =>}~ \false}
10491178
10501179 \paragraph{Allowed elimination sorts.}
1180
10511181 \index{Elimination sorts}
10521182
10531183 An important question for building the typing rule for \kw{match} is
11571287 %{\tt Program} tactic or when extracting ML programs.
11581288
11591289 \paragraph{Empty and singleton elimination}
1290 \label{singleton}
11601291 \index{Elimination!Singleton elimination}
11611292 \index{Elimination!Empty elimination}
11621293
11661297 \item[\Prop-extended]
11671298 \inference{
11681299 \frac{I \mbox{~is an empty or singleton
1169 definition}~~~s\in\Sort}{\compat{I:\Prop}{I\ra s}}
1300 definition}~~~s \in \Sort}{\compat{I:\Prop}{I\ra s}}
11701301 }
11711302 \end{description}
11721303
15291660 in the sort \Set, which is extended to a domain in any sort~:
15301661 \begin{description}
15311662 \item [Prod] \index{Typing rules!Prod (impredicative Set)}
1532 \inference{\frac{\WTEG{T}{s}~~~~s\in\Sort~~~~~~
1663 \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~~~
15331664 \WTE{\Gamma::(x:T)}{U}{\Set}}
15341665 { \WTEG{\forall~x:T,U}{\Set}}}
15351666 \end{description}
15521683
15531684
15541685
1555 % $Id: RefMan-cic.tex 8914 2006-06-07 14:57:22Z cpaulin $
1686 % $Id: RefMan-cic.tex 9001 2006-07-04 13:50:15Z herbelin $
15561687
15571688 %%% Local Variables:
15581689 %%% mode: latex
+7
-1
doc/refman/RefMan-com.tex less more
8585
8686 \section{Options}
8787 \index{Options of the command line}
88 \label{vmoption}
8889
8990 The following command-line options are recognized by the commands {\tt
9091 coqc} and {\tt coqtop}, unless stated otherwise:
237238 This avoids loading in memory the proofs of opaque theorems
238239 resulting in a smaller memory requirement and faster compilation;
239240 warning: this invalidates some features such as the extraction tool.
241
242 \item[{\tt -vm}]\
243
244 This activates the use of the bytecode-based conversion algorithm
245 for the current session (see section~\ref{SetVirtualMachine}).
240246
241247 \item[{\tt -image} {\em file}]\
242248
271277 % (see section~\ref{coqsearchisos}, page~\pageref{coqsearchisos}).
272278 % \end{description}
273279
274 % $Id: RefMan-com.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $
280 % $Id: RefMan-com.tex 9044 2006-07-12 13:22:17Z herbelin $
275281
276282 %%% Local Variables:
277283 %%% mode: latex
+49
-7
doc/refman/RefMan-ext.tex less more
222222 \label{Mult-match}}
223223
224224 The basic version of \verb+match+ allows pattern-matching on simple
225 patterns. As an extension, multiple and nested patterns are
226 allowed, as in ML-like languages.
225 patterns. As an extension, multiple nested patterns or disjunction of
226 patterns are allowed, as in ML-like languages.
227227
228228 The extension just acts as a macro that is expanded during parsing
229229 into a sequence of {\tt match} on simple patterns. Especially, a
230 construction defined using the extended {\tt match} is printed under
231 its expanded form.
230 construction defined using the extended {\tt match} is generally
231 printed under its expanded form (see~\texttt{Set Printing Matching} in
232 section~\ref{SetPrintingMatching}).
232233
233234 \SeeAlso chapter \ref{Mult-match-full}.
234235
329330 $\equiv$~
330331 {\tt match {\term} \zeroone{\ifitem} with C {\ident}$_1$ {\ldots} {\ident}$_n$ \verb!=>! {\term}' end}
331332
332 \subsection{Options for pretty-printing of {\tt match}
333 \subsection{Controlling pretty-printing of {\tt match} expressions
333334 \label{printing-options}}
334335
335 There are three options controlling the pretty-printing of {\tt match}
336 expressions.
336 The following commands give some control over the pretty-printing of
337 {\tt match} expressions.
338
339 \subsubsection{Printing nested patterns
340 \label{SetPrintingMatching}
341 \comindex{Set Printing Matching}
342 \comindex{Unset Printing Matching}
343 \comindex{Test Printing Matching}}
344
345 The Calculus of Inductive Constructions knows pattern-matching only
346 over simple patterns. It is however convenient to re-factorize nested
347 pattern-matching into a single pattern-matching over a nested pattern.
348 {\Coq}'s printer try to do such limited re-factorization.
349
350 \begin{quote}
351 {\tt Set Printing Matching.}
352 \end{quote}
353 This tells {\Coq} to try to use nested patterns. This is the default
354 behavior.
355
356 \begin{quote}
357 {\tt Unset Printing Matching.}
358 \end{quote}
359 This tells {\Coq} to print only simple pattern-matching problems in
360 the same way as the {\Coq} kernel handles them.
361
362 \begin{quote}
363 {\tt Test Printing Matching.}
364 \end{quote}
365 This tells if the printing matching mode is on or off. The default is
366 on.
337367
338368 \subsubsection{Printing of wildcard pattern
339369 \comindex{Set Printing Wildcard}
10871117 \SeeAlso more examples in user contribution \texttt{category}
10881118 (\texttt{Rocq/ALGEBRA}).
10891119
1120 \subsubsection{Print Canonical Projections.
1121 \comindex{Print Canonical Projections}}
1122
1123 This displays the list of global names that are components of some
1124 canonical structure. For each of them, the canonical structure of
1125 which it is a projection is indicated. For instance, the above example
1126 gives the following output:
1127
1128 \begin{coq_example}
1129 Print Canonical Projections.
1130 \end{coq_example}
1131
10901132 \subsection{Implicit types of variables}
10911133
10921134 It is possible to bind variable names to a given type (e.g. in a
+131
-109
doc/refman/RefMan-gal.tex less more
6363 \begin{center}
6464 \begin{tabular}{rcl}
6565 {\firstletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt \_}
66 % $\mid$ {\tt unicode-letter}
66 $\mid$ {\tt unicode-letter}
6767 \\
6868 {\subsequentletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt 0..9}
6969 $\mid$ {\tt \_} % $\mid$ {\tt \$}
70 $\mid$ {\tt '} \\
70 $\mid$ {\tt '}
71 $\mid$ {\tt unicode-letter}
72 $\mid$ {\tt unicode-id-part} \\
7173 {\ident} & ::= & {\firstletter} \sequencewithoutblank{\subsequentletter}{}
7274 \end{tabular}
7375 \end{center}
74 All characters are meaningful. In particular, identifiers are case-sensitive.
76 All characters are meaningful. In particular, identifiers are
77 case-sensitive. The entry {\tt unicode-letter} non-exhaustively
78 includes Latin, Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian,
79 Hangul, Hiragana and Katakana characters, CJK ideographs, mathematical
80 letter-like symbols, hyphens, non-breaking space, {\ldots} The entry
81 {\tt unicode-id-part} non-exhaustively includes symbols for prime
82 letters and subscripts.
83
7584 Access identifiers, written {\accessident}, are identifiers prefixed
7685 by \verb!.! (dot) without blank. They are used in the syntax of qualified
7786 identifiers.
307316 &&\\
308317 {\returntype} & ::= & {\tt return} {\term} \\
309318 &&\\
310 {\eqn} & ::= & \nelist{\pattern}{\tt ,} {\tt =>} {\term}\\
319 {\eqn} & ::= & \nelist{\multpattern}{\tt |} {\tt =>} {\term}\\
320 &&\\
321 {\multpattern} & ::= & \nelist{\pattern}{\tt ,}\\
311322 &&\\
312323 {\pattern} & ::= & {\qualid} \nelist{\pattern}{} \\
313324 & $|$ & {\pattern} {\tt as} {\ident} \\
315326 & $|$ & {\qualid} \\
316327 & $|$ & {\tt \_} \\
317328 & $|$ & {\num} \\
318 & $|$ & {\tt (} \nelist{\pattern}{,} {\tt )}
329 & $|$ & {\tt (} \nelist{\orpattern}{,} {\tt )} \\
330 \\
331 {\orpattern} & ::= & \nelist{\pattern}{\tt |}\\
319332 \end{tabular}
320333 \end{centerframe}
321334 \caption{Syntax of terms (continued)}
514527 {\pattern$_1$} {\tt =>} {\term$_1$} {\tt $|$} {\ldots} {\tt $|$}
515528 {\pattern$_n$} {\tt =>} {\term$_n$} {\tt end}, denotes a {\em
516529 pattern-matching} over the term {\term$_0$} (expected to be of an
517 inductive type $I$). {\term$_1$}\ldots{\term$_n$} are called branches. In
530 inductive type $I$).
531 The terms {\term$_1$}\ldots{\term$_n$} are called branches. In
518532 a simple pattern \qualid~\nelist{\ident}{}, the qualified identifier
519533 {\qualid} is intended to
520 be a constructor. There should be a branch for every constructor of
534 be a constructor. There should be one branch for every constructor of
521535 $I$.
522536
523537 The {\returntype} is used to compute the resulting type of the whole
529543 match} depends on the actual {\term$_0$} matched.
530544
531545 There are specific notations for case analysis on types with one or
532 two constructors: {\tt if / then / else} and
533 {\tt let (}\ldots{\tt ) :=} \ldots {\tt in}\ldots. \SeeAlso
534 section~\ref{Mult-match} for details and examples.
546 two constructors: {\tt if {\ldots} then {\ldots} else {\ldots}} and
547 {\tt let (}\nelist{\ldots}{,}{\tt ) :=} {\ldots} {\tt in} {\ldots}.
535548
536549 \SeeAlso Section~\ref{Mult-match} for details and examples.
537550
760773 {\binder$_1$}\ldots{\binder$_n$}{\tt ,}\,\term$_1$\,{\tt :=}}\,%
761774 {\tt fun}\,{\binder$_1$}\ldots{\binder$_n$}\,{\tt =>}\,{\term$_2$}\,%
762775 {\tt .}
776
777 \item {\tt Example {\ident} := {\term}.}\\
778 {\tt Example {\ident} {\tt :}{\term$_1$} := {\term$_2$}.}\\
779 {\tt Example {\ident} {\binder$_1$}\ldots{\binder$_n$}
780 {\tt :}\term$_1$ {\tt :=} {\term$_2$}.}\\
781 \comindex{Example}
782 These are synonyms of the {\tt Definition} forms.
763783 \end{Variants}
764784
765785 \begin{ErrMsgs}
766 \item \errindex{In environment {\dots} the term: {\term$_2$} does not have type
767 {\term$_1$}}.\\
768 \texttt{Actually, it has type {\term$_3$}}.
786 \item \errindex{Error: The term ``{\term}'' has type "{\type}" while it is expected to have type ``{\type}''}
769787 \end{ErrMsgs}
770788
771789 \SeeAlso Sections \ref{Opaque}, \ref{Transparent}, \ref{unfold}
10611079
10621080 \medskip
10631081 {\tt
1064 Inductive {{\ident$_1$} {\params} : {\type$_1$} := \\
1065 \mbox{}\hspace{0.4cm} {\ident$_1^1$} : {\type$_1^1$} \\
1066 \mbox{}\hspace{0.1cm}| .. \\
1067 \mbox{}\hspace{0.1cm}| {\ident$_{n_1}^1$} : {\type$_{n_1}^1$} \\
1082 \begin{tabular}{l}
1083 Inductive {\ident$_1$} {\params} : {\type$_1$} := \\
1084 \begin{tabular}{clcl}
1085 & {\ident$_1^1$} &:& {\type$_1^1$} \\
1086 | & {\ldots} && \\
1087 | & {\ident$_{n_1}^1$} &:& {\type$_{n_1}^1$}
1088 \end{tabular} \\
10681089 with\\
1069 \mbox{}\hspace{0.1cm} .. \\
1090 ~{\ldots} \\
10701091 with {\ident$_m$} {\params} : {\type$_m$} := \\
1071 \mbox{}\hspace{0.4cm}{\ident$_1^m$} : {\type$_1^m$} \\
1072 \mbox{}\hspace{0.1cm}| .. \\
1073 \mbox{}\hspace{0.1cm}| {\ident$_{n_m}^m$} : {\type$_{n_m}^m$}.
1074 }}
1092 \begin{tabular}{clcl}
1093 & {\ident$_1^m$} &:& {\type$_1^m$} \\
1094 | & {\ldots} \\
1095 | & {\ident$_{n_m}^m$} &:& {\type$_{n_m}^m$}.
1096 \end{tabular}
1097 \end{tabular}
1098 }
10751099 \medskip
10761100
10771101 \Example
11831207 %%
11841208 \subsection{Definition of recursive functions}
11851209
1186 \subsubsection{\tt Fixpoint {\ident} {\params} {\tt \{struct}
1210 \subsubsection{Recursive functions over a inductive type}
1211
1212 The command:
1213 \begin{center}
1214 \texttt{Fixpoint {\ident} {\params} {\tt \{struct}
11871215 \ident$_0$ {\tt \}} : type$_0$ := \term$_0$
1188 \comindex{Fixpoint}
1189 \label{Fixpoint}}
1190
1191 This command allows to define inductive objects using a fixed point
1192 construction. The meaning of this declaration is to define {\it ident}
1193 a recursive function with arguments specified by the binders in
1194 \params{} % {\binder$_1$}\ldots{\binder$_n$}
1195 such that {\it ident} applied to
1196 arguments corresponding to these binders has type \type$_0$, and is
1197 equivalent to the expression \term$_0$. The type of the {\ident} is
1198 consequently {\tt forall {\params} {\tt,} \type$_0$}
1199 and the value is equivalent to {\tt fun {\params} {\tt =>} \term$_0$}.
1216 \comindex{Fixpoint}\label{Fixpoint}}
1217 \end{center}
1218 allows to define inductive objects using a fixed point construction.
1219 The meaning of this declaration is to define {\it ident} a recursive
1220 function with arguments specified by the binders in {\params} such
1221 that {\it ident} applied to arguments corresponding to these binders
1222 has type \type$_0$, and is equivalent to the expression \term$_0$. The
1223 type of the {\ident} is consequently {\tt forall {\params} {\tt,}
1224 \type$_0$} and the value is equivalent to {\tt fun {\params} {\tt
1225 =>} \term$_0$}.
12001226
12011227 To be accepted, a {\tt Fixpoint} definition has to satisfy some
12021228 syntactical constraints on a special argument called the decreasing
12041230 always terminates. The point of the {\tt \{struct \ident {\tt \}}}
12051231 annotation is to let the user tell the system which argument decreases
12061232 along the recursive calls. This annotation may be left implicit for
1207 fixpoints with one argument. For instance, one can define the addition
1208 function as :
1233 fixpoints where only one argument has an inductive type. For instance,
1234 one can define the addition function as :
12091235
12101236 \begin{coq_example}
12111237 Fixpoint add (n m:nat) {struct n} : nat :=
13221348 A generic command {\tt Scheme} is useful to build automatically various
13231349 mutual induction principles. It is described in Section~\ref{Scheme}.
13241350
1325 \subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1326 {\tt \{}decrease\_annot{\tt\}} : type$_0$ := \term$_0$.
1327 }
1328 \comindex{Function}
1329 \label{Function}
1330
1331 This \emph{experimental} command can be seen as a generalization of
1332 {\tt Fixpoint}. It is actually a wrapper for several ways of defining
1333 a function \emph{and other useful related objects}, namely: an
1334 induction principle that reflects the recursive structure of the
1335 function (see \ref{FunInduction}), and its fixpoint equality (not
1336 always, see below). The meaning of this declaration is to define a
1337 function {\it ident}, similarly to {\tt Fixpoint}. Like in {\tt
1338 Fixpoint}, the decreasing argument must be given (unless the function
1339 is not recursive), but it must not necessary be \emph{structurally}
1340 decreasing. The point of the {\tt
1341 \{\}} annotation is to name the decreasing argument \emph{and} to
1351 \subsubsection{A more complex definition of recursive functions}
1352
1353 The \emph{experimental} command
1354 \begin{center}
1355 \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1356 \{decrease\_annot\} : type$_0$ := \term$_0$}
1357 \comindex{Function}
1358 \label{Function}
1359 \end{center}
1360 can be seen as a generalization of {\tt Fixpoint}. It is actually a
1361 wrapper for several ways of defining a function \emph{and other useful
1362 related objects}, namely: an induction principle that reflects the
1363 recursive structure of the function (see \ref{FunInduction}), and its
1364 fixpoint equality (not always, see below). The meaning of this
1365 declaration is to define a function {\it ident}, similarly to {\tt
1366 Fixpoint}. Like in {\tt Fixpoint}, the decreasing argument must be
1367 given (unless the function is not recursive), but it must not
1368 necessary be \emph{structurally} decreasing. The point of the {\tt
1369 \{\}} annotation is to name the decreasing argument \emph{and} to
13421370 describe which kind of decreasing criteria must be used to ensure
13431371 termination of recursive calls.
13441372
14151443
14161444 \SeeAlso{\ref{FunScheme},\ref{FunScheme-examples},\ref{FunInduction}}
14171445
1418 Depending on the {\tt \{\}} annotation, different definition
1446 Depending on the {\tt \{$\ldots$\}} annotation, different definition
14191447 mechanisms are used by {\tt Function}. More precise description
14201448 given below.
14211449
1422
1423
1424 \subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1425 : type$_0$ := \term$_0$.
1426 \comindex{Function}
1427 }
1428
1429 Defines the not recursive function \ident\ as if declared with
1430 \texttt{Definition}. Three elimination schemes {\tt\ident\_rect},
1431 {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the
1432 documentation of {\tt Inductive} \ref{Inductive}), which reflect the
1433 pattern matching structure of \term$_0$.
1434
1435
1436 \subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1437 {\tt \{}{\tt struct} \ident$_0${\tt\}} : type$_0$ := \term$_0$.
1438 \comindex{Function}
1439 }
1440
1441 Defines the structural recursive function \ident\ as if declared with
1442 \texttt{Fixpoint} . Three induction schemes {\tt\ident\_rect},
1443 {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the
1444 documentation of {\tt Inductive} \ref{Inductive}), which reflect the
1445 recursive structure of \term$_0$. When there is only one parameter,
1446 {\tt \{struct} \ident$_0${\tt\}} can be omitted.
1447
1448 \subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1449 {\tt \{}{\tt measure \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$.
1450 \comindex{Function}}
1451
1452 \subsubsection{\tt Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1453 {\tt \{}{\tt wf \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$.
1454 \comindex{Function}}
1450 \begin{Variants}
1451 \item \texttt{ Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1452 : type$_0$ := \term$_0$}
1453
1454 Defines the not recursive function \ident\ as if declared with
1455 \texttt{Definition}. Three elimination schemes {\tt\ident\_rect},
1456 {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the
1457 documentation of {\tt Inductive} \ref{Inductive}), which reflect the
1458 pattern matching structure of \term$_0$.
1459
1460 \item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1461 {\tt \{}{\tt struct} \ident$_0${\tt\}} : type$_0$ := \term$_0$}
1462
1463 Defines the structural recursive function \ident\ as if declared
1464 with \texttt{Fixpoint}. Three induction schemes {\tt\ident\_rect},
1465 {\tt\ident\_rec} and {\tt\ident\_ind} are generated (see the
1466 documentation of {\tt Inductive} \ref{Inductive}), which reflect the
1467 recursive structure of \term$_0$. When there is only one parameter,
1468 {\tt \{struct} \ident$_0${\tt\}} can be omitted.
1469
1470 \item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} {\tt
1471 \{}{\tt measure \term$_1$} \ident$_0${\tt\}} : type$_0$ :=
1472 \term$_0$}
1473 \item \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$}
1474 {\tt \{}{\tt wf \term$_1$} \ident$_0${\tt\}} : type$_0$ := \term$_0$}
14551475
14561476 Defines a recursive function by well founded recursion. \textbf{The
14571477 module \texttt{Recdef} of the standard library must be loaded for this
15071527 %The decreasing argument cannot be dependent of another??
15081528
15091529 %Exemples faux ici
1510
1511
1512
1513
1514
1515 \subsubsection{\tt CoFixpoint {\ident} : \type$_0$ := \term$_0$.
1516 \comindex{CoFixpoint}
1517 \label{CoFixpoint}}
1518
1519 The {\tt CoFixpoint} command introduces a method for constructing an
1520 infinite object of a coinduc\-tive type. For example, the stream
1521 containing all natural numbers can be introduced applying the
1522 following method to the number \texttt{O} (see
1523 Section~\ref{CoInductiveTypes} for the definition of {\tt Stream},
1524 {\tt hd} and {\tt tl}):
1530 \end{Variants}
1531
1532
1533 \subsubsection{Recursive functions over co-indcutive types}
1534
1535 The command:
1536 \begin{center}
1537 \texttt{CoFixpoint {\ident} : \type$_0$ := \term$_0$}
1538 \comindex{CoFixpoint}\label{CoFixpoint}
1539 \end{center}
1540 introduces a method for constructing an infinite object of a
1541 coinduc\-tive type. For example, the stream containing all natural
1542 numbers can be introduced applying the following method to the number
1543 \texttt{O} (see Section~\ref{CoInductiveTypes} for the definition of
1544 {\tt Stream}, {\tt hd} and {\tt tl}):
15251545 \begin{coq_eval}
15261546 Reset Initial.
15271547 CoInductive Stream : Set :=
16051625
16061626 \begin{Variants}
16071627 \item {\tt Lemma {\ident} : {\type}.}\\
1608 It is a synonymous of \texttt{Theorem}
1609 \item {\tt Remark {\ident} : {\type}.}\\
1610 It is a synonymous of \texttt{Theorem}
1628 {\tt Remark {\ident} : {\type}.}\\
1629 {\tt Fact {\ident} : {\type}.}\\
1630 {\tt Corollary {\ident} : {\type}.}\\
1631 {\tt Proposition {\ident} : {\type}.}\\
1632 \comindex{Proposition}
1633 \comindex{Corollary}
1634 All these commands are synonymous of \texttt{Theorem}
16111635 % Same as {\tt Theorem} except
16121636 % that if this statement is in one or more levels of sections then the
16131637 % name {\ident} will be accessible only prefixed by the sections names
16151639 % closed.
16161640 % %All proofs of persistent objects (such as theorems) referring to {\ident}
16171641 % %within the section will be replaced by the proof of {\ident}.
1618 \item {\tt Fact {\ident} : {\type}.}\\
1619 It is a synonymous of \texttt{Theorem}
16201642 % Same as {\tt Remark} except
16211643 % that the innermost section name is dropped from the full name.
16221644 \item {\tt Definition {\ident} : {\type}.} \\
16831705 % TeX-master: "Reference-Manual"
16841706 % End:
16851707
1686 % $Id: RefMan-gal.tex 8915 2006-06-07 15:17:13Z courtieu $
1708 % $Id: RefMan-gal.tex 9040 2006-07-11 18:06:49Z notin $
+5
-4
doc/refman/RefMan-ide.tex less more
1010 \CoqIDE{} is run by typing the command \verb|coqide| on the command
1111 line. Without argument, the main screen is displayed with an ``unnamed
1212 buffer'', and with a file name as argument, another buffer displaying
13 the contents of that file. Additionally, coqide accepts the same
14 options as coqtop, given in Chapter~\ref{Addoc-coqc}, the ones having
15 obviously no meaning for \CoqIDE{} being ignored.
13 the contents of that file. Additionally, \verb|coqide| accepts the same
14 options as \verb|coqtop|, given in Chapter~\ref{Addoc-coqc}, the ones having
15 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/} }.
16
1617
1718 \begin{figure}[t]
1819 \begin{center}
318319
319320
320321
321 % $Id: RefMan-ide.tex 8626 2006-03-14 15:01:00Z notin $
322 % $Id: RefMan-ide.tex 8945 2006-06-10 12:04:14Z jnarboux $
322323
323324 %%% Local Variables:
324325 %%% mode: latex
+237
-43
doc/refman/RefMan-ltac.tex less more
102102 {\tt match reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\
103103 & | &
104104 {\tt match} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\
105 & | &
106 {\tt lazymatch goal with} \nelist{\contextrule}{\tt |} {\tt end}\\
107 & | &
108 {\tt lazymatch reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\
109 & | &
110 {\tt lazymatch} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\
105111 & | & {\tt abstract} {\atom}\\
106112 & | & {\tt abstract} {\atom} {\tt using} {\ident} \\
107113 & | & {\tt first [} \nelist{\tacexpr}{\tt |} {\tt ]}\\
108114 & | & {\tt solve [} \nelist{\tacexpr}{\tt |} {\tt ]}\\
109 & | & {\tt idtac} ~|~ {\tt idtac} {\qstring}\\
110 & | & {\tt fail} ~|~ {\tt fail} {\naturalnumber} {\qstring}\\
115 & | & {\tt idtac} \sequence{\messagetoken}{}\\
116 & | & {\tt fail} \zeroone{\naturalnumber} \sequence{\messagetoken}{}\\
111117 & | & {\tt fresh} ~|~ {\tt fresh} {\qstring}\\
112118 & | & {\tt context} {\ident} {\tt [} {\term} {\tt ]}\\
113119 & | & {\tt eval} {\nterm{redexpr}} {\tt in} {\term}\\
114120 & | & {\tt type of} {\term}\\
121 & | & {\tt external} {\qstring} {\qstring} \nelist{\tacarg}{}\\
115122 & | & {\tt constr :} {\term}\\
116123 & | & \atomictac\\
117124 & | & {\qualid} \nelist{\tacarg}{}\\
121128 {\qualid} \\
122129 & | & ()\\
123130 & | & {\tt (} {\tacexpr} {\tt )}\\
131 \\
132 {\messagetoken}\!\!\!\!\!\! & ::= & {\qstring} ~|~ {\term} ~|~ {\integer} \\
124133 \end{tabular}
125134 \end{centerframe}
126135 \caption{Syntax of the tactic language}
265274 application of $v_0$, for $=1,...,n$. It fails if the application of
266275 $v_0$ does not generate exactly $n$ subgoals.
267276
277 \variant If no tactic is given for the $i$-th generated subgoal, it
278 behaves as if the tactic {\tt idtac} were given. For instance, {\tt
279 split ; [ | auto ]} is a shortcut for
280 {\tt split ; [ idtac | auto ]}.
281
282
268283 \subsubsection{For loop}
269284 \tacindex{do}
270285 \index{Tacticals!do@{\tt do}}
368383
369384 The constant {\tt idtac} is the identity tactic: it leaves any goal
370385 unchanged but it appears in the proof script.
371 \begin{quote}
372 {\tt idtac} and {\tt idtac "message"}
373 \end{quote}
374 The latter variant prints the string on the standard output.
386
387 \variant {\tt idtac \nelist{\messagetoken}{}}
388
389 This prints the given tokens. Strings and integers are printed
390 literally. If a term is given, it is printed, its variables being
391 interpreted in the current environment. In particular, if a variable
392 is given, its value is printed.
375393
376394
377395 \subsubsection{Failing}
380398
381399 The tactic {\tt fail} is the always-failing tactic: it does not solve
382400 any goal. It is useful for defining other tacticals since it can be
383 catched by {\tt try} or {\tt match goal}. There are three variants:
384 \begin{quote}
385 {\tt fail $n$}, {\tt fail "message"} and {\tt fail $n$ "message"}
386 \end{quote}
401 catched by {\tt try} or {\tt match goal}.
402
403 \begin{Variants}
404 \item {\tt fail $n$}\\
387405 The number $n$ is the failure level. If no level is specified, it
388406 defaults to $0$. The level is used by {\tt try} and {\tt match goal}.
389407 If $0$, it makes {\tt match goal} considering the next clause
390408 (backtracking). If non zero, the current {\tt match goal} block or
391409 {\tt try} command is aborted and the level is decremented.
392410
393 \ErrMsg \errindex{Tactic Failure "message" (level $n$)}.
411 \item {\tt fail \nelist{\messagetoken}{}}\\
412 The given tokens are used for printing the failure message.
413
414 \item {\tt fail $n$ \nelist{\messagetoken}{}}\\
415 This is a combination of the previous variants.
416 \end{Variants}
417
418 \ErrMsg \errindex{Tactic Failure {\it message} (level $n$)}.
394419
395420 \subsubsection{Local definitions}
396421 \index{Ltac!let}
463488 pattern matching instantiations to the metavariables. If the matching
464489 with {\cpattern}$_1$ fails, {\cpattern}$_2$ is used and so on. The
465490 pattern {\_} matches any term and shunts all remaining patterns if
466 any. If {\tacexpr}$_1$ evaluates to a tactic, this tactic is not
467 immediately applied to the current goal (in contrast with {\tt match
468 goal}). If all clauses fail (in particular, there is no pattern {\_})
469 then a no-matching error is raised.
491 any. If {\tacexpr}$_1$ evaluates to a tactic and the {\tt match}
492 expression is in position to be applied to a goal (e.g. it is not
493 bound to a variable by a {\tt let in}, then this tactic is applied. If
494 the tactic succeeds, the list of resulting subgoals is the result of
495 the {\tt match} expression. On the opposite, if it fails, the next
496 pattern is tried. If all clauses fail (in particular, there is no
497 pattern {\_}) then a no-matching error is raised.
470498
471499 \begin{ErrMsgs}
472500
480508
481509 \end{ErrMsgs}
482510
483 \index{context!in pattern}
511 \begin{Variants}
512 \item \index{context!in pattern}
484513 There is a special form of patterns to match a subterm against the
485514 pattern:
486515 \begin{quote}
492521 hole. The definition of {\tt context} in expressions below will show
493522 how to use such term contexts.
494523
495 This operator never makes backtracking. If there are several subterms
496 matching the pattern, only the first match is considered. Note that
497 the order of matching is left unspecified.
498 %% TODO: clarify this point! It *should* be specified
499
524 If the evaluation of the right-hand-side of a valid match fails, the
525 next matching subterm is tried. If no further subterm matches, the
526 next clause is tried. Matching subterms are considered top-bottom and
527 from left to right (with respect to the raw printing obtained by
528 setting option {\tt Printing All}, see section~\ref{SetPrintingAll}).
529
530 \begin{coq_example}
531 Ltac f x :=
532 match x with
533 context f [S ?X] =>
534 idtac X; (* To display the evaluation order *)
535 assert (p := refl_equal 1 : X=1); (* To filter the case X=1 *)
536 let x:= context f[O] in assert (x=O) (* To observe the context *)
537 end.
538 Goal True.
539 f (3+4).
540 \end{coq_example}
541
542 \item \index{lazymatch!in Ltac}
543 \index{Ltac!lazymatch}
544 Using {\tt lazymatch} instead of {\tt match} has an effect if the
545 right-hand-side of a clause returns a tactic. With {\tt match}, the
546 tactic is applied to the current goal (and the next clause is tried if
547 it fails). With {\tt lazymatch}, the tactic is directly returned as
548 the result of the whole {\tt lazymatch} block without being first
549 tried to be applied to the goal. Typically, if the {\tt lazymatch}
550 block is bound to some variable $x$ in a {\tt let in}, then tactic
551 expression gets bound to the variable $x$.
552
553 \end{Variants}
500554
501555 \subsubsection{Pattern matching on goals}
502556 \index{Ltac!match goal}
520574 \end{tabbing}
521575 \end{quote}
522576
523 % TODO: specify order of hypothesis and explain reverse...
524
525577 If each hypothesis pattern $hyp_{1,i}$, with $i=1,...,m_1$
526578 is matched (non-linear first order unification) by an hypothesis of
527579 the goal and if {\cpattern}$_1$ is matched by the conclusion of the
534586 no other combination of hypotheses then the second proof context
535587 pattern is tried and so on. If the next to last proof context pattern
536588 fails then {\tacexpr}$_{n+1}$ is evaluated to $v_{n+1}$ and $v_{n+1}$
537 is applied.
589 is applied. Note also that matching against subterms (using the {\tt
590 context} {\ident} {\tt [} {\cpattern} {\tt ]}) is available and may
591 itself induce extra backtrackings.
538592
539593 \ErrMsg \errindex{No matching clauses for match goal}
540594
551605 first), but it possible to reverse this order (older first) with
552606 the {\tt match reverse goal with} variant.
553607
608 \variant
609 \index{lazymatch goal!in Ltac}
610 \index{Ltac!lazymatch goal}
611 \index{lazymatch reverse goal!in Ltac}
612 \index{Ltac!lazymatch reverse goal}
613 Using {\tt lazymatch} instead of {\tt match} has an effect if the
614 right-hand-side of a clause returns a tactic. With {\tt match}, the
615 tactic is applied to the current goal (and the next clause is tried if
616 it fails). With {\tt lazymatch}, the tactic is directly returned as
617 the result of the whole {\tt lazymatch} block without being first
618 tried to be applied to the goal. Typically, if the {\tt lazymatch}
619 block is bound to some variable $x$ in a {\tt let in}, then tactic
620 expression gets bound to the variable $x$.
621
622 \begin{coq_example}
623 Ltac test_lazy :=
624 lazymatch goal with
625 | _ => idtac "here"; fail
626 | _ => idtac "wasn't lazy"; trivial
627 end.
628 Ltac test_eager :=
629 match goal with
630 | _ => idtac "here"; fail
631 | _ => idtac "wasn't lazy"; trivial
632 end.
633 Goal True.
634 test_lazy || idtac "was lazy".
635 test_eager || idtac "was lazy".
636 \end{coq_example}
637
554638 \subsubsection{Filling a term context}
555639 \index{context!in expression}
556640
584668 by padding {\qstring} with a number if necessary. If no name is given,
585669 the prefix is {\tt H}.
586670
587 \subsubsection{{\tt type of} {\term}}
671 \subsubsection{Computing in a constr}
672 \index{Ltac!eval}
673 \index{eval!in Ltac}
674
675 Evaluation of a term can be performed with:
676 \begin{quote}
677 {\tt eval} {\nterm{redexpr}} {\tt in} {\term}
678 \end{quote}
679 where \nterm{redexpr} is a reduction tactic among {\tt red}, {\tt
680 hnf}, {\tt compute}, {\tt simpl}, {\tt cbv}, {\tt lazy}, {\tt unfold},
681 {\tt fold}, {\tt pattern}.
682
683 \subsubsection{Type-checking a term}
588684 %\tacindex{type of}
589685 \index{Ltac!type of}
590686 \index{type of!in Ltac}
591687
592 This tactic computes the type of {\term}.
593
594 \subsubsection{Computing in a constr}
595 \index{Ltac!eval}
596 \index{eval!in Ltac}
597
598 Evaluation of a term can be performed with:
599 \begin{quote}
600 {\tt eval} {\nterm{redexpr}} {\tt in} {\term}
601 \end{quote}
602 where \nterm{redexpr} is a reduction tactic among {\tt red}, {\tt
603 hnf}, {\tt compute}, {\tt simpl}, {\tt cbv}, {\tt lazy}, {\tt unfold},
604 {\tt fold}, {\tt pattern}.
605
688 The following returns the type of {\term}:
689
690 \begin{quote}
691 {\tt type of} {\term}
692 \end{quote}
606693
607694 \subsubsection{Accessing tactic decomposition}
608695 \tacindex{info}
634721
635722 \ErrMsg \errindex{Proof is not complete}
636723
724 \subsubsection{Calling an external tactic}
725 \index{Ltac!external}
726
727 The tactic {\tt external} allows to run an executable outside the
728 {\Coq} executable. The communication is done via an XML encoding of
729 constructions. The syntax of the command is
730
731 \begin{quote}
732 {\tt external} "\textsl{command}" "\textsl{request}" \nelist{\tacarg}{}
733 \end{quote}
734
735 The string \textsl{command}, to be interpreted in the default
736 execution path of the operating system, is the name of the external
737 command. The string \textsl{request} is the name of a request to be
738 sent to the external command. Finally the list of tactic arguments
739 have to evaluate to terms. An XML tree of the following form is sent
740 to the standard input of the external command.
741 \medskip
742
743 \begin{tabular}{l}
744 \texttt{<REQUEST req="}\textsl{request}\texttt{">}\\
745 the XML tree of the first argument\\
746 {\ldots}\\
747 the XML tree of the last argument\\
748 \texttt{</REQUEST>}\\
749 \end{tabular}
750 \medskip
751
752 Conversely, the external command must send on its standard output an
753 XML tree of the following forms:
754
755 \medskip
756 \begin{tabular}{l}
757 \texttt{<TERM>}\\
758 the XML tree of a term\\
759 \texttt{</TERM>}\\
760 \end{tabular}
761 \medskip
762
763 \noindent or
764
765 \medskip
766 \begin{tabular}{l}
767 \texttt{<CALL uri="}\textsl{ltac\_qualified\_ident}\texttt{">}\\
768 the XML tree of a first argument\\
769 {\ldots}\\
770 the XML tree of a last argument\\
771 \texttt{</CALL>}\\
772 \end{tabular}
773
774 \medskip
775 \noindent where \textsl{ltac\_qualified\_ident} is the name of a
776 defined {\ltac} function and each subsequent XML tree is recursively a
777 \texttt{CALL} or a \texttt{TERM} node.
778
779 The Document Type Definition (DTD) for terms of the Calculus of
780 Inductive Constructions is the one developed as part of the MoWGLI
781 European project. It can be found in the file {\tt dev/doc/cic.dtd} of
782 the {\Coq} source archive.
783
784 An example of parser for this DTD, written in the Objective Caml -
785 Camlp4 language, can be found in the file {\tt parsing/g\_xml.ml4} of
786 the {\Coq} source archive.
787
637788 \section{Tactic toplevel definitions}
638789 \comindex{Ltac}
639790
640 Basically, tactics toplevel definitions are made as follows:
791 \subsection{Defining {\ltac} functions}
792
793 Basically, {\ltac} toplevel definitions are made as follows:
641794 %{\tt Tactic Definition} {\ident} {\tt :=} {\tacexpr}\\
642795 %
643796 %{\tacexpr} is evaluated to $v$ and $v$ is associated to {\ident}. Next, every
648801 {\tt Ltac} {\ident} {\ident}$_1$ ... {\ident}$_n$ {\tt :=}
649802 {\tacexpr}
650803 \end{quote}
651 This defines a new tactic that can be used in any tactic script or new
652 tactic toplevel definition.
804 This defines a new {\ltac} function that can be used in any tactic
805 script or new {\ltac} toplevel definition.
653806
654807 \Rem The preceding definition can equivalently be written:
655808 \begin{quote}
673826 %usual except that the substitutions are lazily carried out (when an identifier
674827 %to be evaluated is the name of a recursive definition).
675828
829
830 \subsection{Printing {\ltac} tactics}
831 \comindex{Print Ltac}
832
833 Defined {\ltac} functions can be displayed using the command
834
835 \begin{quote}
836 {\tt Print Ltac {\qualid}.}
837 \end{quote}
838
839 \section{Debugging {\ltac} tactics}
840 \comindex{Set Ltac Debug}
841 \comindex{Unset Ltac Debug}
842 \comindex{Test Ltac Debug}
843
844 The {\ltac} interpreter comes with a step-by-step debugger. The
845 debugger can be activated using the command
846
847 \begin{quote}
848 {\tt Set Ltac Debug.}
849 \end{quote}
850
851 \noindent and deactivated using the command
852
853 \begin{quote}
854 {\tt Unset Ltac Debug.}
855 \end{quote}
856
857 To know if the debugger is on, use the command \texttt{Test Ltac Debug}.
858 When the debugger is activated, it stops at every step of the
859 evaluation of the current {\ltac} expression and it prints information
860 on what it is doing. The debugger stops, prompting for a command which
861 can be one of the following:
862
863 \medskip
864 \begin{tabular}{ll}
865 simple newline: & go to the next step\\
866 h: & get help\\
867 x: & exit current evaluation\\
868 s: & continue current evaluation without stopping\\
869 r$n$: & advance $n$ steps further\\
870 \end{tabular}
676871 \endinput
677
678872
679873 \subsection{Permutation on closed lists}
680874
+16
-30
doc/refman/RefMan-mod.tex less more
5454 {\modbindings}. The output module type is verified against the
5555 module type {\modtype}.
5656
57 \item\texttt{Module [Import|Export]}
58
59 Behaves like \texttt{Module}, but automatically imports or exports
60 the module.
61
5762 \end{Variants}
5863
5964 \subsection{\tt End {\ident}
138143 {\modbindings} and returning {\modtype}.
139144 \end{Variants}
140145
141 \subsection{\tt Declare Module {\ident}}
142
143 Starts an interactive module declaration. This command is available
144 only in module types.
145
146 \begin{Variants}
147
148 \item{\tt Declare Module {\ident} {\modbindings}}
149
150 Starts an interactive declaration of a functor with parameters given
151 by {\modbindings}.
152
153 % Particular case of the next item
154 %\item{\tt Declare Module {\ident} \verb.<:. {\modtype}}
155 %
156 % Starts an interactive declaration of a module satisfying {\modtype}.
157
158 \item{\tt Declare Module {\ident} {\modbindings} \verb.<:. {\modtype}}
159
160 Starts an interactive declaration of a functor with parameters given
161 by {\modbindings} (possibly none). The declared output module type is
162 verified against the module type {\modtype}.
163
164 \end{Variants}
165
166 \subsection{\tt End {\ident}}
167
168 This command closes the interactive declaration of module {\ident}.
169
170146 \subsection{\tt Declare Module {\ident} : {\modtype}}
171147
172 Declares a module of {\ident} of type {\modtype}. This command is available
148 Declares a module {\ident} of type {\modtype}. This command is available
173149 only in module types.
174150
175151 \begin{Variants}
187163
188164 Declares a module equal to the module {\qualid}, verifying that the
189165 module type of the latter is a subtype of {\modtype}.
166
167 \item\texttt{Declare Module [Import|Export] {\ident} := {\qualid}}
168
169 Declares a modules {\ident} of type {\modtype}, and imports or
170 exports it directly.
190171
191172 \end{Variants}
192173
388369
389370 Prints the module type corresponding to {\ident}.
390371
372 \subsection{\texttt{Locate Module {\qualid}}
373 \comindex{Locate Module}}
374
375 Prints the full name of the module {\qualid}.
376
391377
392378 %%% Local Variables:
393379 %%% mode: latex
+99
-1
doc/refman/RefMan-oth.tex less more
333333
334334 \SeeAlso Section \ref{LocateSymbol}
335335
336 \subsection{The {\sc Whelp} searching tool
337 \label{Whelp}}
338
339 {\sc Whelp} is an experimental searching and browsing tool for the
340 whole {\Coq} library and the whole set of {\Coq} user contributions.
341 {\sc Whelp} requires a browser to work. {\sc Whelp} has been developed
342 at the University of Bologna as part of the HELM\footnote{Hypertextual
343 Electronic Library of Mathematics} and MoWGLI\footnote{Mathematics on
344 the Web, Get it by Logics and Interfaces} projects. It can be invoked
345 directly from the {\Coq} toplevel or from {\CoqIDE}, assuming a
346 graphical environment is also running. The browser to use can be
347 selected by setting the environment variable {\tt
348 COQREMOTEBROWSER}. If not explicitly set, it defaults to
349 \verb!netscape -remote "OpenURL(%s)"! or
350 \verb!C:\\PROGRA~1\\INTERN~1\\IEXPLORE %s!, depending on the
351 underlying operating system (in the command, the string \verb!%s!
352 serves as metavariable for the url to open).
353
354 The {\sc Whelp} commands are:
355
356 \subsubsection{\tt Whelp Locate "{\sl reg\_expr}".
357 \comindex{Whelp Locate}}
358
359 This command opens a browser window and displays the result of seeking
360 for all names that match the regular expression {\sl reg\_expr} in the
361 {\Coq} library and user contributions. The regular expression can
362 contain the special operators are * and ? that respectively stand for
363 an arbitrary substring and for exactly one character.
364
365 \variant {\tt Whelp Locate {\ident}.}\\
366 This is equivalent to {\tt Whelp Locate "{\ident}"}.
367
368 \subsubsection{\tt Whelp Match {\pattern}.
369 \comindex{Whelp Match}}
370
371 This command opens a browser window and displays the result of seeking
372 for all statements that match the pattern {\pattern}. Holes in the
373 pattern are represented by the wildcard character ``\_''.
374
375 \subsubsection{\tt Whelp Instance {\pattern}.}
376 \comindex{Whelp Instance}
377
378 This command opens a browser window and displays the result of seeking
379 for all statements that are instances of the pattern {\pattern}. The
380 pattern is here assumed to be an universally quantified expression.
381
382 \subsubsection{\tt Whelp Elim {\qualid}.}
383 \comindex{Whelp Elim}
384
385 This command opens a browser window and displays the result of seeking
386 for all statements that have the ``form'' of an elimination scheme
387 over the type denoted by {\qualid}.
388
389 \subsubsection{\tt Whelp Hint {\term}.}
390 \comindex{Whelp Hint}
391
392 This command opens a browser window and displays the result of seeking
393 for all statements that can be instantiated so that to prove the
394 statement {\term}.
395
396 \variant {\tt Whelp Hint.}\\ This is equivalent to {\tt Whelp Hint
397 {\sl goal}} where {\sl goal} is the current goal to prove. Notice that
398 {\Coq} does not send the local environment of definitions to the {\sc
399 Whelp} tool so that it only works on requests strictly based on, only,
400 definitions of the standard library and user contributions.
401
336402 \section{Loading files}
337403
338404 \Coq\ offers the possibility of loading different
764830 %\subsection{\tt Abstraction ...}
765831 %Not yet documented.
766832
767 % $Id: RefMan-oth.tex 8606 2006-02-23 13:58:10Z herbelin $
833 \section{Controlling the conversion algorithm}
834
835 {\Coq} comes with two algorithms to check the convertibility of types
836 (see section~\ref{convertibility}). The first algorithm lazily
837 compares applicative terms while the other is a brute-force but efficient
838 algorithm that first normalizes the terms before comparing them. The
839 second algorithm is based on a bytecode representation of terms
840 similar to the bytecode representation used in the ZINC virtual
841 machine~\cite{Leroy90}. It is specially useful for intensive
842 computation of algebraic values, such as numbers, and for reflexion-based
843 tactics.
844
845 \subsection{\tt Set Virtual Machine
846 \label{SetVirtualMachine}
847 \comindex{Set Virtual Machine}}
848
849 This activates the bytecode-based conversion algorithm.
850
851 \subsection{\tt Unset Virtual Machine
852 \comindex{Unset Virtual Machine}}
853
854 This deactivates the bytecode-based conversion algorithm.
855
856 \subsection{\tt Test Virtual Machine
857 \comindex{Test Virtual Machine}}
858
859 This tells if the bytecode-based conversion algorithm is
860 activated. The default behavior is to have the bytecode-based
861 conversion algorithm deactivated.
862
863 \SeeAlso sections~\ref{vmcompute} and~\ref{vmoption}.
864
865 % $Id: RefMan-oth.tex 9044 2006-07-12 13:22:17Z herbelin $
768866
769867 %%% Local Variables:
770868 %%% mode: latex
+10
-10
doc/refman/RefMan-pre.tex less more
555555 Laurent Théry's contribution on strings and Pierre Letouzey and
556556 Jean-Christophe Filliâtre's contribution on finite maps have been
557557 integrated to the {\Coq} standard library. Pierre Letouzey developed a
558 library about finite sets ``à la Objective Caml'' and extended the
559 lists library. Pierre Letouzey's contribution on rational numbers
560 has been integrated too.
558 library about finite sets ``à la Objective Caml''. With Jean-Marc
559 Notin, he extended the library on lists. Pierre Letouzey's
560 contribution on rational numbers has been integrated and extended..
561561
562562 Pierre Corbineau extended his tactic for solving first-order
563 statements. He wrote a reflexion-based intuitionistic tautology
563 statements. He wrote a reflection-based intuitionistic tautology
564564 solver.
565565
566 Jean-Marc Notin took care of {\textsf{coqdoc}} and of the general
567 maintenance of the system.
568
569 \begin{flushright}
570 Palaiseau, Apr. 2006\\
566 Jean-Marc Notin significantly contributed to the general maintenance
567 of the system. He also took care of {\textsf{coqdoc}}.
568
569 \begin{flushright}
570 Palaiseau, July 2006\\
571571 Hugo Herbelin
572572 \end{flushright}
573573
576576 % Integration of ZArith lemmas from Sophia and Nijmegen.
577577
578578
579 % $Id: RefMan-pre.tex 8941 2006-06-09 16:43:42Z herbelin $
579 % $Id: RefMan-pre.tex 9030 2006-07-07 15:37:23Z herbelin $
580580
581581 %%% Local Variables:
582582 %%% mode: latex
+6
-13
doc/refman/RefMan-pro.tex less more
162162 current section.
163163 \end{Variants}
164164
165 \subsection{\tt Proof {\term}.}\comindex{Proof}
165 \subsection{\tt Proof {\term}.}
166 \comindex{Proof}
167 \label{BeginProof}
166168 This command applies in proof editing mode. It is equivalent to {\tt
167169 exact {\term}; Save.} That is, you have to give the full proof in
168170 one gulp, as a proof term (see section \ref{exact}).
169171
170 \begin{Variants}
171
172 \item{\tt Proof.}
172 \variant {\tt Proof.}
173173
174174 Is a noop which is useful to delimit the sequence of tactic commands
175175 which start a proof, after a {\tt Theorem} command. It is a good
176176 practice to use {\tt Proof.} as an opening parenthesis, closed in
177177 the script with a closing {\tt Qed.}
178178
179 \item{\tt Proof with {\tac}.}
180
181 This command may be used to start a proof. It defines a default
182 tactic to be used each time a tactic command is ended by
183 ``\verb#...#''. In this case the tactic command typed by the user is
184 equivalent to \emph{command};{\tac}.
185
186 \end{Variants}
179 \SeeAlso {\tt Proof with {\tac}.} in section~\ref{ProofWith}.
187180
188181 \subsection{\tt Abort.}
189182 \comindex{Abort}
380373 This command goes back to the default mode which is to print all
381374 available hypotheses.
382375
383 % $Id: RefMan-pro.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $
376 % $Id: RefMan-pro.tex 9030 2006-07-07 15:37:23Z herbelin $
384377
385378 %%% Local Variables:
386379 %%% mode: latex
+65
-13
doc/refman/RefMan-syn.tex less more
219219 \begin{quote}
220220 \tt Print Grammar constr.
221221 \end{quote}
222
223 \variant
224
225 \comindex{Print Grammar pattern}
226 {\tt Print Grammar pattern.}\\
227
228 This displays the state of the subparser of patterns (the parser
229 used in the grammar of the {\tt match} {\tt with} constructions).
222230
223231 \subsection{Displaying symbolic notations}
224232
435443 \SeeAlso Section \ref{Locate}.
436444
437445 \begin{figure}
446 \begin{small}
438447 \begin{centerframe}
439448 \begin{tabular}{lcl}
440 {\sentence} & ::= &
449 {\sentence} & ::= &
441450 \texttt{Notation} \zeroone{\tt Local} {\str} \texttt{:=} {\term}
442451 \zeroone{\modifiers} \zeroone{:{\scope}} .\\
443452 & $|$ &
473482 & $|$ & {\tt format} {\str}
474483 \end{tabular}
475484 \end{centerframe}
485 \end{small}
476486 \caption{Syntax of the variants of {\tt Notation}}
477487 \label{notation-syntax}
478488 \end{figure}
632642 definitions of an additive operator. Depending on which interpretation
633643 scopes is currently open, the interpretation is different.
634644 Interpretation scopes can include an interpretation for
635 numerals. However, this is only made possible at the {\ocaml} level.
645 numerals and strings. However, this is only made possible at the
646 {\ocaml} level.
636647
637648 See Figure \ref{notation-syntax} for the syntax of notations including
638649 the possibility to declare them in a given scope. Here is a typical
823834 delimited by key {\tt positive} and comes with an interpretation for
824835 numerals as closed term of type {\tt positive}.
825836
837 \subsubsection{\tt Q\_scope}
838
839 This includes the standard arithmetical operators and relations on
840 type {\tt Q} (rational numbers defined as fractions of an integer and
841 a strictly positive integer modulo the equality of the
842 numerator-denominator cross-product). As for numerals, only $0$ and
843 $1$ have an interpretation in scope {\tt Q\_scope} (their
844 interpretations are $\frac{0}{1}$ and $\frac{1}{1}$ respectively).
845
846 \subsubsection{\tt Qc\_scope}
847
848 This includes the standard arithmetical operators and relations on the
849 type {\tt Qc} of rational numbers defined as the type of irreducible
850 fractions of an integer and a strictly positive integer.
851
826852 \subsubsection{\tt real\_scope}
827853
828854 This includes the standard arithmetical operators and relations on
852878
853879 This includes the notation for pairs. It is delimited by key {\tt core}.
854880
881 \subsubsection{\tt string\_scope}
882
883 This includes notation for strings as elements of the type {\tt
884 string}. Special characters and escaping follow {\Coq} conventions
885 on strings (see page~\pageref{strings}). Especially, there is no
886 convention to visualize non printable characters of a string. The
887 file {\tt String.v} shows an example that contains quotes, a newline
888 and a beep (i.e. the ascii character of code 7).
889
890 \subsubsection{\tt char\_scope}
891
892 This includes interpretation for all strings of the form
893 \verb!"!$c$\verb!"! where $c$ is an ascii character, or of the form
894 \verb!"!$nnn$\verb!"! where $nnn$ is a three-digits number (possibly
895 with leading 0's), or of the form \verb!""""!. Their respective
896 denotations are the ascii code of $c$, the decimal ascii code $nnn$,
897 or the ascii code of the character \verb!"! (i.e. the ascii code
898 34), all of them being represented in the type {\tt ascii}.
899
855900 \subsection{Displaying informations about scopes}
856901
857902 \subsubsection{\tt Print Visibility}
947992 the {\tt Grammar tactic simple\_tactic} command that existed in
948993 versions prior to version 8.0.}. Tactic notations obey the following
949994 syntax
950
995 \medskip
996
997 \noindent
951998 \begin{tabular}{lcl}
952 {\sentence} & ::= & \texttt{Tactic Notation} {\str} \sequence{\proditem}{} \\
999 {\sentence} & ::= & \texttt{Tactic Notation} {\taclevel} \sequence{\proditem}{} \\
9531000 & & \texttt{:= {\tac} .}\\
9541001 {\proditem} & ::= & {\str} $|$ {\tacargtype}{\tt ({\ident})} \\
1002 {\taclevel} & ::= & $|$ {\tt (at level} {\naturalnumber}{\tt )} \\
9551003 {\tacargtype} & ::= &
9561004 %{\tt preident} $|$
9571005 {\tt ident} $|$
9651013 {\tt int\_or\_var} $|$
9661014 {\tt tactic} $|$
9671015 \end{tabular}
968
969 A tactic notation {\tt Tactic Notation {\str} {\sequence{\proditem}{}}
970 := {\tac}} extends the parser and pretty-printer of tactics with a
971 new rule made of the juxtaposition of the head name of the tactic
972 {\str} and the list of its production items (in the syntax of
973 production items, {\str} stands for a terminal symbol and {\tt
974 \tacargtype({\ident}) for non terminal entries}. It then evaluates
975 into the tactic expression {\tac}.
1016 \medskip
1017
1018 A tactic notation {\tt Tactic Notation {\taclevel}
1019 {\sequence{\proditem}{}} := {\tac}} extends the parser and
1020 pretty-printer of tactics with a new rule made of the list of
1021 production items. It then evaluates into the tactic expression
1022 {\tac}. For simple tactics, it is recommended to use a terminal
1023 symbol, i.e. a {\str}, for the first production item. The tactic
1024 level indicates the parsing precedence of the tactic notation. This
1025 information is particularly relevant for notations of tacticals.
1026 Levels 0 to 5 are available. To know the parsing precedences of the
1027 existing tacticals, use the command {\tt Print Grammar tactic.}
9761028
9771029 Each type of tactic argument has a specific semantic regarding how it
9781030 is parsed and how it is interpreted. The semantic is described in the
10071059 syntactically includes identifiers in order to be usable in tactic
10081060 definitions.
10091061
1010 % $Id: RefMan-syn.tex 8609 2006-02-24 13:32:57Z notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty $
1062 % $Id: RefMan-syn.tex 9012 2006-07-05 16:03:16Z herbelin $
10111063
10121064 %%% Local Variables:
10131065 %%% mode: latex
+217
-64
doc/refman/RefMan-tac.tex less more
6868 \item \errindex{Not an exact proof}
6969 \end{ErrMsgs}
7070
71 \begin{Variants}
72 \item \texttt{eexact \term}\tacindex{eexact}
73
74 This tactic behaves like \texttt{exact} but is able to handle terms with meta-variables.
75
76 \end{Variants}
77
7178
7279 \subsection{\tt refine \term
7380 \tacindex{refine}
111118 \item \errindex{No such assumption}
112119 \end{ErrMsgs}
113120
121 \begin{Variants}
122 \item \texttt{eassumption}
123
124 This tactic behaves like \texttt{assumption} but is able to handle
125 goals with meta-variables.
126
127 \end{Variants}
128
129
114130 \subsection{\tt clear {\ident}
115131 \tacindex{clear}
116132 \label{clear}}
131147 This tactic expects {\ident} to be a local definition then clears
132148 its body. Otherwise said, this tactic turns a definition into an
133149 assumption.
150
151 \item \texttt{clear - {\ident}.}
152
153 This tactic clears all hypotheses except the ones depending in {\ident}.
134154
135155 \end{Variants}
136156
504524 {\tt cut U} transforms the current goal \texttt{T} into the two
505525 following subgoals: {\tt U -> T} and \texttt{U}. The subgoal {\tt U
506526 -> T} comes first in the list of remaining subgoal to prove.
527
528 \item \texttt{assert {\form} by {\tac}}\tacindex{assert by}
529
530 This tactic behaves like \texttt{assert} but tries to apply {\tac}
531 to any subgoals generated by \texttt{assert}.
532
533 \item \texttt{assert {\form} as {\ident}\tacindex{assert as}}
534
535 This tactic behaves like \texttt{assert ({\ident} : {\form})}.
536
537 \item \texttt{pose proof {\term} as {\ident}}
538
539 This tactic behaves like \texttt{assert ({\ident:T} by exact {\term}} where
540 \texttt{T} is the type of {\term}.
507541
508542 \end{Variants}
509543
720754 \tacindex{cbv}
721755 \tacindex{lazy}
722756 \tacindex{compute}}
757 \label{vmcompute}
723758
724759 These parameterized reduction tactics apply to any goal and perform
725760 the normalization of the goal according to the specified flags. Since
763798 \item {\tt compute} \tacindex{compute}
764799
765800 This tactic is an alias for {\tt cbv beta delta evar iota zeta}.
801
802 \item {\tt vm\_compute} \tacindex{vm\_compute}
803
804 This tactic evaluates the goal using the optimized call-by-value
805 evaluation bytecode-based virtual machine. This algorithm is
806 dramatically more efficient than the algorithm used for the {\tt
807 cbv} tactic, but it cannot be fine-tuned. It is specially
808 interesting for full evaluation of algebraic objects. This includes
809 the case of reflexion-based tactics.
810
766811 \end{Variants}
767812
768813 \begin{ErrMsgs}
10101055 As soon as the inductive type has the right number of constructors,
10111056 these expressions are equivalent to the corresponding {\tt
10121057 constructor $i$ with \bindinglist}.
1058
1059 \item \texttt{econstructor}
1060
1061 This tactic behaves like \texttt{constructor} but is able to
1062 introduce existential variables if an instanciation for a variable
1063 cannot be found (cf \texttt{eapply}). The tactics \texttt{eexists},
1064 \texttt{esplit}, \texttt{eleft} and \texttt{eright} follows the same
1065 behaviour.
10131066
10141067 \end{Variants}
10151068
10951148 scheme of name {\qualid}. It does not expect that the type of
10961149 {\term} is inductive.
10971150
1151 \item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}}
1152
1153 where {\qualid} is an induction principle with complex predicates
1154 (like the ones generated by function induction).
1155
10981156 \item {\tt induction {\term} using {\qualid} as {\intropattern}}
10991157
11001158 This combines {\tt induction {\term} using {\qualid}}
12321290 {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of
12331291 {\tt [} $p_{1} $\ldots $p_{n}$ {\tt ]}.
12341292
1293 \item \texttt{pose proof {\term} as {\intropattern}}
1294
1295 This tactic behaves like \texttt{destruct {\term} as {\intropattern}}.
1296
12351297 \item{\tt destruct {\term} using {\qualid}}
12361298
12371299 This is a synonym of {\tt induction {\term} using {\qualid}}.
12781340 An introduction pattern is either:
12791341 \begin{itemize}
12801342 \item the wildcard: {\tt \_}
1343 \item the pattern \texttt{?}
12811344 \item a variable
12821345 \item a disjunction of lists of patterns:
12831346 {\tt [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} $p_{nm_n}$]}
12891352 \begin{itemize}
12901353 \item introduction on the wildcard do the introduction and then
12911354 immediately clear (cf~\ref{clear}) the corresponding hypothesis;
1355 \item introduction on \texttt{?} do the introduction, and let Coq
1356 choose a fresh name for the variable;
12921357 \item introduction on a variable behaves like described in~\ref{intro};
12931358 \item introduction over a
12941359 list of patterns $p_1~\ldots~p_n$ is equivalent to the sequence of
13221387 Lemma intros_test : forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C.
13231388 intros A B C [a| [_ c]] f.
13241389 apply (f a).
1325 Proof c.
1390 exact c.
1391 Qed.
13261392 \end{coq_example}
13271393
13281394 %\subsection{\tt FixPoint \dots}\tacindex{Fixpoint}
14781544 This tactic applies to any goal. The type of {\term}
14791545 must have the form
14801546
1481 \texttt{(x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\term$_1${\tt =}\term$_2$.
1547 \texttt{(x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq}\term$_1$ \term$_2$.
1548
1549 \noindent where \texttt{eq} is the Leibniz equality or a registered
1550 setoid equality.
14821551
14831552 \noindent Then {\tt rewrite \term} replaces every occurrence of
14841553 \term$_1$ by \term$_2$ in the goal. Some of the variables x$_1$ are
15051574 \item {\tt rewrite <- {\term}}\tacindex{rewrite <-}\\
15061575 Uses the equality \term$_1${\tt=}\term$_2$ from right to left
15071576
1508 \item {\tt rewrite {\term} in {\ident}}
1577 \item {\tt rewrite {\term} in \textit{clause}}
15091578 \tacindex{rewrite \dots\ in}\\
1510 Analogous to {\tt rewrite {\term}} but rewriting is done in the
1511 hypothesis named {\ident}.
1579 Analogous to {\tt rewrite {\term}} but rewriting is done following
1580 \textit{clause} (similarly to \ref{Conversion-tactics}). For instance:
1581 \texttt{rewrite H in H1,H2 |- *} means \texttt{rewrite H in H1;
1582 rewrite H in H2; rewrite H} and \texttt{rewrite H in * |-} will do
1583 \texttt{try rewrite H in H$_i$} for all hypothesis \texttt{H$_i$ <>
1584 H}.
15121585
15131586 \item {\tt rewrite -> {\term} in {\ident}}
15141587 \tacindex{rewrite -> \dots\ in}\\
15391612 \term$_2$=\term$_1$; [intro H{\sl n}; rewrite <- H{\sl n}; clear H{\sl
15401613 n}| assumption || symmetry; try assumption]}.
15411614
1615 \begin{ErrMsgs}
1616 \item \errindex{terms do not have convertible types}
1617 \end{ErrMsgs}
1618
15421619 \begin{Variants}
15431620
15441621 \item {\tt replace {\term$_1$} with {\term$_2$} in \ident}\\
15451622 This replaces {\term$_1$} with {\term$_2$} in the hypothesis named
15461623 {\ident}, and generates the subgoal {\term$_2$}{\tt =}{\term$_1$}.
15471624
1548 \begin{ErrMsgs}
1549 \item \errindex{No such hypothesis} : {\ident}
1550 \item \errindex{Nothing to rewrite in {\ident}}
1551 \end{ErrMsgs}
1552
1625 % \begin{ErrMsgs}
1626 % \item \errindex{No such hypothesis} : {\ident}
1627 % \item \errindex{Nothing to rewrite in {\ident}}
1628 % \end{ErrMsgs}
1629
1630 \item {\tt replace {\term$_1$} with {\term$_2$} by \tac}\\ This acts as
1631 {\tt replace {\term$_1$} with {\term$_2$}} but try to solve the
1632 generated subgoal {\tt \term$_2$=\term$_1$} using {\tt \tac}.
1633 \item {\tt replace {\term$_1$} with {\term$_2$} in \ident by \tac}\\
1634 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}.
15531635 \end{Variants}
15541636
15551637 \subsection{\tt reflexivity
16161698 Lemmas are added to the database using the command
16171699 \comindex{Declare Left Step}
16181700 \begin{quote}
1619 {\tt Declare Left Step {\qualid}.}
1701 {\tt Declare Left Step {\term}.}
16201702 \end{quote}
1621 where {\qualid} is the name of the lemma.
16221703
16231704 The tactic is especially useful for parametric setoids which are not
1624 accepted as regular setoids for {\tt rewrite} and {\tt setoid\_replace} (see chapter \ref{setoid_replace}).
1705 accepted as regular setoids for {\tt rewrite} and {\tt
1706 setoid\_replace} (see chapter \ref{setoid_replace}).
16251707
16261708 \tacindex{stepr}
16271709 \comindex{Declare Right Step}
16371719 $z$, $R$ $x$ $y$ {\tt ->} $eq$ $y$ $z$ {\tt ->} $R$ $x$ $z$''
16381720 and are registered using the command
16391721 \begin{quote}
1640 {\tt Declare Right Step {\qualid}.}
1722 {\tt Declare Right Step {\term}.}
16411723 \end{quote}
16421724 \end{Variants}
16431725
21562238 Uses all existing hint databases, minus the special database
21572239 {\tt v62}. See Section~\ref{Hints-databases}
21582240
2241 \item \texttt{auto using $lemma_1, \ldots, lemma_n$}
2242
2243 Uses $lemma_1, \ldots, lemma_n$ in addition to hints (can be conbined
2244 with the \texttt{with \ident} option).
2245
21592246 \item {\tt trivial}\tacindex{trivial}
21602247
21612248 This tactic is a restriction of {\tt auto} that is not recursive and
23052392 % En attente d'un moyen de valoriser les fichiers de demos
23062393 %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_tauto.v}
23072394
2395
2396 \subsection{\tt rtauto
2397 \tacindex{rtauto}
2398 \label{rtauto}}
2399
2400 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.
2401
2402 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).
2403
23082404 \subsection{{\tt firstorder}
23092405 \tacindex{firstorder}
23102406 \label{firstorder}}
24582554 (see \ref{injection} and \ref{discriminate}).
24592555 If the goal is a non-quantified equality, {\tt congruence} tries to
24602556 prove it with non-quantified equalities in the context. Otherwise it
2461 tries to infer a discriminable equality from those in the context.
2557 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.
24622558
24632559 \begin{coq_eval}
24642560 Reset Initial.
24882584 congruence.
24892585 \end{coq_example}
24902586
2587 \begin{Variants}
2588 \item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\
2589 Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by
2590 {\tt congruence}. This helps in case you have partially applied
2591 constructors in your goal.
2592 \end{Variants}
2593
24912594 \begin{ErrMsgs}
24922595 \item \errindex{I don't know how to handle dependent equality} \\
24932596 The decision procedure managed to find a proof of the goal or of
24942597 a discriminable equality but this proof couldn't be built in Coq
24952598 because of dependently-typed functions.
24962599 \item \errindex{I couldn't solve goal} \\
2497 The decision procedure didn't managed to find a proof of the goal or of
2498 a discriminable equality.
2600 The decision procedure didn't find any way to solve the goal.
2601 \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\
2602 The decision procedure could solve the goal with the provision
2603 that additional arguments are supplied for some partially applied
2604 constructors. Any term of an appropriate type will allow the
2605 tactic to successfully solve the goal. Those additional arguments
2606 can be given to {\tt congruence} by filling in the holes in the
2607 terms given in the error message, using the {\tt with} variant
2608 described below.
24992609 \end{ErrMsgs}
25002610
25012611 \subsection{\tt omega
26782788 to get a very compact and readable version.} carries out rewritings according
26792789 the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}.
26802790
2681 Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until
2791 Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until
26822792 it fails. Once all the rules have been processed, if the main subgoal has
26832793 progressed (e.g., if it is distinct from the initial main goal) then the rules
26842794 of this base are processed again. If the main subgoal has not progressed then
26942804 \item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\
26952805 Performs, in the same way, all the rewritings of the bases {\tt $ident_1$ $...$
26962806 $ident_n$} applying {\tt \tac} to the main subgoal after each rewriting step.
2697 %\item{\tt autorewrite [ \ident$_1$ \dots \ident$_n$ ]}\\
2698 %{\tt autorewrite [ \ident$_1$ \dots \ident$_n$ ] using \tac}\\
2699 %These are deprecated syntactic variants for
2700 %{\tt autorewrite with \ident$_1$ \dots \ident$_n$}
2701 %and
2702 %{\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}.
2807
2808 \item \texttt{autorewrite with {\ident} in {\qualid}}
2809
2810 Performs all the rewritings in hypothesis {\qualid}.
2811
27032812 \end{Variant}
27042813
2705 \subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident
2706 \comindex{Hint Rewrite}}
2707
2708 This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$}
2709 (their types must be equalities) in the rewriting base {\tt \ident}
2710 with the default orientation (left to right). Notice that the
2711 rewriting bases are distinct from the {\tt auto} hint bases and that
2712 {\tt auto} does not take them into account.
2713
2714 This command is synchronous with the section mechanism (see \ref{Section}):
2715 when closing a section, all aliases created by \texttt{Hint Rewrite} in that
2716 section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite}
2717 declarations at the global level of that module are loaded.
2718
2719 \begin{Variants}
2720 \item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\
2721 This is strictly equivalent to the command above (we only make explicit the
2722 orientation which otherwise defaults to {\tt ->}).
2723
2724 \item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\
2725 Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left
2726 orientation in the base {\tt \ident}.
2727
2728 \item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\
2729 When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will
2730 be used, the tactic {\tt \tac} will be applied to the generated subgoals, the
2731 main subgoal excluded.
2732
2733 %% \item
2734 %% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\
2735 %% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\
2736 %% These are deprecated syntactic variants for
2737 %% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and
2738 %% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}.
2739
2740 \end{Variants}
2741
2742 \SeeAlso \ref{autorewrite-example} for examples showing the use of
2814 \SeeAlso section \ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}.
2815
2816 \SeeAlso section \ref{autorewrite-example} for examples showing the use of
27432817 this tactic.
27442818
27452819 % En attente d'un moyen de valoriser les fichiers de demos
27462820 %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v}
27472821
2748 \section{The hints databases for {\tt auto} and {\tt eauto}
2822 \section{Controlling automation}
2823
2824 \subsection{The hints databases for {\tt auto} and {\tt eauto}
27492825 \index{Hints databases}
27502826 \label{Hints-databases}
27512827 \comindex{Hint}}
30353111
30363112 \end{Variants}
30373113
3114 \subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident
3115 \label{HintRewrite}
3116 \comindex{Hint Rewrite}}
3117
3118 This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$}
3119 (their types must be equalities) in the rewriting base {\tt \ident}
3120 with the default orientation (left to right). Notice that the
3121 rewriting bases are distinct from the {\tt auto} hint bases and that
3122 {\tt auto} does not take them into account.
3123
3124 This command is synchronous with the section mechanism (see \ref{Section}):
3125 when closing a section, all aliases created by \texttt{Hint Rewrite} in that
3126 section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite}
3127 declarations at the global level of that module are loaded.
3128
3129 \begin{Variants}
3130 \item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\
3131 This is strictly equivalent to the command above (we only make explicit the
3132 orientation which otherwise defaults to {\tt ->}).
3133
3134 \item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\
3135 Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left
3136 orientation in the base {\tt \ident}.
3137
3138 \item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\
3139 When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will
3140 be used, the tactic {\tt \tac} will be applied to the generated subgoals, the
3141 main subgoal excluded.
3142
3143 %% \item
3144 %% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\
3145 %% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\
3146 %% These are deprecated syntactic variants for
3147 %% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and
3148 %% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}.
3149
3150 \item \texttt{Print Rewrite HintDb {\ident}}
3151
3152 This command displays all rewrite hints contained in {\ident}.
3153
3154 \end{Variants}
30383155
30393156 \subsection{Hints and sections
30403157 \label{Hint-and-Section}}
30443161 defined inside a section (and not defined with option {\tt Local}) become
30453162 available when the module {\tt A} is imported (using
30463163 e.g. \texttt{Require Import A.}).
3164
3165 \subsection{Setting implicit automation tactics}
3166
3167 \subsubsection{\tt Proof with {\tac}.}
3168 \label{ProofWith}
3169 \comindex{Proof with}
3170
3171 This command may be used to start a proof. It defines a default
3172 tactic to be used each time a tactic command {\tac$_1$} is ended by
3173 ``\verb#...#''. In this case the tactic command typed by the user is
3174 equivalent to \tac$_1$;{\tac}.
3175
3176 \SeeAlso {\tt Proof.} in section~\ref{BeginProof}.
3177
3178 \subsubsection{\tt Declare Implicit Tactic {\tac}.}
3179 \comindex{Declare Implicit Tactic}
3180
3181 This command declares a tactic to be used to solve implicit arguments
3182 that {\Coq} does not know how to solve by unification. It is used
3183 every time the term argument of a tactic has one of its holes not
3184 fully resolved.
3185
3186 Here is an example:
3187
3188 \begin{coq_example}
3189 Parameter quo : nat -> forall n:nat, n<>0 -> nat.
3190 Notation "x // y" := (quo x y _) (at level 40).
3191
3192 Declare Implicit Tactic assumption.
3193 Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }.
3194 intros.
3195 exists (n // m).
3196 \end{coq_example}
3197
3198 The tactic {\tt exists (n // m)} did not fail. The hole was solved by
3199 {\tt assumption} so that it behaved as {\tt exists (quo n m H)}.
30473200
30483201 \section{Generation of induction principles with {\tt Scheme}
30493202 \label{Scheme}
31383291 user-defined tactics.
31393292
31403293
3141 % $Id: RefMan-tac.tex 8938 2006-06-09 16:29:01Z jnarboux $
3294 % $Id: RefMan-tac.tex 9044 2006-07-12 13:22:17Z herbelin $
31423295
31433296 %%% Local Variables:
31443297 %%% mode: latex
+2
-2
doc/refman/Reference-Manual.tex less more
6767 \include{RefMan-oth.v}% Vernacular commands
6868 \include{RefMan-pro}% Proof handling
6969 \include{RefMan-tac.v}% Tactics and tacticals
70 \include{RefMan-ltac}% Writing tactics
70 \include{RefMan-ltac.v}% Writing tactics
7171 \include{RefMan-tacex.v}% Detailed Examples of tactics
7272
7373 \part{User extensions}
121121 \end{document}
122122
123123
124 % $Id: Reference-Manual.tex 8688 2006-04-07 15:08:12Z msozeau $
124 % $Id: Reference-Manual.tex 9038 2006-07-11 13:53:53Z herbelin $
+2
-1
doc/refman/cover.html less more
1212 The Coq Proof Assistant<BR>
1313 Reference Manual<BR></B></FONT><FONT SIZE=7>
1414 </FONT>
15 <BR><BR><FONT SIZE=5><B><BR></B></FONT><FONT SIZE=5><B>Version 8.0</B></FONT><FONT SIZE=5><B>
15 <BR><BR><FONT SIZE=5><B><BR></B></FONT><FONT SIZE=5><B>Version 8.1</B></FONT><FONT SIZE=5><B>
1616 </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>
1717 </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>
1818 </B></FONT></DIV><BR>
2121 <DIV ALIGN=left>
2222 <FONT SIZE=4>V7.x © INRIA 1999-2004</FONT><BR>
2323 <FONT SIZE=4>V8.0 © INRIA 2004-2006</FONT><BR>
24 <FONT SIZE=4>V8.1 © INRIA 2006</FONT><BR>
2425 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.
2526 </DIV>
2627 <BR>
+8
-23
doc/refman/index.html less more
00 <HTML>
11
2 <BODY>
2 <HEAD>
33
4 <CENTER>
4 <TITLE>The Coq Proof Assistant Reference Manual</TITLE>
55
6 <TABLE BORDER="0" CELLPADDING=10>
7 <TR>
8 <TD><CENTER><A HREF="cover.html" TARGET="UP"><FONT SIZE=2>Cover page</FONT></A></CENTER></TD>
9 <TD><CENTER><A HREF="toc.html" TARGET="UP"><FONT SIZE=2>Table of contents</FONT></A></CENTER></TD>
10 <TD><CENTER><A HREF="biblio.html" TARGET="UP"><FONT SIZE=2>
11 Bibliography</FONT></A></CENTER></TD>
12 <TD><CENTER><A HREF="general-index.html" TARGET="UP"><FONT SIZE=2>
13 Global Index
14 </FONT></A></CENTER></TD>
15 <TD><CENTER><A HREF="tactic-index.html" TARGET="UP"><FONT SIZE=2>
16 Tactics Index
17 </FONT></A></CENTER></TD>
18 <TD><CENTER><A HREF="command-index.html" TARGET="UP"><FONT SIZE=2>
19 Vernacular Commands Index
20 </FONT></A></CENTER></TD>
21 <TD><CENTER><A HREF="error-index.html" TARGET="UP"><FONT SIZE=2>
22 Index of Error Messages
23 </FONT></A></CENTER></TD>
24 </TABLE>
6 </HEAD>
257
26 </CENTER>
8 <FRAMESET ROWS=90%,*>
9 <FRAME SRC="cover.html" NAME="UP">
10 <FRAME SRC="menu.html">
11 </FRAMESET>
2712
28 </BODY></HTML>⏎
13 </HTML>⏎
+29
-0
doc/refman/menu.html less more
0 <HTML>
1
2 <BODY>
3
4 <CENTER>
5
6 <TABLE BORDER="0" CELLPADDING=10>
7 <TR>
8 <TD><CENTER><A HREF="cover.html" TARGET="UP"><FONT SIZE=2>Cover page</FONT></A></CENTER></TD>
9 <TD><CENTER><A HREF="toc.html" TARGET="UP"><FONT SIZE=2>Table of contents</FONT></A></CENTER></TD>
10 <TD><CENTER><A HREF="biblio.html" TARGET="UP"><FONT SIZE=2>
11 Bibliography</FONT></A></CENTER></TD>
12 <TD><CENTER><A HREF="general-index.html" TARGET="UP"><FONT SIZE=2>
13 Global Index
14 </FONT></A></CENTER></TD>
15 <TD><CENTER><A HREF="tactic-index.html" TARGET="UP"><FONT SIZE=2>
16 Tactics Index
17 </FONT></A></CENTER></TD>
18 <TD><CENTER><A HREF="command-index.html" TARGET="UP"><FONT SIZE=2>
19 Vernacular Commands Index
20 </FONT></A></CENTER></TD>
21 <TD><CENTER><A HREF="error-index.html" TARGET="UP"><FONT SIZE=2>
22 Index of Error Messages
23 </FONT></A></CENTER></TD>
24 </TABLE>
25
26 </CENTER>
27
28 </BODY></HTML>⏎
+20
-11
doc/tutorial/Tutorial.tex less more
3030 the \Coq{} Reference Manual or the \textit{Coq'Art}, a new book by Y.
3131 Bertot and P. Castéran on practical uses of the \Coq{} system.
3232
33 We assume here that the potential user has installed \Coq~ on his workstation,
34 that he calls \Coq~ from a standard teletype-like shell window, and that
35 he does not use any special interface.
33 Coq can be used from a standard teletype-like shell window but
34 preferably through the graphical user interface
35 CoqIde\footnote{Alternative graphical interfaces exist: Proof General
36 and Pcoq.}.
37
3638 Instructions on installation procedures, as well as more comprehensive
3739 documentation, may be found in the standard distribution of \Coq,
3840 which may be obtained from \Coq{} web site \texttt{http://coq.inria.fr}.
3941
40 In the following, all examples preceded by the prompting sequence
41 \verb:Coq < : represent user input, terminated by a period. The
42 following lines usually show \Coq's answer as it appears on the users
43 screen. The sequence of such examples is a valid \Coq~ session, unless
44 otherwise specified. This version of the tutorial has been prepared
45 on a PC workstation running Linux.
46 The standard invocation of \Coq\ delivers a message such as:
42 In the following, we assume that \Coq~ is called from a standard
43 teletype-like shell window. All examples preceded by the prompting
44 sequence \verb:Coq < : represent user input, terminated by a
45 period.
46
47 The following lines usually show \Coq's answer as it appears on the
48 users screen. When used from a graphical user interface such as
49 CoqIde, the prompt is not displayed: user input is given in one window
50 and \Coq's answers are displayed in a different window.
51
52 The sequence of such examples is a valid \Coq~
53 session, unless otherwise specified. This version of the tutorial has
54 been prepared on a PC workstation running Linux. The standard
55 invocation of \Coq\ delivers a message such as:
4756
4857 \begin{small}
4958 \begin{flushleft}
15511560
15521561 \end{document}
15531562
1554 % $Id: Tutorial.tex 8715 2006-04-14 12:43:23Z cpaulin $
1563 % $Id: Tutorial.tex 8978 2006-06-23 10:15:57Z herbelin $
+2
-2
ide/coq.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: coq.ml 8912 2006-06-07 11:20:58Z notin $ *)
8 (* $Id: coq.ml 9024 2006-07-06 10:38:15Z herbelin $ *)
99
1010 open Vernac
1111 open Vernacexpr
123123 | VernacDeclareTacticDefinition _
124124 when is_in_proof_mode () ->
125125 user_error_loc loc (str "CoqIDE do not support nested goals")
126 | VernacDebug _ ->
126 | VernacSetOption (Goptions.SecondaryTable ("Ltac","Debug"), _) ->
127127 user_error_loc loc (str "Debug mode not available within CoqIDE")
128128 | VernacResetName _
129129 | VernacResetInitial
+4
-3
interp/constrextern.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: constrextern.ml 8831 2006-05-19 09:29:54Z herbelin $ *)
8 (* $Id: constrextern.ml 8997 2006-07-03 16:40:20Z herbelin $ *)
99
1010 (*i*)
1111 open Pp
185185 | CCases(_,_,a1,brl1), CCases(_,_,a2,brl2) ->
186186 List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2;
187187 List.iter2 (fun (_,pl1,r1) (_,pl2,r2) ->
188 List.iter2 check_same_pattern pl1 pl2;
188 List.iter2 (List.iter2 check_same_pattern) pl1 pl2;
189189 check_same_type r1 r2) brl1 brl2
190190 | CHole _, CHole _ -> ()
191191 | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> ()
796796 LocalRawAssum([(dummy_loc,na)],ty) :: l))
797797
798798 and extern_eqn inctx scopes vars (loc,ids,pl,c) =
799 (loc,List.map (extern_cases_pattern_in_scope scopes vars) pl,
799 (loc,[List.map (extern_cases_pattern_in_scope scopes vars) pl],
800800 extern inctx scopes vars c)
801801
802802 and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
842842 and extern_recursion_order scopes vars = function
843843 RStructRec -> CStructRec
844844 | RWfRec c -> CWfRec (extern true scopes vars c)
845 | RMeasureRec c -> CMeasureRec (extern true scopes vars c)
845846
846847
847848 let extern_rawconstr vars c =
+38
-20
interp/constrintern.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: constrintern.ml 8924 2006-06-08 17:49:01Z notin $ *)
8 (* $Id: constrintern.ml 8997 2006-07-03 16:40:20Z herbelin $ *)
99
1010 open Pp
1111 open Util
8080 str "The variable " ++ pr_id id ++ str " is bound several times in pattern"
8181
8282 let explain_bad_patterns_number n1 n2 =
83 let s = if n1 > 1 then "s" else "" in
84 str "Expecting " ++ int n1 ++ str " pattern" ++ str s ++ str " but found "
85 ++ int n2
83 str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++
84 str " but found " ++ int n2
8685
8786 let explain_bad_explicitation_number n po =
8887 match n with
356355 | x::l -> if List.mem x l then (Some x) else has_duplicate l
357356
358357 let loc_of_lhs lhs =
359 join_loc (cases_pattern_loc (List.hd lhs)) (cases_pattern_loc (list_last lhs))
358 join_loc (cases_pattern_loc (List.hd (List.hd lhs)))
359 (cases_pattern_loc (list_last (list_last lhs)))
360360
361361 let check_linearity lhs ids =
362362 match has_duplicate ids with
774774 in
775775 let idl = Array.map
776776 (fun (id,(n,order),bl,ty,bd) ->
777 let ro, ((ids',_,_),rbl) =
778 (match order with
779 CStructRec ->
780 RStructRec,
781 List.fold_left intern_local_binder (env,[]) bl
782 | CWfRec c ->
783 let before, after = list_chop (succ (out_some n)) bl in
784 let ((ids',_,_),rafter) =
785 List.fold_left intern_local_binder (env,[]) after in
786 let ro = RWfRec (intern (ids', tmp_scope, scopes) c) in
787 ro, List.fold_left intern_local_binder (env,rafter) before)
777 let intern_ro_arg c f =
778 let before, after = list_chop (succ (out_some n)) bl in
779 let ((ids',_,_),rafter) =
780 List.fold_left intern_local_binder (env,[]) after in
781 let ro = (intern (ids', tmp_scope, scopes) c) in
782 f ro, List.fold_left intern_local_binder (env,rafter) before
783 in
784 let ro, ((ids',_,_),rbl) =
785 (match order with
786 CStructRec ->
787 RStructRec,
788 List.fold_left intern_local_binder (env,[]) bl
789 | CWfRec c ->
790 intern_ro_arg c (fun r -> RWfRec r)
791 | CMeasureRec c ->
792 intern_ro_arg c (fun r -> RMeasureRec r))
788793 in
789794 let ids'' = List.fold_right Idset.add lf ids' in
790795 ((n, ro), List.rev rbl,
923928 ((name_fold Idset.add na ids,ts,sc),
924929 (na,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
925930
926 and intern_eqn n (ids,tmp_scope,scopes as _env) (loc,lhs,rhs) =
931 (* Expands a multiple pattern into a disjunction of multiple patterns *)
932 and intern_multiple_pattern scopes pl =
927933 let idsl_pll =
928 List.map (intern_cases_pattern globalenv scopes ([],[]) None) lhs in
929
930 let eqn_ids,pll = product_of_cases_patterns [] idsl_pll in
934 List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in
935 product_of_cases_patterns [] idsl_pll
936
937 (* Expands a disjunction of multiple pattern *)
938 and intern_disjunctive_multiple_pattern scopes loc mpl =
939 assert (mpl <> []);
940 let mpl' = List.map (intern_multiple_pattern scopes) mpl in
941 let (idsl,mpl') = List.split mpl' in
942 let ids = List.hd idsl in
943 check_or_pat_variables loc ids (List.tl idsl);
944 (ids,List.flatten mpl')
945
946 (* Expands a pattern-matching clause [lhs => rhs] *)
947 and intern_eqn n (ids,tmp_scope,scopes) (loc,lhs,rhs) =
948 let eqn_ids,pll = intern_disjunctive_multiple_pattern scopes loc lhs in
931949 (* Linearity implies the order in ids is irrelevant *)
932950 check_linearity lhs eqn_ids;
933951 check_number_of_pattern loc n (snd (List.hd pll));
+16
-15
interp/genarg.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: genarg.mli 8926 2006-06-08 20:23:17Z herbelin $ i*)
8 (*i $Id: genarg.mli 8983 2006-06-23 13:21:49Z herbelin $ i*)
99
1010 open Util
1111 open Names
5959 \begin{verbatim}
6060 tag raw open type cooked closed type
6161
62 BoolArgType bool bool
63 IntArgType int int
64 IntOrVarArgType int or_var int
65 StringArgType string (parsed w/ "") string
66 PreIdentArgType string (parsed w/o "") (vernac only)
67 IdentArgType identifier identifier
68 IntroPatternArgType intro_pattern_expr intro_pattern_expr
69 VarArgType identifier constr
70 RefArgType reference global_reference
71 ConstrArgType constr_expr constr
72 ConstrMayEvalArgType constr_expr may_eval constr
73 QuantHypArgType quantified_hypothesis quantified_hypothesis
74 OpenConstrArgType constr_expr open_constr
75 ConstrBindingsArgType constr_expr with_bindings constr with_bindings
62 BoolArgType bool bool
63 IntArgType int int
64 IntOrVarArgType int or_var int
65 StringArgType string (parsed w/ "") string
66 PreIdentArgType string (parsed w/o "") (vernac only)
67 IdentArgType identifier identifier
68 IntroPatternArgType intro_pattern_expr intro_pattern_expr
69 VarArgType identifier located identifier
70 RefArgType reference global_reference
71 QuantHypArgType quantified_hypothesis quantified_hypothesis
72 ConstrArgType constr_expr constr
73 ConstrMayEvalArgType constr_expr may_eval constr
74 OpenConstrArgType open_constr_expr open_constr
75 ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings
76 BindingsArgType constr_expr bindings constr bindings
7677 List0ArgType of argument_type
7778 List1ArgType of argument_type
7879 OptArgType of argument_type
+8
-2
interp/topconstr.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: topconstr.ml 8875 2006-05-29 19:59:11Z msozeau $ *)
8 (* $Id: topconstr.ml 9032 2006-07-07 16:30:34Z herbelin $ *)
99
1010 (*i*)
1111 open Pp
514514 (constr_expr * explicitation located option) list
515515 | CCases of loc * constr_expr option *
516516 (constr_expr * (name option * constr_expr option)) list *
517 (loc * cases_pattern_expr list * constr_expr) list
517 (loc * cases_pattern_expr list list * constr_expr) list
518518 | CLetTuple of loc * name list * (name option * constr_expr option) *
519519 constr_expr * constr_expr
520520 | CIf of loc * constr_expr * (name option * constr_expr option)
543543 and recursion_order_expr =
544544 | CStructRec
545545 | CWfRec of constr_expr
546 | CMeasureRec of constr_expr
546547
547548 (***********************)
548549 (* For binders parsing *)
550551 let rec local_binders_length = function
551552 | [] -> 0
552553 | LocalRawDef _::bl -> 1 + local_binders_length bl
554 | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl
555
556 let rec local_assums_length = function
557 | [] -> 0
558 | LocalRawDef _::bl -> local_binders_length bl
553559 | LocalRawAssum (idl,_)::bl -> List.length idl + local_binders_length bl
554560
555561 let names_of_local_assums bl =
+6
-2
interp/topconstr.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: topconstr.mli 8875 2006-05-29 19:59:11Z msozeau $ i*)
8 (*i $Id: topconstr.mli 9032 2006-07-07 16:30:34Z herbelin $ i*)
99
1010 (*i*)
1111 open Pp
9797 (constr_expr * explicitation located option) list
9898 | CCases of loc * constr_expr option *
9999 (constr_expr * (name option * constr_expr option)) list *
100 (loc * cases_pattern_expr list * constr_expr) list
100 (loc * cases_pattern_expr list list * constr_expr) list
101101 | CLetTuple of loc * name list * (name option * constr_expr option) *
102102 constr_expr * constr_expr
103103 | CIf of loc * constr_expr * (name option * constr_expr option)
121121 and recursion_order_expr =
122122 | CStructRec
123123 | CWfRec of constr_expr
124 | CMeasureRec of constr_expr
124125
125126 and local_binder =
126127 | LocalRawDef of name located * constr_expr
157158 (* Includes let binders *)
158159 val local_binders_length : local_binder list -> int
159160
161 (* Excludes let binders *)
162 val local_assums_length : local_binder list -> int
163
160164 (* Does not take let binders into account *)
161165 val names_of_local_assums : local_binder list -> name located list
162166
+10
-4
kernel/inductive.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: inductive.ml 8871 2006-05-28 16:46:48Z herbelin $ *)
8 (* $Id: inductive.ml 8972 2006-06-22 22:17:43Z herbelin $ *)
99
1010 open Util
1111 open Names
134134 | Prop Null -> neutral_univ
135135 | Prop Pos -> base_univ
136136
137 let cons_subst u su subst =
138 try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
139 with Not_found -> (u, su) :: subst
140
137141 let rec make_subst env exp act =
138142 match exp, act with
139143 (* Bind expected levels of parameters to actual levels *)
140144 | None :: exp, _ :: act ->
141145 make_subst env exp act
142 | Some u :: exp, t :: act ->
143 (u, sort_as_univ (snd (dest_arity env t))) :: make_subst env exp act
146 | Some u :: exp, t :: act ->
147 let su = sort_as_univ (snd (dest_arity env t)) in
148 cons_subst u su (make_subst env exp act)
144149 (* Not enough parameters, create a fresh univ *)
145150 | Some u :: exp, [] ->
146 (u, fresh_local_univ ()) :: make_subst env exp []
151 let su = fresh_local_univ () in
152 cons_subst u su (make_subst env exp [])
147153 | None :: exp, [] ->
148154 make_subst env exp []
149155 (* Uniform parameters are exhausted *)
+1
-36
parsing/argextend.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: argextend.ml4 8926 2006-06-08 20:23:17Z herbelin $ *)
8 (* $Id: argextend.ml4 8976 2006-06-23 10:03:54Z herbelin $ *)
99
1010 open Genarg
1111 open Q_util
175175
176176 open Vernacexpr
177177 open Pcoq
178
179 let rec interp_entry_name loc s =
180 let l = String.length s in
181 if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
182 let t, g = interp_entry_name loc (String.sub s 3 (l-8)) in
183 List1ArgType t, <:expr< Gramext.Slist1 $g$ >>
184 else if l > 5 & String.sub s (l-5) 5 = "_list" then
185 let t, g = interp_entry_name loc (String.sub s 0 (l-5)) in
186 List0ArgType t, <:expr< Gramext.Slist0 $g$ >>
187 else if l > 4 & String.sub s (l-4) 4 = "_opt" then
188 let t, g = interp_entry_name loc (String.sub s 0 (l-4)) in
189 OptArgType t, <:expr< Gramext.Sopt $g$ >>
190 else
191 let t, se =
192 if tactic_genarg_level s <> None then
193 Some (ExtraArgType s), <:expr< Tactic. tactic >>
194 else
195 match Pcoq.entry_type (Pcoq.get_univ "prim") s with
196 | Some _ as x -> x, <:expr< Prim. $lid:s$ >>
197 | None ->
198 match Pcoq.entry_type (Pcoq.get_univ "constr") s with
199 | Some _ as x -> x, <:expr< Constr. $lid:s$ >>
200 | None ->
201 match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
202 | Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
203 | None -> None, <:expr< $lid:s$ >> in
204 let t =
205 match t with
206 | Some t -> t
207 | None ->
208 (* Pp.warning_with Pp_control.err_ft
209 ("Unknown primitive grammar entry: "^s);*)
210 ExtraArgType s
211 in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
212
213178 open Pcaml
214179
215180 EXTEND
+9
-7
parsing/g_constr.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: g_constr.ml4 8875 2006-05-29 19:59:11Z msozeau $ *)
8 (* $Id: g_constr.ml4 9043 2006-07-12 10:06:40Z herbelin $ *)
99
1010 open Pcoq
1111 open Constr
243243 fixannot:
244244 [ [ "{"; IDENT "struct"; id=name; "}" -> (Some id, CStructRec)
245245 | "{"; IDENT "wf"; id=name; rel=lconstr; "}" -> (Some id, CWfRec rel)
246 | "{"; IDENT "measure"; id=name; rel=lconstr; "}" -> (Some id, CMeasureRec rel)
246247 | -> (None, CStructRec)
247248 ] ]
248249 ;
272273 [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
273274 ;
274275 eqn:
275 [ [ pl = LIST1 pattern SEP ","; "=>"; rhs = lconstr -> (loc,pl,rhs) ] ]
276 [ [ pll = LIST0 LIST1 pattern LEVEL "99" SEP "," SEP "|";
277 "=>"; rhs = lconstr -> (loc,pll,rhs) ] ]
276278 ;
277279 pattern:
278280 [ "200" RIGHTA [ ]
279 | "100" LEFTA
281 | "100" RIGHTA
280282 [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ]
281283 | "99" RIGHTA [ ]
282284 | "10" LEFTA
283 [ p = pattern; lp = LIST1 (pattern LEVEL "0") ->
285 [ p = pattern; lp = LIST1 NEXT ->
284286 (match p with
285287 | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
286288 | _ -> Util.user_err_loc
287289 (cases_pattern_loc p, "compound_pattern",
288290 Pp.str "Constructor expected"))
289291 | p = pattern; "as"; id = ident ->
290 CPatAlias (loc, p, id)
291 | c = pattern; "%"; key=IDENT ->
292 CPatDelimiters (loc,key,c) ]
292 CPatAlias (loc, p, id) ]
293 | "1" LEFTA
294 [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ]
293295 | "0"
294296 [ r = Prim.reference -> CPatAtom (loc,Some r)
295297 | "_" -> CPatAtom (loc,None)
+2
-2
parsing/g_ltac.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: g_ltac.ml4 8878 2006-05-30 16:44:25Z herbelin $ *)
8 (* $Id: g_ltac.ml4 9037 2006-07-11 12:43:50Z herbelin $ *)
99
1010 open Pp
1111 open Util
133133 | "()" -> TacVoid ] ]
134134 ;
135135 match_key:
136 [ [ "match" -> false ] ]
136 [ [ "match" -> false | "lazymatch" -> true ] ]
137137 ;
138138 input_fun:
139139 [ [ "_" -> None
+7
-3
parsing/g_vernac.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: g_vernac.ml4 8929 2006-06-08 22:35:58Z herbelin $ *)
8 (* $Id: g_vernac.ml4 9017 2006-07-05 17:27:34Z herbelin $ *)
99 (*i camlp4deps: "parsing/grammar.cma" i*)
1010
1111 open Pp
236236 rec_annotation:
237237 [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec)
238238 | "{"; IDENT "wf"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CWfRec rel)
239 | "{"; IDENT "measure"; id=IDENT; rel=lconstr; "}" -> (Some (id_of_string id), CMeasureRec rel)
239240 | -> (None, CStructRec)
240241 ] ]
241242 ;
650651 VernacBacktrack (n,m,p)
651652
652653 (* Tactic Debugger *)
653 | IDENT "Debug"; IDENT "On" -> VernacDebug true
654 | IDENT "Debug"; IDENT "Off" -> VernacDebug false
654 | IDENT "Debug"; IDENT "On" ->
655 VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue true)
656
657 | IDENT "Debug"; IDENT "Off" ->
658 VernacSetOption (SecondaryTable ("Ltac","Debug"), BoolValue false)
655659
656660 ] ];
657661 END
+6
-12
parsing/g_xml.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: g_xml.ml4 8875 2006-05-29 19:59:11Z msozeau $ *)
8 (* $Id: g_xml.ml4 9016 2006-07-05 17:19:39Z herbelin $ *)
99
1010 open Pp
1111 open Util
227227 (match l with
228228 [c] -> RWfRec (interp_xml_type c)
229229 | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)"))
230 | "Measure" ->
231 (match l with
232 [c] -> RMeasureRec (interp_xml_type c)
233 | _ -> user_err_loc (loc, "", str "wrong number of arguments (expected one)"))
230234 | _ ->
231235 user_err_loc (locs,"",str "invalid recursion order")
232236
251255
252256 (* Interpreting tactic argument *)
253257
254 let rec (interp_xml_tactic_expr : xml -> glob_tactic_expr) = function
255 | XmlTag (loc,"TACARG",[],[x]) ->
256 TacArg (interp_xml_tactic_arg x)
257 | _ -> error "Ill-formed xml tree"
258
259 and interp_xml_tactic_arg = function
258 let rec interp_xml_tactic_arg = function
260259 | XmlTag (loc,"TERM",[],[x]) ->
261260 ConstrMayEval (ConstrTerm (interp_xml_constr x,None))
262261 | XmlTag (loc,"CALL",al,xl) ->
263262 let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in
264263 TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl)
265 (*
266 | XmlTag (loc,"TACTIC",[],[x]) ->
267 Tacexp (interp_xml_tactic_expr x)
268 | _ -> error "Ill-formed xml tree"
269 *)
270264 | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s)
271265
272266 let parse_tactic_arg ch =
+9
-6
parsing/lexer.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: lexer.ml4 8924 2006-06-08 17:49:01Z notin $ i*)
8 (*i $Id: lexer.ml4 9015 2006-07-05 17:19:22Z herbelin $ i*)
99
1010 open Pp
1111 open Token
145145 (* utf-8 what do to with diacritics U0483-U0489 \ U0487 ? *)
146146 (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
147147 | x when 0x048A <= x & x <= 0x04F9 -> Utf8Letter n
148 (* utf-8 Cyrillic supplements letters U0500-U050F *)
148 (* utf-8 Cyrillic supplement letters U0500-U050F *)
149149 | x when 0x0500 <= x & x <= 0x050F -> Utf8Letter n
150150 (* utf-8 Hebrew letters U05D0-05EA *)
151151 | x when 0x05D0 <= x & x <= 0x05EA -> Utf8Letter n
152 (* utf-8 Hebrew letters U0621-064A *)
152 (* utf-8 Arabic letters U0621-064A *)
153153 | x when 0x0621 <= x & x <= 0x064A -> Utf8Letter n
154 (* utf-8 Arabic supplement letters U0750-076D *)
155 | x when 0x0750 <= x & x <= 0x076D -> Utf8Letter n
154156 | _ -> error_unsupported_unicode_character n cs
155157 end
156158 | 0x1000 ->
588590 | _ -> false
589591
590592 let is_number s =
591 match s.[0] with
592 | '0'..'9' -> true
593 | _ -> false
593 let rec aux i =
594 String.length s = i or
595 match s.[i] with '0'..'9' -> aux (i+1) | _ -> false
596 in aux 0
594597
595598 let strip s =
596599 let len =
+6
-2
parsing/pcoq.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: pcoq.ml4 8926 2006-06-08 20:23:17Z herbelin $ i*)
8 (*i $Id: pcoq.ml4 9043 2006-07-12 10:06:40Z herbelin $ i*)
99
1010 open Pp
1111 open Util
483483 0,Gramext.RightA]
484484
485485 let default_pattern_levels =
486 [10,Gramext.LeftA;
486 [200,Gramext.RightA;
487 100,Gramext.RightA;
488 99,Gramext.RightA;
489 10,Gramext.LeftA;
490 1,Gramext.LeftA;
487491 0,Gramext.RightA]
488492
489493 let level_stack =
+5
-3
parsing/ppconstr.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: ppconstr.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
8 (* $Id: ppconstr.ml 8997 2006-07-03 16:40:20Z herbelin $ *)
99
1010 (*i*)
1111 open Util
185185
186186 let pr_patt = pr_patt mt
187187
188
189188 let pr_eqn pr (loc,pl,rhs) =
190189 spc() ++ hov 4
191190 (pr_with_comments loc
192191 (str "| " ++
193 hov 0 (prlist_with_sep sep_v (pr_patt ltop) pl ++ str " =>") ++
192 hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
193 ++ str " =>") ++
194194 pr_sep_com spc (pr ltop) rhs))
195195
196196 let begin_of_binder = function
383383 else mt()
384384 | CWfRec c ->
385385 spc () ++ str "{wf " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}"
386 | CMeasureRec c ->
387 spc () ++ str "{measure " ++ pr lsimple c ++ pr_name (snd (List.nth ids (out_some n))) ++ str"}"
386388 in
387389 pr_recursive_decl pr prd dangling_with_for id bl annot t c
388390
+4
-2
parsing/ppvernac.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: ppvernac.ml 8831 2006-05-19 09:29:54Z herbelin $ *)
8 (* $Id: ppvernac.ml 9020 2006-07-05 17:35:23Z herbelin $ *)
99
1010 open Pp
1111 open Names
413413 | ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l
414414 in pr_showable s
415415 | VernacCheckGuard -> str"Guarded"
416 | VernacDebug b -> pr_topcmd b
417416
418417 (* Resetting *)
419418 | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
570569 else mt()
571570 | CWfRec c ->
572571 spc() ++ str "{wf " ++ pr_name name ++ spc() ++
572 pr_lconstr_expr c ++ str"}"
573 | CMeasureRec c ->
574 spc() ++ str "{measure " ++ pr_name name ++ spc() ++
573575 pr_lconstr_expr c ++ str"}"
574576 in
575577 pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
+17
-11
parsing/q_util.ml4 less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: q_util.ml4 7732 2005-12-26 13:51:24Z herbelin $ *)
8 (* $Id: q_util.ml4 8982 2006-06-23 13:17:49Z herbelin $ *)
99
1010 (* This file defines standard combinators to build ml expressions *)
1111
8383 OptArgType t, <:expr< Gramext.Sopt $g$ >>
8484 else
8585 let s = if s = "hyp" then "var" else s in
86 let t, se =
86 let t, se, lev =
87 match tactic_genarg_level s with
88 | Some n -> Some (ExtraArgType s), <:expr< Tactic. tactic_expr >>, Some n
89 | None ->
8790 match Pcoq.entry_type (Pcoq.get_univ "prim") s with
88 | Some _ as x -> x, <:expr< Prim. $lid:s$ >>
91 | Some _ as x -> x, <:expr< Prim. $lid:s$ >>, None
8992 | None ->
9093 match Pcoq.entry_type (Pcoq.get_univ "constr") s with
91 | Some _ as x -> x, <:expr< Constr. $lid:s$ >>
94 | Some _ as x -> x, <:expr< Constr. $lid:s$ >>, None
9295 | None ->
9396 match Pcoq.entry_type (Pcoq.get_univ "tactic") s with
94 | Some _ as x -> x, <:expr< Tactic. $lid:s$ >>
95 | None -> None, <:expr< $lid:s$ >> in
97 | Some _ as x -> x, <:expr< Tactic. $lid:s$ >>, None
98 | None -> None, <:expr< $lid:s$ >>, None in
9699 let t =
97100 match t with
98101 | Some t -> t
99 | None ->
100 (* Pp.warning_with Pp_control.err_ft
101 ("Unknown primitive grammar entry: "^s);*)
102 ExtraArgType s
103 in t, <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
102 | None -> ExtraArgType s in
103 let entry = match lev with
104 | Some n ->
105 let s = string_of_int n in
106 <:expr< Gramext.Snterml (Pcoq.Gram.Entry.obj $se$, $str:s$) >>
107 | None ->
108 <:expr< Gramext.Snterm (Pcoq.Gram.Entry.obj $se$) >>
109 in t, entry
+2
-2
pretyping/pattern.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: pattern.ml 8755 2006-04-27 22:22:15Z herbelin $ *)
8 (* $Id: pattern.ml 8963 2006-06-19 18:54:49Z barras $ *)
99
1010 open Util
1111 open Names
131131 let map_pattern f = map_pattern_with_binders (fun () -> ()) (fun () -> f) ()
132132
133133 let rec instantiate_pattern lvar = function
134 | PVar id as x -> (try List.assoc id lvar with Not_found -> x)
134 | PVar id as x -> (try Lazy.force(List.assoc id lvar) with Not_found -> x)
135135 | (PFix _ | PCoFix _) -> error ("Not instantiable pattern")
136136 | c -> map_pattern (instantiate_pattern lvar) c
137137
+2
-2
pretyping/pattern.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: pattern.mli 8755 2006-04-27 22:22:15Z herbelin $ i*)
8 (*i $Id: pattern.mli 8963 2006-06-19 18:54:49Z barras $ i*)
99
1010 (*i*)
1111 open Pp
7575 patvar list * constr_pattern
7676
7777 val instantiate_pattern :
78 (identifier * constr_pattern) list -> constr_pattern -> constr_pattern
78 (identifier * constr_pattern Lazy.t) list -> constr_pattern -> constr_pattern
7979
8080 val lift_pattern : int -> constr_pattern -> constr_pattern
+2
-1
pretyping/pretyping.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: pretyping.ml 8875 2006-05-29 19:59:11Z msozeau $ *)
8 (* $Id: pretyping.ml 8992 2006-06-27 21:29:18Z herbelin $ *)
99
1010 open Pp
1111 open Util
481481 else
482482 error_cant_find_case_type_loc loc env (evars_of !isevars)
483483 cj.uj_val in
484 let ccl = refresh_universes ccl in
484485 let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
485486 let v =
486487 let mis,_ = dest_ind_family indf in
+2
-2
pretyping/rawterm.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: rawterm.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
8 (* $Id: rawterm.ml 8969 2006-06-22 12:51:04Z msozeau $ *)
99
1010 (*i*)
1111 open Util
7272
7373 and rawdecl = name * rawconstr option * rawconstr
7474
75 and fix_recursion_order = RStructRec | RWfRec of rawconstr
75 and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
7676
7777 and fix_kind =
7878 | RFix of ((int option * fix_recursion_order) array * int)
+2
-2
pretyping/rawterm.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: rawterm.mli 8878 2006-05-30 16:44:25Z herbelin $ i*)
8 (*i $Id: rawterm.mli 8969 2006-06-22 12:51:04Z msozeau $ i*)
99
1010 (*i*)
1111 open Util
6969
7070 and rawdecl = name * rawconstr option * rawconstr
7171
72 and fix_recursion_order = RStructRec | RWfRec of rawconstr
72 and fix_recursion_order = RStructRec | RWfRec of rawconstr | RMeasureRec of rawconstr
7373
7474 and fix_kind =
7575 | RFix of ((int option * fix_recursion_order) array * int)
+9
-6
pretyping/recordops.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: recordops.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
8 (* $Id: recordops.ml 9032 2006-07-07 16:30:34Z herbelin $ *)
99
1010 open Util
1111 open Pp
3131
3232 type struc_typ = {
3333 s_CONST : identifier;
34 s_PARAM : int;
34 s_EXPECTEDPARAM : int;
3535 s_PROJKIND : bool list;
3636 s_PROJ : constant option list }
3737
4343 let load_structure i (_,(ind,id,kl,projs)) =
4444 let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
4545 let struc =
46 { s_CONST = id; s_PARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
46 { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
4747 structure_table := Indmap.add ind struc !structure_table;
4848 projection_table :=
4949 List.fold_right (option_fold_right (fun proj -> Cmap.add proj struc))
8282
8383 let lookup_structure indsp = Indmap.find indsp !structure_table
8484
85 let lookup_projections indsp = (lookup_structure indsp).s_PROJ
86
8587 let find_projection_nparams = function
86 | ConstRef cst -> (Cmap.find cst !projection_table).s_PARAM
88 | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM
8789 | _ -> raise Not_found
8890
8991
133135 let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in
134136 let lt = List.rev (List.map snd lt) in
135137 let args = snd (decompose_app t) in
136 let { s_PARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in
138 let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in
137139 let params, projs = list_chop p args in
138140 let lpj = keep_true_projections lpj kl in
139141 let lps = List.combine lpj projs in
201203 | Construct (indsp,1) -> indsp
202204 | _ -> error_not_structure ref in
203205 let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
204 if s.s_PARAM + List.length s.s_PROJ > Array.length args then
206 let ntrue_projs = List.length (List.filter (fun x -> x) s.s_PROJKIND) in
207 if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then
205208 error_not_structure ref;
206209 (sp,indsp)
207210
+5
-10
pretyping/recordops.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: recordops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
8 (*i $Id: recordops.mli 9032 2006-07-07 16:30:34Z herbelin $ i*)
99
1010 (*i*)
1111 open Names
2020 (*s A structure S is a non recursive inductive type with a single
2121 constructor (the name of which defaults to Build_S) *)
2222
23 type struc_typ = {
24 s_CONST : identifier;
25 s_PARAM : int;
26 s_PROJKIND : bool list;
27 s_PROJ : constant option list }
28
2923 val declare_structure :
3024 inductive * identifier * int * bool list * constant option list -> unit
3125
32 (* [lookup_structure isp] returns the infos associated to inductive path
33 [isp] if it corresponds to a structure, otherwise fails with [Not_found] *)
34 val lookup_structure : inductive -> struc_typ
26 (* [lookup_projections isp] returns the projections associated to the
27 inductive path [isp] if it corresponds to a structure, otherwise
28 it fails with [Not_found] *)
29 val lookup_projections : inductive -> constant option list
3530
3631 (* raise [Not_found] if not a projection *)
3732 val find_projection_nparams : global_reference -> int
+5
-7
tactics/equality.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: equality.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
8 (* $Id: equality.ml 9010 2006-07-05 07:17:41Z jforest $ *)
99
1010 open Pp
1111 open Util
200200 ]
201201 ] gl
202202 else
203 error "terms does not have convertible types"
203 error "terms do not have convertible types"
204204
205205
206206 let replace c2 c1 gl = abstract_replace None c2 c1 false tclIDTAC gl
543543
544544 (* returns the sigma type (sigS, sigT) with the respective
545545 constructor depending on the sort *)
546
547 let find_sigma_data s =
548 match s with
549 | Prop Pos | Type _ -> build_sigma_type () (* Set/Type *)
550 | Prop Null -> error "find_sigma_data"
546 (* J.F.: correction du bug #1167 en accord avec Hugo. *)
547
548 let find_sigma_data s = build_sigma_type ()
551549
552550 (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
553551 index bound in [rty]
+18
-13
tactics/extratactics.ml4 less more
77
88 (*i camlp4deps: "parsing/grammar.cma" i*)
99
10 (* $Id: extratactics.ml4 8926 2006-06-08 20:23:17Z herbelin $ *)
10 (* $Id: extratactics.ml4 8979 2006-06-23 10:17:14Z herbelin $ *)
1111
1212 open Pp
1313 open Pcoq
4545 | None -> mt ()
4646 | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t)
4747
48 (* Julien Forest: on voudrait pouvoir passer la loc mais je
49 n'ai pas reussi
50 *)
48 let pr_in_hyp = function
49 | None -> mt ()
50 | Some id -> spc () ++ hov 2 (str "in" ++ spc () ++ Nameops.pr_id id)
5151
5252 let pr_in_arg_hyp _prc _prlc _prtac opt_c =
53 match opt_c with
54 | None -> mt ()
55 | Some id -> spc () ++ hov 2 (str "by" ++ spc () ++ Nameops.pr_id id)
53 pr_in_hyp (Util.option_map snd opt_c)
54
55 let pr_in_arg_hyp_typed _prc _prlc _prtac =
56 pr_in_hyp
5657
5758 ARGUMENT EXTEND by_arg_tac
5859 TYPED AS tactic_opt
6263 END
6364
6465 ARGUMENT EXTEND in_arg_hyp
65 TYPED AS ident_opt
66 PRINTED BY pr_in_arg_hyp
67 | [ "in" ident(c) ] -> [ Some (c) ]
66 TYPED AS var_opt
67 PRINTED BY pr_in_arg_hyp_typed
68 RAW_TYPED AS var_opt
69 RAW_PRINTED BY pr_in_arg_hyp
70 GLOB_TYPED AS var_opt
71 GLOB_PRINTED BY pr_in_arg_hyp
72 | [ "in" hyp(c) ] -> [ Some (c) ]
6873 | [ ] -> [ None ]
6974 END
7075
182187 [ autorewrite Refiner.tclIDTAC l ]
183188 | [ "autorewrite" "with" ne_preident_list(l) "using" tactic(t) ] ->
184189 [ autorewrite (snd t) l ]
185 | [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) ] ->
190 | [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) ] ->
186191 [ autorewrite_in id Refiner.tclIDTAC l ]
187 | [ "autorewrite" "with" ne_preident_list(l) "in" ident(id) "using" tactic(t) ] ->
192 | [ "autorewrite" "with" ne_preident_list(l) "in" hyp(id) "using" tactic(t) ] ->
188193 [ autorewrite_in id (snd t) l ]
189194 END
190195
282287
283288 TACTIC EXTEND setoid_symmetry
284289 [ "setoid_symmetry" ] -> [ setoid_symmetry ]
285 | [ "setoid_symmetry" "in" ident(n) ] -> [ setoid_symmetry_in n ]
290 | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
286291 END
287292
288293 TACTIC EXTEND setoid_reflexivity
+9
-6
tactics/extratactics.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: extratactics.mli 8780 2006-05-02 21:58:58Z letouzey $ i*)
8 (*i $Id: extratactics.mli 8977 2006-06-23 10:09:59Z herbelin $ i*)
99
10 open Util
1011 open Names
1112 open Term
1213 open Proof_type
1314 open Rawterm
15 open Tacexpr
16 open Topconstr
17 open Genarg
1418
1519 val h_discrHyp : quantified_hypothesis -> tactic
1620 val h_injHyp : quantified_hypothesis -> tactic
2529 *)
2630
2731
28 val rawwit_in_arg_hyp: identifier option Tacexpr.raw_abstract_argument_type
29 val in_arg_hyp: identifier option Pcoq.Gram.Entry.e
32 val rawwit_in_arg_hyp: identifier located option raw_abstract_argument_type
33
34 val in_arg_hyp: identifier located option Pcoq.Gram.Entry.e
3035
3136
3237
3338 val rawwit_by_arg_tac :
34 (Tacexpr.raw_tactic_expr option, Topconstr.constr_expr,
35 Tacexpr.raw_tactic_expr)
36 Genarg.abstract_argument_type
39 (raw_tactic_expr option, constr_expr, raw_tactic_expr) abstract_argument_type
3740
3841 val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e
+227
-216
tactics/tacinterp.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (* $Id: tacinterp.ml 8926 2006-06-08 20:23:17Z herbelin $ *)
8 (* $Id: tacinterp.ml 8991 2006-06-27 11:59:50Z herbelin $ *)
99
1010 open Constrintern
1111 open Closure
7272 | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
7373 (* bound as in "Intro H" but which may be bound *)
7474 (* later, as in "tac" in "Intro H; tac" *)
75 | VConstr of constr (* includes idents known bound and references *)
75 | VConstr of constr (* includes idents known to be bound and references *)
7676 | VConstr_context of constr
7777 | VRec of value ref
7878
115115 | VVoid -> str "()"
116116 | VInteger n -> int n
117117 | VIntroPattern ipat -> pr_intro_pattern ipat
118 | VConstr c -> pr_lconstr_env env c
119 | VConstr_context c -> pr_lconstr_env env c
120 | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "<fun>"
118 | VConstr c | VConstr_context c ->
119 (match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
120 | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "a tactic"
121121
122122 (* Transforms a named_context into a (string * constr) list *)
123123 let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
166166 | ast ->
167167 anomalylabstrm "constrOut" (str "Not a Dynamic ast")
168168
169 let loc = dummy_loc
169 let dloc = dummy_loc
170170
171171 (* Globalizes the identifier *)
172
173172 let find_reference env qid =
174173 (* We first look for a variable of the current proof *)
175174 match repr_qualid qid with
177176 -> VarRef id
178177 | _ -> Nametab.locate qid
179178
180 let coerce_to_reference env = function
181 | VConstr c ->
182 (try global_of_constr c
183 with Not_found -> invalid_arg_loc (loc, "Not a reference"))
184 | v -> errorlabstrm "coerce_to_reference"
185 (str "The value" ++ spc () ++ pr_value env v ++
186 str "cannot be coerced to a reference")
187
188 (* turns a value into an evaluable reference *)
189179 let error_not_evaluable s =
190180 errorlabstrm "evalref_of_ref"
191181 (str "Cannot coerce" ++ spc () ++ s ++ spc () ++
192182 str "to an evaluable reference")
193
194 let coerce_to_evaluable_ref env c =
195 let ev = match c with
196 | VConstr c when isConst c -> EvalConstRef (destConst c)
197 | VConstr c when isVar c -> EvalVarRef (destVar c)
198 | VIntroPattern (IntroIdentifier id)
199 when Environ.evaluable_named id env -> EvalVarRef id
200 | _ -> error_not_evaluable (pr_value env c)
201 in
202 if not (Tacred.is_evaluable env ev) then
203 error_not_evaluable (pr_value env c);
204 ev
205
206 let coerce_to_inductive = function
207 | VConstr c when isInd c -> destInd c
208 | x ->
209 try
210 let r = match x with
211 | VConstr c -> global_of_constr c
212 | _ -> failwith "" in
213 errorlabstrm "coerce_to_inductive"
214 (pr_global r ++ str " is not an inductive type")
215 with _ ->
216 errorlabstrm "coerce_to_inductive"
217 (str "Found an argument which should be an inductive type")
218
219183
220184 (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
221185 let atomic_mactab = ref Idmap.empty
226190 let _ =
227191 let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in
228192 List.iter
229 (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t)))
193 (fun (s,t) -> add_primitive_tactic s (TacAtom(dloc,t)))
230194 [ "red", TacReduce(Red false,nocl);
231195 "hnf", TacReduce(Hnf,nocl);
232196 "simpl", TacReduce(Simpl None,nocl);
353317
354318 let strict_check = ref false
355319
356 let adjust_loc loc = if !strict_check then dummy_loc else loc
320 let adjust_loc loc = if !strict_check then dloc else loc
357321
358322 (* Globalize a name which must be bound -- actually just check it is bound *)
359323 let intern_hyp ist (loc,id as locid) =
360324 if not !strict_check then
361325 locid
362326 else if find_ident id ist then
363 (dummy_loc,id)
327 (dloc,id)
364328 else
365329 Pretype_errors.error_var_not_found_loc loc id
366330
400364
401365 let intern_constr_reference strict ist = function
402366 | Ident (_,id) when (not strict & find_hyp id ist) or find_ctxvar id ist ->
403 RVar (loc,id), None
367 RVar (dloc,id), None
404368 | r ->
405369 let loc,qid = qualid_of_reference r in
406370 RRef (loc,locate_global qid), if strict then None else Some (CRef r)
473437 | ElimOnIdent (loc,id) ->
474438 if !strict_check then
475439 (* If in a defined tactic, no intros-until *)
476 ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id))))
440 ElimOnConstr (intern_constr ist (CRef (Ident (dloc,id))))
477441 else
478442 ElimOnIdent (loc,id)
479443
508472
509473 let intern_constr_occurrence ist (l,c) = (l,intern_constr ist c)
510474
511 let intern_redexp ist = function
475 let intern_red_expr ist = function
512476 | Unfold l -> Unfold (List.map (intern_unfold ist) l)
513477 | Fold l -> Fold (List.map (intern_constr ist) l)
514478 | Cbv f -> Cbv (intern_flag ist f)
538502 pattern_of_rawconstr c
539503
540504 (* Reads a pattern *)
541 let intern_pattern evc env lfun = function
505 let intern_pattern sigma env lfun = function
542506 | Subterm (ido,pc) ->
543 let (metas,pat) = interp_constrpattern_gen evc env lfun pc in
507 let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in
544508 ido, metas, Subterm (ido,pat)
545509 | Term pc ->
546 let (metas,pat) = interp_constrpattern_gen evc env lfun pc in
510 let (metas,pat) = interp_constrpattern_gen sigma env lfun pc in
547511 None, metas, Term pat
548512
549513 let intern_constr_may_eval ist = function
550 | ConstrEval (r,c) -> ConstrEval (intern_redexp ist r,intern_constr ist c)
514 | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
551515 | ConstrContext (locid,c) ->
552516 ConstrContext (intern_hyp ist locid,intern_constr ist c)
553517 | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
572536 output_string ch "</REQUEST>\n"
573537
574538 (* Reads the hypotheses of a Match Context rule *)
575 let rec intern_match_context_hyps evc env lfun = function
539 let rec intern_match_context_hyps sigma env lfun = function
576540 | (Hyp ((_,na) as locna,mp))::tl ->
577 let ido, metas1, pat = intern_pattern evc env lfun mp in
578 let lfun, metas2, hyps = intern_match_context_hyps evc env lfun tl in
541 let ido, metas1, pat = intern_pattern sigma env lfun mp in
542 let lfun, metas2, hyps = intern_match_context_hyps sigma env lfun tl in
579543 let lfun' = name_cons na (option_cons ido lfun) in
580544 lfun', metas1@metas2, Hyp (locna,pat)::hyps
581545 | [] -> lfun, [], []
708672
709673 (* Conversion *)
710674 | TacReduce (r,cl) ->
711 TacReduce (intern_redexp ist r, clause_app (intern_hyp_location ist) cl)
675 TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
712676 | TacChange (occl,c,cl) ->
713677 TacChange (option_map (intern_constr_occurrence ist) occl,
714678 intern_constr ist c, clause_app (intern_hyp_location ist) cl)
866830 in_gen globwit_quant_hyp
867831 (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x))
868832 | RedExprArgType ->
869 in_gen globwit_red_expr (intern_redexp ist (out_gen rawwit_red_expr x))
833 in_gen globwit_red_expr (intern_red_expr ist (out_gen rawwit_red_expr x))
870834 | OpenConstrArgType b ->
871835 in_gen (globwit_open_constr_gen b)
872836 ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen b) x)))
913877 | None -> []
914878 | Some id -> [id,VConstr_context ctxt]
915879
916 (* Reads a pattern by substituing vars of lfun *)
880 (* Reads a pattern by substituting vars of lfun *)
917881 let eval_pattern lfun c =
918 let lvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lfun in
882 let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in
919883 instantiate_pattern lvar c
920884
921 let read_pattern evc env lfun = function
885 let read_pattern lfun = function
922886 | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc)
923887 | Term pc -> Term (eval_pattern lfun pc)
924888
925889 (* Reads the hypotheses of a Match Context rule *)
926890 let cons_and_check_name id l =
927891 if List.mem id l then
928 user_err_loc (loc,"read_match_context_hyps",
892 user_err_loc (dloc,"read_match_context_hyps",
929893 str ("Hypothesis pattern-matching variable "^(string_of_id id)^
930894 " used twice in the same pattern"))
931895 else id::l
932896
933 let rec read_match_context_hyps evc env lfun lidh = function
897 let rec read_match_context_hyps lfun lidh = function
934898 | (Hyp ((loc,na) as locna,mp))::tl ->
935899 let lidh' = name_fold cons_and_check_name na lidh in
936 Hyp (locna,read_pattern evc env lfun mp)::
937 (read_match_context_hyps evc env lfun lidh' tl)
900 Hyp (locna,read_pattern lfun mp)::
901 (read_match_context_hyps lfun lidh' tl)
938902 | [] -> []
939903
940904 (* Reads the rules of a Match Context or a Match *)
941 let rec read_match_rule evc env lfun = function
942 | (All tc)::tl -> (All tc)::(read_match_rule evc env lfun tl)
905 let rec read_match_rule lfun = function
906 | (All tc)::tl -> (All tc)::(read_match_rule lfun tl)
943907 | (Pat (rl,mp,tc))::tl ->
944 Pat (read_match_context_hyps evc env lfun [] rl,
945 read_pattern evc env lfun mp,tc)
946 ::(read_match_rule evc env lfun tl)
908 Pat (read_match_context_hyps lfun [] rl, read_pattern lfun mp,tc)
909 :: read_match_rule lfun tl
947910 | [] -> []
948911
949912 (* For Match Context and Match *)
1003966 try shortest_qualid_of_global Idset.empty (global_of_constr c)
1004967 with _ -> invalid_arg_loc (loc, "Not a global reference")
1005968
969 let is_variable env id =
970 List.mem id (ids_of_named_context (Environ.named_context env))
971
1006972 (* Debug reference *)
1007973 let debug = ref DebugOff
1008974
1012978 (* Gives the state of debug *)
1013979 let get_debug () = !debug
1014980
981 let error_ltac_variable loc id env v s =
982 user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++
983 str " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
984 str "which cannot be coerced to " ++ str s)
985
986 exception CannotCoerceTo of string
987
988 (* Raise Not_found if not in interpretation sign *)
989 let try_interp_ltac_var coerce ist env (loc,id) =
990 let v = List.assoc id ist.lfun in
991 try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s
992
993 let interp_ltac_var coerce ist env locid =
994 try try_interp_ltac_var coerce ist env locid
995 with Not_found -> anomaly "Detected as ltac var at interning time"
996
1015997 (* Interprets an identifier which must be fresh *)
1016 let interp_ident ist id =
1017 try match List.assoc id ist.lfun with
998 let coerce_to_ident env = function
1018999 | VIntroPattern (IntroIdentifier id) -> id
1019 | VConstr c when isVar c ->
1020 (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
1021 (* c is then expected not to belong to the proof context *)
1022 (* would be checkable if env were known from interp_ident *)
1000 | VConstr c when isVar c & not (is_variable env (destVar c)) ->
1001 (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
10231002 destVar c
1024 | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++
1025 str ") should have been bound to an identifier")
1003 | v -> raise (CannotCoerceTo "a fresh identifier")
1004
1005 let interp_ident ist gl id =
1006 let env = pf_env gl in
1007 try try_interp_ltac_var (coerce_to_ident env) ist (Some env) (dloc,id)
10261008 with Not_found -> id
10271009
1028 let interp_hint_base ist s =
1029 try match List.assoc (id_of_string s) ist.lfun with
1030 | VIntroPattern (IntroIdentifier id) -> string_of_id id
1031 | _ -> user_err_loc(loc,"", str "An ltac name (" ++ str s ++
1032 str ") should have been bound to a hint base name")
1033 with Not_found -> s
1034
1035 let interp_intro_pattern_var ist id =
1036 try match List.assoc id ist.lfun with
1010 (* Interprets an optional identifier which must be fresh *)
1011 let interp_name ist gl = function
1012 | Anonymous -> Anonymous
1013 | Name id -> Name (interp_ident ist gl id)
1014
1015 let coerce_to_intro_pattern env = function
10371016 | VIntroPattern ipat -> ipat
10381017 | VConstr c when isVar c ->
1039 (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
1040 (* c is then expected not to belong to the proof context *)
1041 (* would be checkable if env were known from interp_ident *)
1018 (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
1019 (* but also in "destruct H as (H,H')" *)
10421020 IntroIdentifier (destVar c)
1043 | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++
1044 str ") should have been bound to an introduction pattern")
1021 | v -> raise (CannotCoerceTo "an introduction pattern")
1022
1023 let interp_intro_pattern_var ist env id =
1024 try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env)(dloc,id)
10451025 with Not_found -> IntroIdentifier id
10461026
1047 let interp_int lfun (loc,id) =
1048 try match List.assoc id lfun with
1027 let coerce_to_hint_base = function
1028 | VIntroPattern (IntroIdentifier id) -> string_of_id id
1029 | _ -> raise (CannotCoerceTo "a hint base name")
1030
1031 let interp_hint_base ist s =
1032 try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s)
1033 with Not_found -> s
1034
1035 let coerce_to_int = function
10491036 | VInteger n -> n
1050 | _ -> user_err_loc(loc,"interp_int",str "should be bound to an integer")
1051 with Not_found -> user_err_loc (loc,"interp_int",str "Unbound variable")
1037 | v -> raise (CannotCoerceTo "an integer")
1038
1039 let interp_int ist locid =
1040 try try_interp_ltac_var coerce_to_int ist None locid
1041 with Not_found -> user_err_loc(fst locid,"interp_int",str "Unbound variable")
10521042
10531043 let interp_int_or_var ist = function
1054 | ArgVar locid -> interp_int ist.lfun locid
1044 | ArgVar locid -> interp_int ist locid
10551045 | ArgArg n -> n
10561046
10571047 let constr_of_value env = function
10591049 | VIntroPattern (IntroIdentifier id) -> constr_of_id env id
10601050 | _ -> raise Not_found
10611051
1062 let is_variable env id =
1063 List.mem id (ids_of_named_context (Environ.named_context env))
1064
1065 let variable_of_value env = function
1052 let coerce_to_hyp env = function
10661053 | VConstr c when isVar c -> destVar c
10671054 | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
1068 | _ -> raise Not_found
1069
1070 (* Extract a variable from a value, if any *)
1071 let id_of_Identifier = variable_of_value
1072
1073 (* Extract a constr from a value, if any *)
1074 let constr_of_VConstr = constr_of_value
1055 | _ -> raise (CannotCoerceTo "a variable")
10751056
10761057 (* Interprets a bound variable (especially an existing hypothesis) *)
1077 let interp_hyp ist gl (loc,id) =
1058 let interp_hyp ist gl (loc,id as locid) =
1059 let env = pf_env gl in
10781060 (* Look first in lfun for a value coercible to a variable *)
1079 try
1080 let v = List.assoc id ist.lfun in
1081 try variable_of_value (pf_env gl) v
1082 with Not_found ->
1083 errorlabstrm "coerce_to_variable"
1084 (str "Cannot coerce" ++ spc () ++ pr_value (pf_env gl) v ++ spc () ++
1085 str "to a variable")
1061 try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid
10861062 with Not_found ->
10871063 (* Then look if bound in the proof context at calling time *)
1088 if is_variable (pf_env gl) id then id
1089 else
1090 user_err_loc (loc,"eval_variable",pr_id id ++ str " not found")
1091
1092 let interp_name ist = function
1093 | Anonymous -> Anonymous
1094 | Name id -> Name (interp_ident ist id)
1064 if is_variable env id then id
1065 else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found")
10951066
10961067 let interp_clause_pattern ist gl (l,occl) =
10971068 let rec check acc = function
11041075 in (l,check [] occl)
11051076
11061077 (* Interprets a qualified name *)
1078 let coerce_to_reference env v =
1079 try match v with
1080 | VConstr c -> global_of_constr c (* may raise Not_found *)
1081 | _ -> raise Not_found
1082 with Not_found -> raise (CannotCoerceTo "a reference")
1083
11071084 let interp_reference ist env = function
11081085 | ArgArg (_,r) -> r
1109 | ArgVar (loc,id) -> coerce_to_reference env (List.assoc id ist.lfun)
1086 | ArgVar locid ->
1087 interp_ltac_var (coerce_to_reference env) ist (Some env) locid
11101088
11111089 let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
1090
1091 let coerce_to_inductive = function
1092 | VConstr c when isInd c -> destInd c
1093 | _ -> raise (CannotCoerceTo "an inductive type")
11121094
11131095 let interp_inductive ist = function
11141096 | ArgArg r -> r
1115 | ArgVar (_,id) -> coerce_to_inductive (List.assoc id ist.lfun)
1097 | ArgVar locid -> interp_ltac_var coerce_to_inductive ist None locid
1098
1099 let coerce_to_evaluable_ref env v =
1100 let ev = match v with
1101 | VConstr c when isConst c -> EvalConstRef (destConst c)
1102 | VConstr c when isVar c -> EvalVarRef (destVar c)
1103 | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env)
1104 -> EvalVarRef id
1105 | _ -> raise (CannotCoerceTo "an evaluable reference")
1106 in
1107 if not (Tacred.is_evaluable env ev) then
1108 raise (CannotCoerceTo "an evaluable reference")
1109 else
1110 ev
11161111
11171112 let interp_evaluable ist env = function
11181113 | ArgArg (r,Some (loc,id)) ->
11191114 (* Maybe [id] has been introduced by Intro-like tactics *)
11201115 (try match Environ.lookup_named id env with
1121 | (_,Some _,_) -> EvalVarRef id
1122 | _ -> error_not_evaluable (pr_id id)
1123 with Not_found ->
1124 match r with
1125 | EvalConstRef _ -> r
1126 | _ -> Pretype_errors.error_var_not_found_loc loc id)
1116 | (_,Some _,_) -> EvalVarRef id
1117 | _ -> error_not_evaluable (pr_id id)
1118 with Not_found ->
1119 match r with
1120 | EvalConstRef _ -> r
1121 | _ -> Pretype_errors.error_var_not_found_loc loc id)
11271122 | ArgArg (r,None) -> r
1128 | ArgVar (_,id) -> coerce_to_evaluable_ref env (List.assoc id ist.lfun)
1123 | ArgVar locid ->
1124 interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
11291125
11301126 (* Interprets an hypothesis name *)
11311127 let interp_hyp_location ist gl ((occs,id),hl) =
11701166 List.fold_right (fun (x,csr) a ->
11711167 try (x,Retyping.get_judgment_of env sigma csr)::a with
11721168 | Anomaly _ -> a) lst []
1173
1174 (* List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*)
11751169
11761170 let implicit_tactic = ref None
11771171
12761270
12771271 let pf_interp_pattern ist gl = interp_pattern ist (project gl) (pf_env gl)
12781272
1279 let redexp_interp ist sigma env = function
1273 let interp_red_expr ist sigma env = function
12801274 | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
12811275 | Fold l -> Fold (List.map (interp_constr ist sigma env) l)
12821276 | Cbv f -> Cbv (interp_flag ist env f)
12851279 | Simpl o -> Simpl (option_map (interp_pattern ist sigma env) o)
12861280 | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
12871281
1288 let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl)
1282 let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
12891283
12901284 let interp_may_eval f ist gl = function
12911285 | ConstrEval (r,c) ->
1292 let redexp = pf_redexp_interp ist gl r in
1286 let redexp = pf_interp_red_expr ist gl r in
12931287 pf_reduction_of_red_expr gl redexp (f ist gl c)
12941288 | ConstrContext ((loc,s),c) ->
12951289 (try
13221316 | [] -> mt()
13231317 | MsgString s :: l -> pr_arg str s ++ interp_message ist l
13241318 | MsgInt n :: l -> pr_arg int n ++ interp_message ist l
1325 | MsgIdent (_,id) :: l ->
1319 | MsgIdent (loc,id) :: l ->
13261320 let v =
13271321 try List.assoc id ist.lfun
1328 with Not_found -> user_err_loc (loc,"",pr_id id ++ str " not found") in
1322 with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found") in
13291323 pr_arg message_of_value v ++ interp_message ist l
13301324
13311325 let rec interp_message_nl ist = function
13321326 | [] -> mt()
13331327 | l -> interp_message ist l ++ fnl()
13341328
1335 let rec interp_intro_pattern ist = function
1336 | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist l)
1337 | IntroIdentifier id -> interp_intro_pattern_var ist id
1329 let rec interp_intro_pattern ist gl = function
1330 | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l)
1331 | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id
13381332 | IntroWildcard | IntroAnonymous as x -> x
13391333
1340 and interp_case_intro_pattern ist =
1341 List.map (List.map (interp_intro_pattern ist))
1334 and interp_case_intro_pattern ist gl =
1335 List.map (List.map (interp_intro_pattern ist gl))
13421336
13431337 (* Quantified named or numbered hypothesis or hypothesis in context *)
13441338 (* (as in Inversion) *)
1339 let coerce_to_quantified_hypothesis = function
1340 | VInteger n -> AnonHyp n
1341 | VIntroPattern (IntroIdentifier id) -> NamedHyp id
1342 | v -> raise (CannotCoerceTo "a quantified hypothesis")
1343
13451344 let interp_quantified_hypothesis ist = function
13461345 | AnonHyp n -> AnonHyp n
13471346 | NamedHyp id ->
1348 try match List.assoc id ist.lfun with
1349 | VInteger n -> AnonHyp n
1350 | VIntroPattern (IntroIdentifier id) -> NamedHyp id
1351 | _ -> raise Not_found
1352 with Not_found -> NamedHyp id
1347 try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
1348 with Not_found
1349 | Stdpp.Exc_located (_, UserError _) | UserError _ (*Compat provisoire*)
1350 -> NamedHyp id
13531351
13541352 (* Quantified named or numbered hypothesis or hypothesis in context *)
13551353 (* (as in Inversion) *)
1354 let coerce_to_decl_or_quant_hyp env = function
1355 | VInteger n -> AnonHyp n
1356 | v ->
1357 try NamedHyp (coerce_to_hyp env v)
1358 with CannotCoerceTo _ ->
1359 raise (CannotCoerceTo "a declared or quantified hypothesis")
1360
13561361 let interp_declared_or_quantified_hypothesis ist gl = function
13571362 | AnonHyp n -> AnonHyp n
13581363 | NamedHyp id ->
1359 try match List.assoc id ist.lfun with
1360 | VInteger n -> AnonHyp n
1361 | v -> NamedHyp (variable_of_value (pf_env gl) v)
1364 let env = pf_env gl in
1365 try try_interp_ltac_var
1366 (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
13621367 with Not_found -> NamedHyp id
13631368
13641369 let interp_induction_arg ist gl = function
13941399 | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
13951400 | TacArg a -> interp_tacarg ist gl a
13961401 (* Delayed evaluation *)
1397 | t -> VTactic (dummy_loc,eval_tactic ist t)
1402 | t -> VTactic (dloc,eval_tactic ist t)
13981403
13991404 in check_for_interrupt ();
14001405 match ist.debug with
14361441 | TacVoid -> VVoid
14371442 | Reference r -> interp_ltac_reference false false ist gl r
14381443 | Integer n -> VInteger n
1439 | IntroPattern ipat -> VIntroPattern ipat
1444 | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat)
14401445 | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
14411446 | MetaIdArg (loc,id) -> assert false
14421447 | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r
14661471 else if tg = "constr" then
14671472 VConstr (constr_out t)
14681473 else
1469 anomaly_loc (loc, "Tacinterp.val_interp",
1474 anomaly_loc (dloc, "Tacinterp.val_interp",
14701475 (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
14711476
14721477 (* Interprets an application node *)
15401545 start_proof id (Local,Proof Lemma) ndc typ (fun _ _ -> ());
15411546 by t;
15421547 let (_,({const_entry_body = pft},_,_)) = cook_proof () in
1543 delete_proof (dummy_loc,id);
1548 delete_proof (dloc,id);
15441549 pft
15451550 with | NotTactic ->
1546 delete_proof (dummy_loc,id);
1551 delete_proof (dloc,id);
15471552 errorlabstrm "Tacinterp.interp_letin"
15481553 (str "Term or fully applied tactic expected in Let")
15491554 in (id,VConstr (mkCast (csr,DEFAULTcast, typ)))::(interp_letin ist gl tl)
15981603 end in
15991604 let env = pf_env g in
16001605 apply_match_context ist env g 0 lmr
1601 (read_match_rule (project g) env (fst (constr_list ist env)) lmr)
1606 (read_match_rule (fst (constr_list ist env)) lmr)
16021607
16031608 (* Tries to match the hypotheses in a Match Context *)
16041609 and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
16281633 interp_tacarg ist gl (System.connect f g com)
16291634
16301635 (* Interprets extended tactic generic arguments *)
1631 and interp_genarg ist goal x =
1636 and interp_genarg ist gl x =
16321637 match genarg_tag x with
16331638 | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
16341639 | IntArgType -> in_gen wit_int (out_gen globwit_int x)
16411646 in_gen wit_pre_ident (out_gen globwit_pre_ident x)
16421647 | IntroPatternArgType ->
16431648 in_gen wit_intro_pattern
1644 (interp_intro_pattern ist (out_gen globwit_intro_pattern x))
1649 (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
16451650 | IdentArgType ->
1646 in_gen wit_ident (interp_ident ist (out_gen globwit_ident x))
1651 in_gen wit_ident (interp_ident ist gl (out_gen globwit_ident x))
16471652 | VarArgType ->
1648 in_gen wit_var (interp_hyp ist goal (out_gen globwit_var x))
1653 in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
16491654 | RefArgType ->
1650 in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x))
1655 in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
16511656 | SortArgType ->
16521657 in_gen wit_sort
16531658 (destSort
1654 (pf_interp_constr ist goal
1655 (RSort (dummy_loc,out_gen globwit_sort x), None)))
1659 (pf_interp_constr ist gl
1660 (RSort (dloc,out_gen globwit_sort x), None)))
16561661 | ConstrArgType ->
1657 in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x))
1662 in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
16581663 | ConstrMayEvalArgType ->
1659 in_gen wit_constr_may_eval (interp_constr_may_eval ist goal (out_gen globwit_constr_may_eval x))
1664 in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
16601665 | QuantHypArgType ->
16611666 in_gen wit_quant_hyp
1662 (interp_declared_or_quantified_hypothesis ist goal
1667 (interp_declared_or_quantified_hypothesis ist gl
16631668 (out_gen globwit_quant_hyp x))
16641669 | RedExprArgType ->
1665 in_gen wit_red_expr (pf_redexp_interp ist goal (out_gen globwit_red_expr x))
1670 in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x))
16661671 | OpenConstrArgType casted ->
16671672 in_gen (wit_open_constr_gen casted)
1668 (pf_interp_open_constr casted ist goal
1673 (pf_interp_open_constr casted ist gl
16691674 (snd (out_gen (globwit_open_constr_gen casted) x)))
16701675 | ConstrWithBindingsArgType ->
16711676 in_gen wit_constr_with_bindings
1672 (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x))
1677 (interp_constr_with_bindings ist gl (out_gen globwit_constr_with_bindings x))
16731678 | BindingsArgType ->
16741679 in_gen wit_bindings
1675 (interp_bindings ist goal (out_gen globwit_bindings x))
1676 | List0ArgType _ -> app_list0 (interp_genarg ist goal) x
1677 | List1ArgType _ -> app_list1 (interp_genarg ist goal) x
1678 | OptArgType _ -> app_opt (interp_genarg ist goal) x
1679 | PairArgType _ -> app_pair (interp_genarg ist goal) (interp_genarg ist goal) x
1680 (interp_bindings ist gl (out_gen globwit_bindings x))
1681 | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
1682 | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
1683 | OptArgType _ -> app_opt (interp_genarg ist gl) x
1684 | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
16801685 | ExtraArgType s ->
16811686 match tactic_genarg_level s with
16821687 | Some n ->
16831688 (* Special treatment of tactic arguments *)
16841689 in_gen (wit_tactic n) (out_gen (globwit_tactic n) x)
16851690 | None ->
1686 lookup_interp_genarg s ist goal x
1691 lookup_interp_genarg s ist gl x
16871692
16881693 (* Interprets the Match expressions *)
16891694 and interp_match ist g lz constr lmr =
17111716 | _ ->
17121717 errorlabstrm "Tacinterp.apply_match" (str
17131718 "No matching clauses for match") in
1714 let env = pf_env g in
1715 let csr =
1716 try constr_of_value env (val_interp ist g constr)
1717 with Not_found ->
1718 errorlabstrm "Tacinterp.apply_match"
1719 (str "Argument of match does not evaluate to a term") in
1720 let ilr = read_match_rule (project g) env (fst (constr_list ist env)) lmr in
1719 let csr = interp_ltac_constr ist g constr in
1720 let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in
17211721 apply_match ist csr ilr
1722
1723 (* Interprets tactic expressions : returns a "constr" *)
1724 and interp_ltac_constr ist gl e =
1725 try constr_of_value (pf_env gl) (val_interp ist gl e)
1726 with Not_found ->
1727 errorlabstrm "" (str "Must evaluate to a term")
17221728
17231729 (* Interprets tactic expressions : returns a "tactic" *)
17241730 and interp_tactic ist tac gl =
17251731 try tactic_of_value (val_interp ist gl tac) gl
1726 with | NotTactic ->
1727 errorlabstrm "Tacinterp.interp_tactic" (str
1728 "Must be a command or must give a tactic value")
1732 with NotTactic ->
1733 errorlabstrm "" (str "Must be a command or must give a tactic value")
17291734
17301735 (* Interprets a primitive tactic *)
17311736 and interp_atomic ist gl = function
17321737 (* Basic tactics *)
17331738 | TacIntroPattern l ->
1734 h_intro_patterns (List.map (interp_intro_pattern ist) l)
1739 h_intro_patterns (List.map (interp_intro_pattern ist gl) l)
17351740 | TacIntrosUntil hyp ->
17361741 h_intros_until (interp_quantified_hypothesis ist hyp)
17371742 | TacIntroMove (ido,ido') ->
1738 h_intro_move (option_map (interp_ident ist) ido)
1743 h_intro_move (option_map (interp_ident ist gl) ido)
17391744 (option_map (interp_hyp ist gl) ido')
17401745 | TacAssumption -> h_assumption
17411746 | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
17471752 | TacElimType c -> h_elim_type (pf_interp_type ist gl c)
17481753 | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb)
17491754 | TacCaseType c -> h_case_type (pf_interp_type ist gl c)
1750 | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist) idopt) n
1755 | TacFix (idopt,n) -> h_fix (option_map (interp_ident ist gl) idopt) n
17511756 | TacMutualFix (id,n,l) ->
1752 let f (id,n,c) = (interp_ident ist id,n,pf_interp_type ist gl c) in
1753 h_mutual_fix (interp_ident ist id) n (List.map f l)
1754 | TacCofix idopt -> h_cofix (option_map (interp_ident ist) idopt)
1757 let f (id,n,c) = (interp_ident ist gl id,n,pf_interp_type ist gl c) in
1758 h_mutual_fix (interp_ident ist gl id) n (List.map f l)
1759 | TacCofix idopt -> h_cofix (option_map (interp_ident ist gl) idopt)
17551760 | TacMutualCofix (id,l) ->
1756 let f (id,c) = (interp_ident ist id,pf_interp_type ist gl c) in
1757 h_mutual_cofix (interp_ident ist id) (List.map f l)
1761 let f (id,c) = (interp_ident ist gl id,pf_interp_type ist gl c) in
1762 h_mutual_cofix (interp_ident ist gl id) (List.map f l)
17581763 | TacCut c -> h_cut (pf_interp_type ist gl c)
17591764 | TacAssert (t,ipat,c) ->
17601765 let c = (if t=None then pf_interp_constr else pf_interp_type) ist gl c in
17611766 abstract_tactic (TacAssert (t,ipat,c))
17621767 (Tactics.forward (option_map (interp_tactic ist) t)
1763 (interp_intro_pattern ist ipat) c)
1768 (interp_intro_pattern ist gl ipat) c)
17641769 | TacGeneralize cl -> h_generalize (List.map (pf_interp_constr ist gl) cl)
17651770 | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
17661771 | TacLetTac (na,c,clp) ->
17671772 let clp = interp_clause ist gl clp in
1768 h_let_tac (interp_name ist na) (pf_interp_constr ist gl c) clp
1773 h_let_tac (interp_name ist gl na) (pf_interp_constr ist gl c) clp
17691774 (* | TacInstantiate (n,c,idh) -> h_instantiate n (fst c)
17701775 (* pf_interp_constr ist gl c *)
17711776 (match idh with
17931798 | TacNewInduction (lc,cbo,ids) ->
17941799 h_new_induction (List.map (interp_induction_arg ist gl) lc)
17951800 (option_map (interp_constr_with_bindings ist gl) cbo)
1796 (interp_intro_pattern ist ids)
1801 (interp_intro_pattern ist gl ids)
17971802 | TacSimpleDestruct h ->
17981803 h_simple_destruct (interp_quantified_hypothesis ist h)
17991804 | TacNewDestruct (c,cbo,ids) ->
18001805 h_new_destruct (List.map (interp_induction_arg ist gl) c)
18011806 (option_map (interp_constr_with_bindings ist gl) cbo)
1802 (interp_intro_pattern ist ids)
1807 (interp_intro_pattern ist gl ids)
18031808 | TacDoubleInduction (h1,h2) ->
18041809 let h1 = interp_quantified_hypothesis ist h1 in
18051810 let h2 = interp_quantified_hypothesis ist h2 in
18191824 | TacMove (dep,id1,id2) ->
18201825 h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2)
18211826 | TacRename (id1,id2) ->
1822 h_rename (interp_hyp ist gl id1) (interp_ident ist (snd id2))
1827 h_rename (interp_hyp ist gl id1) (interp_ident ist gl (snd id2))
18231828
18241829 (* Constructors *)
18251830 | TacLeft bl -> h_left (interp_bindings ist gl bl)
18331838
18341839 (* Conversion *)
18351840 | TacReduce (r,cl) ->
1836 h_reduce (pf_redexp_interp ist gl r) (interp_clause ist gl cl)
1841 h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl)
18371842 | TacChange (occl,c,cl) ->
18381843 h_change (option_map (pf_interp_pattern ist gl) occl)
18391844 (pf_interp_constr ist gl c) (interp_clause ist gl cl)
18501855 (interp_clause ist gl cl)
18511856 | TacInversion (DepInversion (k,c,ids),hyp) ->
18521857 Inv.dinv k (option_map (pf_interp_constr ist gl) c)
1853 (interp_intro_pattern ist ids)
1858 (interp_intro_pattern ist gl ids)
18541859 (interp_declared_or_quantified_hypothesis ist gl hyp)
18551860 | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
18561861 Inv.inv_clause k
1857 (interp_intro_pattern ist ids)
1862 (interp_intro_pattern ist gl ids)
18581863 (List.map (interp_hyp ist gl) idl)
18591864 (interp_declared_or_quantified_hypothesis ist gl hyp)
18601865 | TacInversion (InversionUsing (c,idl),hyp) ->
18731878 | PreIdentArgType ->
18741879 failwith "pre-identifiers cannot be bound"
18751880 | IntroPatternArgType ->
1876 VIntroPattern (out_gen globwit_intro_pattern x)
1881 VIntroPattern
1882 (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
18771883 | IdentArgType ->
1878 VIntroPattern (IntroIdentifier (out_gen globwit_ident x))
1884 VIntroPattern
1885 (IntroIdentifier (interp_ident ist gl (out_gen globwit_ident x)))
18791886 | VarArgType ->
18801887 VConstr (mkVar (interp_hyp ist gl (out_gen globwit_var x)))
18811888 | RefArgType ->
19061913 try tactic_of_value v gl
19071914 with NotTactic -> user_err_loc (loc,"",str "not a tactic")
19081915
1916 let make_empty_glob_sign () =
1917 { ltacvars = ([],[]); ltacrecvars = [];
1918 gsigma = Evd.empty; genv = Global.env() }
1919
19091920 (* Initial call for interpretation *)
19101921 let interp_tac_gen lfun debug t gl =
19111922 interp_tactic { lfun=lfun; debug=debug }
19161927 let eval_tactic t = interp_tactic { lfun=[]; debug=get_debug() } t
19171928
19181929 let interp t = interp_tac_gen [] (get_debug()) t
1930
1931 let eval_ltac_constr gl t =
1932 interp_ltac_constr { lfun=[]; debug=get_debug() } gl
1933 (intern_tactic (make_empty_glob_sign ()) t )
19191934
19201935 (* Hides interpretation for pretty-print *)
19211936 let hide_interp t ot gl =
19641979 | ArgVar _ as x -> x
19651980 | ArgArg x -> ArgArg (f x)
19661981
1967 let subst_located f (_loc,id) = (loc,f id)
1982 let subst_located f (_loc,id) = (dloc,f id)
19681983
19691984 let subst_reference subst =
19701985 subst_or_var (subst_located (subst_kn subst))
21062121
21072122 (* For extensions *)
21082123 | TacExtend (_loc,opn,l) ->
2109 TacExtend (loc,opn,List.map (subst_genarg subst) l)
2124 TacExtend (dloc,opn,List.map (subst_genarg subst) l)
21102125 | TacAlias (_,s,l,(dir,body)) ->
2111 TacAlias (loc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
2126 TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
21122127 (dir,subst_tactic subst body))
21132128
21142129 and subst_tactic subst (t:glob_tactic_expr) = match t with
2115 | TacAtom (_loc,t) -> TacAtom (loc, subst_atomic subst t)
2130 | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
21162131 | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
21172132 | TacLetRecIn (lrc,u) ->
21182133 let lrc = List.map (fun (n,b) -> (n,subst_tactic_fun subst b)) lrc in
21572172 | TacDynamic(_,t) as x ->
21582173 (match tag t with
21592174 | "tactic" | "value" | "constr" -> x
2160 | s -> anomaly_loc (loc, "Tacinterp.val_interp",
2175 | s -> anomaly_loc (dloc, "Tacinterp.val_interp",
21612176 str "Unknown dynamic: <" ++ str s ++ str ">"))
21622177
21632178 (* Reads the rules of a Match Context or a Match *)
22802295 str "There is already an Ltac named " ++ pr_id id);
22812296 kn
22822297
2283 let make_empty_glob_sign () =
2284 { ltacvars = ([],[]); ltacrecvars = [];
2285 gsigma = Evd.empty; genv = Global.env() }
2286
22872298 let add_tacdef isrec tacl =
22882299 (* let isrec = if !Options.p1 then isrec else true in*)
22892300 let rfun = List.map (fun ((loc,id as locid),_) -> (id,make_absolute_name locid)) tacl in
23102321 { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
23112322 x
23122323
2313 let interp_redexp env evc r =
2324 let interp_redexp env sigma r =
23142325 let ist = { lfun=[]; debug=get_debug () } in
2315 let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = evc } in
2316 redexp_interp ist evc env (intern_redexp gist r)
2326 let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
2327 interp_red_expr ist sigma env (intern_red_expr gist r)
23172328
23182329 (***************************************************************************)
23192330 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
+11
-11
tactics/tacinterp.mli less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: tacinterp.mli 7841 2006-01-11 11:24:54Z herbelin $ i*)
8 (*i $Id: tacinterp.mli 8975 2006-06-23 08:52:53Z herbelin $ i*)
99
1010 (*i*)
1111 open Dyn
1212 open Pp
13 open Util
1314 open Names
1415 open Proof_type
1516 open Tacmach
1920 open Genarg
2021 open Topconstr
2122 open Mod_subst
23 open Redexpr
2224 (*i*)
2325
2426 (* Values for interpretation *)
3739 and interp_sign =
3840 { lfun : (identifier * value) list;
3941 debug : debug_info }
40
41 (* Gives the identifier corresponding to an Identifier [tactic_arg] *)
42 val id_of_Identifier : Environ.env -> value -> identifier
43
44 (* Gives the constr corresponding to a Constr [value] *)
45 val constr_of_VConstr : Environ.env -> value -> constr
4642
4743 (* Transforms an id into a constr if possible *)
4844 val constr_of_id : Environ.env -> identifier -> constr
10298 (* Interprets any expression *)
10399 val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
104100
101 (* Interprets an expression that evaluates to a constr *)
102 val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
103 constr
104
105105 (* Interprets redexp arguments *)
106 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr
107 -> Redexpr.red_expr
106 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
108107
109108 (* Interprets tactic expressions *)
110109 val interp_tac_gen : (identifier * value) list ->
111110 debug_info -> raw_tactic_expr -> tactic
112111
113 val interp_hyp : interp_sign -> goal sigma ->
114 identifier Util.located -> identifier
112 val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier
115113
116114 (* Initial call for interpretation *)
117115 val glob_tactic : raw_tactic_expr -> glob_tactic_expr
121119 val eval_tactic : glob_tactic_expr -> tactic
122120
123121 val interp : raw_tactic_expr -> tactic
122
123 val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
124124
125125 val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
126126
+4
-0
test-suite/failure/inductive1.v less more
0 (* A check that sort-polymorphic product is not set too low *)
1
2 Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
3 Check (fun (A:Type) (B:Prop) => (prod A B : Prop)).
+4
-0
test-suite/failure/inductive2.v less more
0 (* A check that sort-polymorphic product is not set too low *)
1
2 Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
3 Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).
+5
-0
test-suite/failure/inductive3.v less more
0 (* Check that the nested inductive types positivity check avoids recursively
1 non uniform parameters (at least if these parameters break positivity) *)
2
3 Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
4 Inductive u : Type := d : u | e : t u -> u.
+7
-0
test-suite/success/CanonicalStructure.v less more
0 (* Bug #1172 *)
1
2 Structure foo : Type := Foo {
3 A : Set; Aopt := option A; unopt : Aopt -> A
4 }.
5
6 Canonical Structure unopt_nat := @Foo nat (fun _ => O).
+7
-4
test-suite/success/Case18.v less more
22 Definition g x :=
33 match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end.
44
5 Eval compute in (g ((1,2),(3,4))).
6 (* (1,3) *)
5 Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)).
76
8 Eval compute in (g ((1,4),(3,2))).
9 (* (1,2) *)
7 Check (refl_equal _ : g ((1,4),(3,2)) = (1,2)).
108
9 Fixpoint max (n m:nat) {struct m} : nat :=
10 match n, m with
11 | S n', S m' => S (max n' m')
12 | 0, p | p, 0 => p
13 end.
+8
-0
test-suite/success/Case19.v less more
0 (* This used to fail in Coq version 8.1 beta due to a non variable
1 universe (issued by the inductive sort-polymorphism) being sent by
2 pretyping to the kernel (bug #1182) *)
3
4 Variable T : Type.
5 Variable x : nat*nat.
6
7 Check let (_, _) := x in sigT (fun _ : T => nat).
+74
-20
test-suite/success/Funind.v less more
2727 intros n m.
2828 functional induction ftest n m; auto.
2929 Qed.
30
31 Lemma test2 : forall m n, ~ 2 = ftest n m.
32 Proof.
33 intros n m;intro H.
34 functional inversion H ftest.
35 Qed.
36
37 Lemma test3 : forall n m, ftest n m = 0 -> (n = 0 /\ m = 0) \/ n <> 0.
38 Proof.
39 functional inversion 1 ftest;auto.
40 Qed.
41
3042
3143 Require Import Arith.
3244 Lemma test11 : forall m : nat, ftest 0 m <= 2.
111123 | S (S m) => iseven m
112124 | _ => false
113125 end.
114
126
127
115128 Function funex (n : nat) : nat :=
116129 match iseven n with
117130 | true => n
121134 end
122135 end.
123136
137
124138 Function nat_equal_bool (n m : nat) {struct n} : bool :=
125139 match n with
126140 | O => match m with
150164
151165 (* reuse this lemma as a scheme:*)
152166
153
154167 Function nested_lam (n : nat) : nat -> nat :=
155168 match n with
156169 | O => fun m : nat => 0
183196 auto with arith.
184197 Qed.
185198
186
187199 Function plus_x_not_five'' (n m : nat) {struct n} : nat :=
188200 let x := nat_equal_bool m 5 in
189201 let y := 0 in
205217 Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true.
206218 intros n m.
207219 functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto.
208 rewrite <- hyp in H1; simpl in H1;tauto.
220 rewrite <- hyp in y; simpl in y;tauto.
209221 inversion hyp.
210222 Qed.
211223
279291 destruct n. inversion istr.
280292 destruct n. inversion istr.
281293 destruct n. tauto.
282 simpl in *. inversion H1.
294 simpl in *. inversion H0.
283295 Qed.
284296
285297 Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n).
286298 intros n.
287299 functional induction isononeorfour n; intros m istr; inversion istr.
288300 apply istrue0.
289 rewrite H in H0; simpl in H0;tauto.
301 rewrite H in y; simpl in y;tauto.
290302 Qed.
291303
292304 Function ftest4 (n m : nat) : nat :=
352364 | S p => ftest2 p m
353365 end.
354366
355 Lemma test2 : forall n m : nat, ftest2 n m <= 2.
367 Lemma test2' : forall n m : nat, ftest2 n m <= 2.
356368 intros n m.
357369 functional induction ftest2 n m; simpl in |- *; intros; auto.
358370 Qed.
366378 end
367379 end.
368380
369 Lemma test3 : forall n m : nat, ftest3 n m <= 2.
381 Lemma test3' : forall n m : nat, ftest3 n m <= 2.
370382 intros n m.
371383 functional induction ftest3 n m.
372384 intros.
441453 functional induction ftest6 n m; simpl in |- *; auto.
442454 Qed.
443455
444
445
446
447
448
449
450
451
452
453
454
455
456 (* Some tests with modules *)
457 Module M.
458 Function test_m (n:nat) : nat :=
459 match n with
460 | 0 => 0
461 | S n => S (S (test_m n))
462 end.
463
464 Lemma test_m_is_double : forall n, div2 (test_m n) = n.
465 Proof.
466 intros n.
467 functional induction (test_m n).
468 reflexivity.
469 simpl;rewrite IHn0;reflexivity.
470 Qed.
471 End M.
472 (* We redefine a new Function with the same name *)
473 Function test_m (n:nat) : nat :=
474 pred n.
475
476 Lemma test_m_is_pred : forall n, test_m n = pred n.
477 Proof.
478 intro n.
479 functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*)
480 reflexivity.
481 Qed.
482
483 (* Checks if the dot notation are correctly treated in infos *)
484 Lemma M_test_m_is_double : forall n, div2 (M.test_m n) = n.
485 intro n.
486 (* here we should apply M.test_m_ind *)
487 functional induction (M.test_m n).
488 reflexivity.
489 simpl;rewrite IHn0;reflexivity.
490 Qed.
491
492 Import M.
493 (* Now test_m is the one which defines double *)
494
495 Lemma test_m_is_double : forall n, div2 (M.test_m n) = n.
496 intro n.
497 (* here we should apply M.test_m_ind *)
498 functional induction (test_m n).
499 reflexivity.
500 simpl;rewrite IHn0;reflexivity.
501 Qed.
502
503
504
505
506
507
508
509
+54
-54
theories/FSets/FMapAVL.v less more
88
99 (* Finite map library. *)
1010
11 (* $Id: FMapAVL.v 8899 2006-06-06 11:09:43Z jforest $ *)
11 (* $Id: FMapAVL.v 8985 2006-06-23 16:12:45Z jforest $ *)
1212
1313 (** This module implements map using AVL trees.
1414 It follows the implementation from Ocaml's standard library. *)
511511 (* LT *)
512512 inv avl.
513513 rewrite bal_in; auto.
514 rewrite (IHt H1); intuition_in.
514 rewrite (IHt H0); intuition_in.
515515 (* EQ *)
516516 inv avl.
517517 firstorder_in.
519519 (* GT *)
520520 inv avl.
521521 rewrite bal_in; auto.
522 rewrite (IHt H2); intuition_in.
522 rewrite (IHt H1); intuition_in.
523523 Qed.
524524
525525 Lemma add_bst : forall elt (m:t elt) x e, bst m -> avl m -> bst (add x e m).
529529 (* lt_tree -> lt_tree (add ...) *)
530530 red; red in H4.
531531 intros.
532 rewrite (add_in x y0 e H) in H1.
532 rewrite (add_in x y0 e H) in H0.
533533 intuition.
534534 eauto.
535535 (* gt_tree -> gt_tree (add ...) *)
536 red; red in H5.
536 red; red in H4.
537537 intros.
538 rewrite (add_in x y0 e H6) in H1.
538 rewrite (add_in x y0 e H5) in H0.
539539 intuition.
540540 apply lt_eq with x; auto.
541541 Qed.
590590 inversion_clear H.
591591 destruct (IHp lh); auto.
592592 split; simpl in *.
593 rewrite_all H0. simpl in *.
593 rewrite_all e1. simpl in *.
594594 apply bal_avl; subst;auto; omega_max.
595 rewrite_all H0;simpl in *;omega_bal.
595 rewrite_all e1;simpl in *;omega_bal.
596596 Qed.
597597
598598 Lemma remove_min_avl : forall elt (l:t elt) x e r h, avl (Node l x e r h) ->
609609 intuition_in.
610610 (* l = Node *)
611611 inversion_clear H.
612 generalize (remove_min_avl H1).
612 generalize (remove_min_avl H0).
613613
614 rewrite_all H0; simpl; intros.
614 rewrite_all e1; simpl; intros.
615615 rewrite bal_in; auto.
616 generalize (IHp lh y H1).
616 generalize (IHp lh y H0).
617617 intuition.
618 inversion_clear H8; intuition.
618 inversion_clear H7; intuition.
619619 Qed.
620620
621621 Lemma remove_min_mapsto : forall elt (l:t elt) x e r h y e', avl (Node l x e r h) ->
627627 intuition_in; subst; auto.
628628 (* l = Node *)
629629 inversion_clear H.
630 generalize (remove_min_avl H1).
631 rewrite_all H0; simpl; intros.
630 generalize (remove_min_avl H0).
631 rewrite_all e1; simpl; intros.
632632 rewrite bal_mapsto; auto; unfold create.
633633 simpl in *;destruct (IHp lh y e').
634634 auto.
635635 intuition.
636 inversion_clear H3; intuition.
637 inversion_clear H10; intuition.
636 inversion_clear H2; intuition.
637 inversion_clear H9; intuition.
638638 Qed.
639639
640640 Lemma remove_min_bst : forall elt (l:t elt) x e r h,
642642 Proof.
643643 intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
644644 inv bst; auto.
645 inversion_clear H; inversion_clear H1.
645 inversion_clear H; inversion_clear H0.
646646 apply bal_bst; auto.
647 rewrite_all H0;simpl in *;firstorder.
647 rewrite_all e1;simpl in *;firstorder.
648648 intro; intros.
649649 generalize (remove_min_in y H).
650 rewrite_all H0; simpl in *.
650 rewrite_all e1; simpl in *.
651651 destruct 1.
652 apply H4; intuition.
652 apply H3; intuition.
653653 Qed.
654654
655655 Lemma remove_min_gt_tree : forall elt (l:t elt) x e r h,
658658 Proof.
659659 intros elt l x e r; functional induction (remove_min l x e r); simpl in *; intros.
660660 inv bst; auto.
661 inversion_clear H; inversion_clear H1.
661 inversion_clear H; inversion_clear H0.
662662 intro; intro.
663 rewrite_all H0;simpl in *.
664 generalize (IHp lh H2 H); clear H7 H8 IHp.
663 rewrite_all e1;simpl in *.
664 generalize (IHp lh H1 H); clear H7 H6 IHp.
665665 generalize (remove_min_avl H).
666666 generalize (remove_min_in (fst m) H).
667 rewrite H0; simpl; intros.
668 rewrite (bal_in x e y H8 H6) in H1.
669 destruct H7.
667 rewrite e1; simpl; intros.
668 rewrite (bal_in x e y H7 H5) in H0.
669 destruct H6.
670670 firstorder.
671671 apply lt_eq with x; auto.
672672 apply X.lt_trans with x; auto.
695695 Proof.
696696 intros elt s1 s2; functional induction (merge s1 s2); simpl in *; intros.
697697 split; auto; avl_nns; omega_max.
698 destruct s1;try contradiction;clear H1.
698 destruct s1;try contradiction;clear y.
699699 split; auto; avl_nns; simpl in *; omega_max.
700 destruct s1;try contradiction;clear H1.
700 destruct s1;try contradiction;clear y.
701701 generalize (remove_min_avl_1 H0).
702 rewrite H2; simpl;destruct 1.
702 rewrite e3; simpl;destruct 1.
703703 split.
704704 apply bal_avl; auto.
705705 simpl; omega_max.
718718 intros elt s1 s2; functional induction (merge s1 s2);intros.
719719 intuition_in.
720720 intuition_in.
721 destruct s1;try contradiction;clear H1.
721 destruct s1;try contradiction;clear y.
722722 (* rewrite H_eq_2; rewrite H_eq_2 in H_eq_1; clear H_eq_2. *)
723 replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto].
723 replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto].
724724 rewrite bal_in; auto.
725 generalize (remove_min_avl H4); rewrite H2; simpl; auto.
726 generalize (remove_min_in y H4); rewrite H2; simpl; intro.
727 rewrite H1; intuition.
725 generalize (remove_min_avl H2); rewrite e3; simpl; auto.
726 generalize (remove_min_in y0 H2); rewrite e3; simpl; intro.
727 rewrite H3; intuition.
728728 Qed.
729729
730730 Lemma merge_mapsto : forall elt (s1 s2:t elt) y e, bst s1 -> avl s1 -> bst s2 -> avl s2 ->
733733 intros elt s1 s2; functional induction (@merge elt s1 s2); intros.
734734 intuition_in.
735735 intuition_in.
736 destruct s1;try contradiction;clear H1.
737 replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite H2; auto].
736 destruct s1;try contradiction;clear y.
737 replace s2' with (fst (remove_min l2 x2 e2 r2)); [|rewrite e3; auto].
738738 rewrite bal_mapsto; auto; unfold create.
739 generalize (remove_min_avl H4); rewrite H2; simpl; auto.
740 generalize (remove_min_mapsto y e0 H4); rewrite H2; simpl; intro.
741 rewrite H1; intuition (try subst; auto).
742 inversion_clear H1; intuition.
739 generalize (remove_min_avl H2); rewrite e3; simpl; auto.
740 generalize (remove_min_mapsto y0 e H2); rewrite e3; simpl; intro.
741 rewrite H3; intuition (try subst; auto).
742 inversion_clear H3; intuition.
743743 Qed.
744744
745745 Lemma merge_bst : forall elt (s1 s2:t elt), bst s1 -> avl s1 -> bst s2 -> avl s2 ->
750750
751751 apply bal_bst; auto.
752752 destruct s1;try contradiction.
753 generalize (remove_min_bst H3); rewrite H2; simpl in *; auto.
753 generalize (remove_min_bst H1); rewrite e3; simpl in *; auto.
754754 destruct s1;try contradiction.
755755 intro; intro.
756 apply H5; auto.
757 generalize (remove_min_in x H4); rewrite H2; simpl; intuition.
756 apply H3; auto.
757 generalize (remove_min_in x H2); rewrite e3; simpl; intuition.
758758 destruct s1;try contradiction.
759 generalize (remove_min_gt_tree H3); rewrite H2; simpl; auto.
759 generalize (remove_min_gt_tree H1); rewrite e3; simpl; auto.
760760 Qed.
761761
762762 (** * Deletion *)
778778 split; auto; omega_max.
779779 (* LT *)
780780 inv avl.
781 destruct (IHt H1).
781 destruct (IHt H0).
782782 split.
783783 apply bal_avl; auto.
784784 omega_max.
785785 omega_bal.
786786 (* EQ *)
787787 inv avl.
788 generalize (merge_avl_1 H1 H2 H3).
788 generalize (merge_avl_1 H0 H1 H2).
789789 intuition omega_max.
790790 (* GT *)
791791 inv avl.
792 destruct (IHt H2).
792 destruct (IHt H1).
793793 split.
794794 apply bal_avl; auto.
795795 omega_max.
808808 intros elt s x; functional induction (@remove elt x s); simpl; intros.
809809 intuition_in.
810810 (* LT *)
811 inv avl; inv bst; clear H0.
811 inv avl; inv bst; clear e1.
812812 rewrite bal_in; auto.
813 generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
813 generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
814814 (* EQ *)
815 inv avl; inv bst; clear H0.
815 inv avl; inv bst; clear e1.
816816 rewrite merge_in; intuition; [ order | order | intuition_in ].
817817 elim H9; eauto.
818818 (* GT *)
819 inv avl; inv bst; clear H0.
819 inv avl; inv bst; clear e1.
820820 rewrite bal_in; auto.
821 generalize (IHt y0 H6); intuition; [ order | order | intuition_in ].
821 generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
822822 Qed.
823823
824824 Lemma remove_bst : forall elt (s:t elt) x, bst s -> avl s -> bst (remove x s).
829829 inv avl; inv bst.
830830 apply bal_bst; auto.
831831 intro; intro.
832 rewrite (remove_in x y0 H1) in H; auto.
832 rewrite (remove_in x y0 H0) in H; auto.
833833 destruct H; eauto.
834834 (* EQ *)
835835 inv avl; inv bst.
838838 inv avl; inv bst.
839839 apply bal_bst; auto.
840840 intro; intro.
841 rewrite (remove_in x y0 H6) in H; auto.
841 rewrite (remove_in x y0 H5) in H; auto.
842842 destruct H; eauto.
843843 Qed.
844844
+23
-25
theories/FSets/FMapList.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (***********************************************************************)
77
8 (* $Id: FMapList.v 8899 2006-06-06 11:09:43Z jforest $ *)
8 (* $Id: FMapList.v 9035 2006-07-09 15:42:09Z herbelin $ *)
99
1010 (** * Finite map library *)
1111
1818
1919 Set Implicit Arguments.
2020 Unset Strict Implicit.
21
22 Arguments Scope list [type_scope].
2321
2422 Module Raw (X:OrderedType).
2523
160158 inversion 2.
161159
162160 inversion_clear 2.
163 clear H0;compute in H1; destruct H1;order.
164 clear H0;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H1)); compute; order.
165
166 clear H0;inversion_clear 2.
161 clear e1;compute in H0; destruct H0;order.
162 clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
163
164 clear e1;inversion_clear 2.
167165 compute in H0; destruct H0; intuition congruence.
168166 generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
169167
170 clear H0; do 2 inversion_clear 1; auto.
168 clear e1; do 2 inversion_clear 1; auto.
171169 compute in H2; destruct H2; order.
172170 Qed.
173171
196194 Proof.
197195 intros m x y e e'.
198196 generalize y e; clear y e; unfold PX.MapsTo.
199 functional induction (add x e' m) ;simpl;auto; clear H0.
197 functional induction (add x e' m) ;simpl;auto; clear e0.
200198 subst;auto.
201199
202200 intros y' e'' eqky'; inversion_clear 1; destruct H0; simpl in *.
213211 intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
214212 functional induction (add x e' m);simpl; intros.
215213 apply (In_inv_3 H0); compute; auto.
216 apply (In_inv_3 H1); compute; auto.
217 constructor 2; apply (In_inv_3 H1); compute; auto.
218 inversion_clear H1; auto.
214 apply (In_inv_3 H0); compute; auto.
215 constructor 2; apply (In_inv_3 H0); compute; auto.
216 inversion_clear H0; auto.
219217 Qed.
220218
221219
264262 red; inversion 1; inversion H1.
265263
266264 apply Sort_Inf_NotIn with x0; auto.
267 clear H0;constructor; compute; order.
265 clear e0;constructor; compute; order.
268266
269 clear H0;inversion_clear Hm.
267 clear e0;inversion_clear Hm.
270268 apply Sort_Inf_NotIn with x0; auto.
271269 apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.
272270
273 clear H0;inversion_clear Hm.
271 clear e0;inversion_clear Hm.
274272 assert (notin:~ In y (remove x l)) by auto.
275273 intros (x1,abs).
276274 inversion_clear abs.
392390
393391
394392 assert (cmp_e_e':cmp e e' = true).
395 apply H2 with x; auto.
393 apply H1 with x; auto.
396394 rewrite cmp_e_e'; simpl.
397395 apply IHb; auto.
398396 inversion_clear Hm; auto.
401399 destruct (H0 k).
402400 assert (In k ((x,e) ::l)).
403401 destruct H as (e'', hyp); exists e''; auto.
404 destruct (In_inv (H1 H4)); auto.
402 destruct (In_inv (H2 H4)); auto.
405403 inversion_clear Hm.
406404 elim (Sort_Inf_NotIn H6 H7).
407405 destruct H as (e'', hyp); exists e''; auto.
414412 elim (Sort_Inf_NotIn H6 H7).
415413 destruct H as (e'', hyp); exists e''; auto.
416414 apply MapsTo_eq with k; auto; order.
417 apply H2 with k; destruct (eq_dec x k); auto.
418
419
420 destruct (X.compare x x'); try contradiction;clear H2.
415 apply H1 with k; destruct (eq_dec x k); auto.
416
417
418 destruct (X.compare x x'); try contradiction; clear y.
421419 destruct (H0 x).
422420 assert (In x ((x',e')::l')).
423421 apply H; auto.
491489
492490 inversion_clear Hm;inversion_clear Hm'.
493491 destruct (andb_prop _ _ H); clear H.
494 destruct (IHb H1 H4 H7).
492 destruct (IHb H2 H4 H7).
495493 inversion_clear H0.
496494 destruct H9; simpl in *; subst.
497 inversion_clear H2.
495 inversion_clear H1.
498496 destruct H9; simpl in *; subst; auto.
499497 elim (Sort_Inf_NotIn H4 H5).
500498 exists e'0; apply MapsTo_eq with k; auto; order.
501 inversion_clear H2.
499 inversion_clear H1.
502500 destruct H0; simpl in *; subst; auto.
503 elim (Sort_Inf_NotIn H1 H3).
501 elim (Sort_Inf_NotIn H2 H3).
504502 exists e0; apply MapsTo_eq with k; auto; order.
505503 apply H8 with k; auto.
506504 Qed.
+14
-14
theories/FSets/FMapWeakList.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (***********************************************************************)
77
8 (* $Id: FMapWeakList.v 8899 2006-06-06 11:09:43Z jforest $ *)
8 (* $Id: FMapWeakList.v 8985 2006-06-23 16:12:45Z jforest $ *)
99
1010 (** * Finite map library *)
1111
103103 inversion belong1. inversion H.
104104 inversion_clear NoDup.
105105 inversion_clear belong1.
106 inversion_clear H2.
107 compute in H3; destruct H3.
106 inversion_clear H1.
107 compute in H2; destruct H2.
108108 contradiction.
109109 apply IHb; auto.
110110 exists x0; auto.
143143 inversion 2.
144144
145145 do 2 inversion_clear 1.
146 compute in H3; destruct H3; subst; trivial.
146 compute in H2; destruct H2; subst; trivial.
147147 elim H; apply InA_eqk with (x,e); auto.
148148
149149 do 2 inversion_clear 1; auto.
150 compute in H3; destruct H3; elim _x; auto.
150 compute in H2; destruct H2; elim _x; auto.
151151 Qed.
152152
153153 (* Not part of the exported specifications, used later for [combine]. *)
183183 intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo.
184184 functional induction (add x e' m);simpl;auto.
185185 intros y' e'' eqky'; inversion_clear 1.
186 destruct H1; simpl in *.
186 destruct H0; simpl in *.
187187 elim eqky'; apply X.eq_trans with k'; auto.
188188 auto.
189189 intros y' e'' eqky'; inversion_clear 1; intuition.
195195 intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
196196 functional induction (add x e' m);simpl;auto.
197197 intros; apply (In_inv_3 H0); auto.
198 constructor 2; apply (In_inv_3 H1); auto.
198 constructor 2; apply (In_inv_3 H0); auto.
199199 inversion_clear 2; auto.
200200 Qed.
201201
207207 inversion_clear 2.
208208 compute in H1; elim H; auto.
209209 inversion H1.
210 constructor 2; inversion_clear H1; auto.
211 compute in H2; elim H; auto.
210 constructor 2; inversion_clear H0; auto.
211 compute in H1; elim H; auto.
212212 inversion_clear 2; auto.
213213 Qed.
214214
271271
272272 inversion_clear Hm.
273273 subst.
274 swap H1.
275 destruct H3 as (e,H3); unfold PX.MapsTo in H3.
274 swap H0.
275 destruct H2 as (e,H2); unfold PX.MapsTo in H2.
276276 apply InA_eqk with (y,e); auto.
277277 compute; apply X.eq_trans with x; auto.
278278
279279 intro H2.
280280 destruct H2 as (e,H2); inversion_clear H2.
281 compute in H1; destruct H1.
281 compute in H0; destruct H0.
282282 elim _x; apply X.eq_trans with y; auto.
283283 inversion_clear Hm.
284 elim (IHt0 H3 H).
284 elim (IHt0 H2 H).
285285 exists e; auto.
286286 Qed.
287287
291291 intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
292292 functional induction (remove x m);auto.
293293 inversion_clear 3; auto.
294 compute in H2; destruct H2.
294 compute in H1; destruct H1.
295295 elim H; apply X.eq_trans with k'; auto.
296296
297297 inversion_clear 1; inversion_clear 2; auto.
+78
-78
theories/FSets/FSetAVL.v less more
1111 * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
1212 * 91405 Orsay, France *)
1313
14 (* $Id: FSetAVL.v 8899 2006-06-06 11:09:43Z jforest $ *)
14 (* $Id: FSetAVL.v 8985 2006-06-23 16:12:45Z jforest $ *)
1515
1616 (** This module implements sets using AVL trees.
1717 It follows the implementation from Ocaml's standard library. *)
514514 (* LT *)
515515 inv avl.
516516 rewrite bal_in; auto.
517 rewrite (IHt y0 H1); intuition_in.
517 rewrite (IHt y0 H0); intuition_in.
518518 (* EQ *)
519519 inv avl.
520520 intuition.
522522 (* GT *)
523523 inv avl.
524524 rewrite bal_in; auto.
525 rewrite (IHt y0 H2); intuition_in.
525 rewrite (IHt y0 H1); intuition_in.
526526 Qed.
527527
528528 Lemma add_bst : forall s x, bst s -> avl s -> bst (add x s).
530530 intros s x; functional induction (add x s); auto; intros.
531531 inv bst; inv avl; apply bal_bst; auto.
532532 (* lt_tree -> lt_tree (add ...) *)
533 red; red in H5.
533 red; red in H4.
534534 intros.
535 rewrite (add_in l x y0 H) in H1.
535 rewrite (add_in l x y0 H) in H0.
536536 intuition.
537537 eauto.
538538 inv bst; inv avl; apply bal_bst; auto.
539539 (* gt_tree -> gt_tree (add ...) *)
540 red; red in H5.
540 red; red in H4.
541541 intros.
542 rewrite (add_in r x y0 H6) in H1.
542 rewrite (add_in r x y0 H5) in H0.
543543 intuition.
544544 apply MX.lt_eq with x; auto.
545545 Qed.
702702 avl_nns; omega_max.
703703 (* l = Node *)
704704 inversion_clear H.
705 rewrite H0 in IHp;simpl in IHp;destruct (IHp lh); auto.
705 rewrite e0 in IHp;simpl in IHp;destruct (IHp lh); auto.
706706 split; simpl in *.
707707 apply bal_avl; auto; omega_max.
708708 omega_bal.
722722 intuition_in.
723723 (* l = Node *)
724724 inversion_clear H.
725 generalize (remove_min_avl ll lx lr lh H1).
726 rewrite H0; simpl; intros.
725 generalize (remove_min_avl ll lx lr lh H0).
726 rewrite e0; simpl; intros.
727727 rewrite bal_in; auto.
728 rewrite H0 in IHp;generalize (IHp lh y H1).
728 rewrite e0 in IHp;generalize (IHp lh y H0).
729729 intuition.
730 inversion_clear H8; intuition.
730 inversion_clear H7; intuition.
731731 Qed.
732732
733733 Lemma remove_min_bst : forall l x r h,
735735 Proof.
736736 intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
737737 inv bst; auto.
738 inversion_clear H; inversion_clear H1.
739 rewrite_all H0;simpl in *.
738 inversion_clear H; inversion_clear H0.
739 rewrite_all e0;simpl in *.
740740 apply bal_bst; auto.
741741 firstorder.
742742 intro; intros.
743743 generalize (remove_min_in ll lx lr lh y H).
744 rewrite H0; simpl.
744 rewrite e0; simpl.
745745 destruct 1.
746 apply H4; intuition.
746 apply H3; intuition.
747747 Qed.
748748
749749 Lemma remove_min_gt_tree : forall l x r h,
752752 Proof.
753753 intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros.
754754 inv bst; auto.
755 inversion_clear H; inversion_clear H1.
755 inversion_clear H; inversion_clear H0.
756756 intro; intro.
757 generalize (IHp lh H2 H); clear H8 H7 IHp.
757 generalize (IHp lh H1 H); clear H6 H7 IHp.
758758 generalize (remove_min_avl ll lx lr lh H).
759759 generalize (remove_min_in ll lx lr lh m H).
760 rewrite H0; simpl; intros.
761 rewrite (bal_in l' x r y H8 H6) in H1.
762 destruct H7.
760 rewrite e0; simpl; intros.
761 rewrite (bal_in l' x r y H7 H5) in H0.
762 destruct H6.
763763 firstorder.
764764 apply MX.lt_eq with x; auto.
765765 apply X.lt_trans with x; auto.
787787 intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros.
788788 split; auto; avl_nns; omega_max.
789789 split; auto; avl_nns; simpl in *; omega_max.
790 destruct s1;try contradiction;clear H1.
790 destruct s1;try contradiction;clear y.
791791 generalize (remove_min_avl_1 l2 x2 r2 h2 H0).
792 rewrite H2; simpl; destruct 1.
792 rewrite e1; simpl; destruct 1.
793793 split.
794794 apply bal_avl; auto.
795795 simpl; omega_max.
808808 intros s1 s2; functional induction (merge s1 s2); subst; simpl in *; intros.
809809 intuition_in.
810810 intuition_in.
811 destruct s1;try contradiction;clear H1.
812 replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite H2; auto].
811 destruct s1;try contradiction;clear y.
812 replace s2' with (fst (remove_min l2 x2 r2)); [|rewrite e1; auto].
813813 rewrite bal_in; auto.
814 generalize (remove_min_avl l2 x2 r2 h2); rewrite H2; simpl; auto.
815 generalize (remove_min_in l2 x2 r2 h2 y); rewrite H2; simpl; intro.
816 rewrite H1; intuition.
814 generalize (remove_min_avl l2 x2 r2 h2); rewrite e1; simpl; auto.
815 generalize (remove_min_in l2 x2 r2 h2 y0); rewrite e1; simpl; intro.
816 rewrite H3 ; intuition.
817817 Qed.
818818
819819 Lemma merge_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 ->
821821 bst (merge s1 s2).
822822 Proof.
823823 intros s1 s2; functional induction (merge s1 s2); subst;simpl in *; intros; auto.
824 destruct s1;try contradiction;clear H1.
824 destruct s1;try contradiction;clear y.
825825 apply bal_bst; auto.
826 generalize (remove_min_bst l2 x2 r2 h2); rewrite H2; simpl in *; auto.
826 generalize (remove_min_bst l2 x2 r2 h2); rewrite e1; simpl in *; auto.
827827 intro; intro.
828 apply H5; auto.
829 generalize (remove_min_in l2 x2 r2 h2 m); rewrite H2; simpl; intuition.
830 generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite H2; simpl; auto.
828 apply H3; auto.
829 generalize (remove_min_in l2 x2 r2 h2 m); rewrite e1; simpl; intuition.
830 generalize (remove_min_gt_tree l2 x2 r2 h2); rewrite e1; simpl; auto.
831831 Qed.
832832
833833 (** * Deletion *)
849849 intuition; omega_max.
850850 (* LT *)
851851 inv avl.
852 destruct (IHt H1).
852 destruct (IHt H0).
853853 split.
854854 apply bal_avl; auto.
855855 omega_max.
856856 omega_bal.
857857 (* EQ *)
858858 inv avl.
859 generalize (merge_avl_1 l r H1 H2 H3).
859 generalize (merge_avl_1 l r H0 H1 H2).
860860 intuition omega_max.
861861 (* GT *)
862862 inv avl.
863 destruct (IHt H2).
863 destruct (IHt H1).
864864 split.
865865 apply bal_avl; auto.
866866 omega_max.
879879 intros s x; functional induction (remove x s); subst;simpl; intros.
880880 intuition_in.
881881 (* LT *)
882 inv avl; inv bst; clear H0.
882 inv avl; inv bst; clear e0.
883883 rewrite bal_in; auto.
884 generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
884 generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
885885 (* EQ *)
886 inv avl; inv bst; clear H0.
886 inv avl; inv bst; clear e0.
887887 rewrite merge_in; intuition; [ order | order | intuition_in ].
888888 elim H9; eauto.
889889 (* GT *)
890 inv avl; inv bst; clear H0.
890 inv avl; inv bst; clear e0.
891891 rewrite bal_in; auto.
892 generalize (IHt y0 H6); intuition; [ order | order | intuition_in ].
892 generalize (IHt y0 H5); intuition; [ order | order | intuition_in ].
893893 Qed.
894894
895895 Lemma remove_bst : forall s x, bst s -> avl s -> bst (remove x s).
944944 simpl.
945945 destruct l1.
946946 inversion 1; subst.
947 assert (X.lt x _x) by (apply H3; auto).
947 assert (X.lt x _x) by (apply H2; auto).
948948 inversion_clear 1; auto; order.
949949 assert (X.lt t _x) by auto.
950950 inversion_clear 2; auto;
957957 red; auto.
958958 inversion 1.
959959 destruct l;try contradiction.
960 clear H0;intro H0.
960 clear y;intro H0.
961961 destruct (IHo H0 t); auto.
962962 Qed.
963963
10031003 red; auto.
10041004 inversion 1.
10051005 destruct r;try contradiction.
1006 clear H0;intros H0; destruct (IHo H0 t); auto.
1006 intros H0; destruct (IHo H0 t); auto.
10071007 Qed.
10081008
10091009 (** * Any element *)
10371037 Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2).
10381038 Proof.
10391039 intros s1 s2; functional induction (concat s1 s2); subst;auto.
1040 destruct s1;try contradiction;clear H1.
1040 destruct s1;try contradiction;clear y.
10411041 intros; apply join_avl; auto.
1042 generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite H2; simpl; auto.
1042 generalize (remove_min_avl l2 x2 r2 h2 H0); rewrite e1; simpl; auto.
10431043 Qed.
10441044
10451045 Lemma concat_bst : forall s1 s2, bst s1 -> avl s1 -> bst s2 -> avl s2 ->
10471047 bst (concat s1 s2).
10481048 Proof.
10491049 intros s1 s2; functional induction (concat s1 s2); subst ;auto.
1050 destruct s1;try contradiction;clear H1.
1050 destruct s1;try contradiction;clear y.
10511051 intros; apply join_bst; auto.
1052 generalize (remove_min_bst l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto.
1053 generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto.
1054 generalize (remove_min_in l2 x2 r2 h2 m H3); rewrite H2; simpl; auto.
1052 generalize (remove_min_bst l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto.
1053 generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
1054 generalize (remove_min_in l2 x2 r2 h2 m H2); rewrite e1; simpl; auto.
10551055 destruct 1; intuition.
1056 generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H3); rewrite H2; simpl; auto.
1056 generalize (remove_min_gt_tree l2 x2 r2 h2 H1 H2); rewrite e1; simpl; auto.
10571057 Qed.
10581058
10591059 Lemma concat_in : forall s1 s2 y, bst s1 -> avl s1 -> bst s2 -> avl s2 ->
10631063 intros s1 s2; functional induction (concat s1 s2);subst;simpl.
10641064 intuition.
10651065 inversion_clear H5.
1066 destruct s1;try contradiction;clear H1;intuition.
1066 destruct s1;try contradiction;clear y;intuition.
10671067 inversion_clear H5.
1068 destruct s1;try contradiction;clear H1; intros.
1068 destruct s1;try contradiction;clear y; intros.
10691069 rewrite (join_in (Node s1_1 t s1_2 i) m s2' y H0).
1070 generalize (remove_min_avl l2 x2 r2 h2 H3); rewrite H2; simpl; auto.
1071 generalize (remove_min_in l2 x2 r2 h2 y H3); rewrite H2; simpl.
1070 generalize (remove_min_avl l2 x2 r2 h2 H2); rewrite e1; simpl; auto.
1071 generalize (remove_min_in l2 x2 r2 h2 y H2); rewrite e1; simpl.
10721072 intro EQ; rewrite EQ; intuition.
10731073 Qed.
10741074
10991099 Proof.
11001100 intros s x; functional induction (split x s);subst;simpl in *.
11011101 auto.
1102 rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition.
1102 rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition.
11031103 simpl; inversion_clear 1; auto.
1104 rewrite H1 in IHp;simpl in IHp;inversion_clear 1; intuition.
1104 rewrite e1 in IHp;simpl in IHp;inversion_clear 1; intuition.
11051105 Qed.
11061106
11071107 Lemma split_in_1 : forall s x y, bst s -> avl s ->
11101110 intros s x; functional induction (split x s);subst;simpl in *.
11111111 intuition; try inversion_clear H1.
11121112 (* LT *)
1113 rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H9.
1114 rewrite (IHp y0 H2 H6); clear IHp H0.
1113 rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
1114 rewrite (IHp y0 H0 H4); clear IHp e0.
11151115 intuition.
1116 inversion_clear H0; auto; order.
1116 inversion_clear H6; auto; order.
11171117 (* EQ *)
1118 simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0.
1118 simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
11191119 intuition.
11201120 order.
11211121 intuition_in; order.
11221122 (* GT *)
1123 rewrite H1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
1123 rewrite e1 in IHp;simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
11241124 rewrite join_in; auto.
1125 generalize (split_avl r x H7); rewrite H1; simpl; intuition.
1126 rewrite (IHp y0 H3 H7); clear H1.
1125 generalize (split_avl r x H5); rewrite e1; simpl; intuition.
1126 rewrite (IHp y0 H1 H5); clear e1.
11271127 intuition; [ eauto | eauto | intuition_in ].
11281128 Qed.
11291129
11331133 intros s x; functional induction (split x s);subst;simpl in *.
11341134 intuition; try inversion_clear H1.
11351135 (* LT *)
1136 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
1136 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
11371137 rewrite join_in; auto.
1138 generalize (split_avl l x H6); rewrite H1; simpl; intuition.
1139 rewrite (IHp y0 H2 H6); clear IHp H0.
1138 generalize (split_avl l x H4); rewrite e1; simpl; intuition.
1139 rewrite (IHp y0 H0 H4); clear IHp e0.
11401140 intuition; [ order | order | intuition_in ].
11411141 (* EQ *)
1142 simpl in *; inversion_clear 1; inversion_clear 1; clear H8 H7 H0.
1142 simpl in *; inversion_clear 1; inversion_clear 1; clear H6 H5 e0.
11431143 intuition; [ order | intuition_in; order ].
11441144 (* GT *)
1145 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
1146 rewrite (IHp y0 H3 H7); clear IHp H0.
1145 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
1146 rewrite (IHp y0 H1 H5); clear IHp e0.
11471147 intuition; intuition_in; order.
11481148 Qed.
11491149
11531153 intros s x; functional induction (split x s);subst;simpl in *.
11541154 intuition; try inversion_clear H1.
11551155 (* LT *)
1156 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
1156 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
11571157 rewrite IHp; auto.
11581158 intuition_in; absurd (X.lt x y); eauto.
11591159 (* EQ *)
11601160 simpl in *; inversion_clear 1; inversion_clear 1; intuition.
11611161 (* GT *)
1162 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H9 H8.
1162 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1; clear H7 H6.
11631163 rewrite IHp; auto.
11641164 intuition_in; absurd (X.lt y x); eauto.
11651165 Qed.
11701170 intros s x; functional induction (split x s);subst;simpl in *.
11711171 intuition.
11721172 (* LT *)
1173 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
1173 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
11741174 intuition.
11751175 apply join_bst; auto.
1176 generalize (split_avl l x H6); rewrite H1; simpl; intuition.
1176 generalize (split_avl l x H4); rewrite e1; simpl; intuition.
11771177 intro; intro.
1178 generalize (split_in_2 l x y0 H2 H6); rewrite H1; simpl; intuition.
1178 generalize (split_in_2 l x y0 H0 H4); rewrite e1; simpl; intuition.
11791179 (* EQ *)
11801180 simpl in *; inversion_clear 1; inversion_clear 1; intuition.
11811181 (* GT *)
1182 rewrite H1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
1182 rewrite e1 in IHp; simpl in *; inversion_clear 1; inversion_clear 1.
11831183 intuition.
11841184 apply join_bst; auto.
1185 generalize (split_avl r x H7); rewrite H1; simpl; intuition.
1185 generalize (split_avl r x H5); rewrite e1; simpl; intuition.
11861186 intro; intro.
1187 generalize (split_in_1 r x y0 H3 H7); rewrite H1; simpl; intuition.
1187 generalize (split_in_1 r x y0 H1 H5); rewrite e1; simpl; intuition.
11881188 Qed.
11891189
11901190 (** * Intersection *)
+4
-1
theories/Init/Wf.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: Wf.v 8642 2006-03-17 10:09:02Z notin $ i*)
8 (*i $Id: Wf.v 8988 2006-06-25 22:15:32Z letouzey $ i*)
99
1010 (** This module proves the validity of
1111 - well-founded recursion (also called course of values)
145145 Variable R : A * B -> A * B -> Prop.
146146
147147 Variable P : A -> B -> Type.
148
149 Section Acc_iter_2.
148150 Variable
149151 F :
150152 forall (x:A) (x':B),
155157 F
156158 (fun (y:A) (y':B) (h:R (y, y') (x, x')) =>
157159 Acc_iter_2 (x:=y) (x':=y') (Acc_inv a (y, y') h)).
160 End Acc_iter_2.
158161
159162 Hypothesis Rwf : well_founded R.
160163
+5
-11
theories/Lists/List.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: List.v 8866 2006-05-28 16:21:04Z herbelin $ i*)
8 (*i $Id: List.v 9035 2006-07-09 15:42:09Z herbelin $ i*)
99
1010 Require Import Le Gt Minus Min Bool.
1111 Require Import Setoid.
8484
8585 Bind Scope list_scope with list.
8686
87 Arguments Scope list [type_scope].
8788
8889 (** ** Facts about lists *)
8990
134135 Proof.
135136 simpl in |- *; auto.
136137 Qed.
137 Hint Resolve in_eq.
138138
139139 Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
140140 Proof.
141141 simpl in |- *; auto.
142142 Qed.
143 Hint Resolve in_cons.
144143
145144 Theorem in_nil : forall a:A, ~ In a nil.
146145 Proof.
196195 induction l; simpl in |- *; auto.
197196 rewrite <- IHl; auto.
198197 Qed.
199 Hint Resolve app_nil_end.
200
201198
202199 (** [app] is associative *)
203200 Theorem app_ass : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
210207
211208 Theorem ass_app : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
212209 Proof.
213 auto.
214 Qed.
215 Hint Resolve ass_app.
210 auto using app_ass.
211 Qed.
216212
217213 (** [app] commutes with [cons] *)
218214 Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
295291 now_show ((a0 = a \/ In a y) \/ In a m).
296292 elim (H H1); auto.
297293 Qed.
298 Hint Immediate in_app_or.
299294
300295 Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m).
301296 Proof.
312307 now_show (H = a \/ In a (y ++ m)).
313308 elim H2; auto.
314309 Qed.
315 Hint Resolve in_or_app.
316310
317311
318312 End Facts.
889883 break_list l1 b l1' H0; break_list l3 c l3' H1.
890884 auto.
891885 apply perm_trans with (l3'++c::l4); auto.
892 apply perm_trans with (l1'++a::l2); auto.
886 apply perm_trans with (l1'++a::l2); auto using Permutation_cons_app.
893887 apply perm_skip.
894888 apply (IH a l1' l2 l3' l4); auto.
895889 (* swap *)
+5
-5
theories/Logic/ChoiceFacts.v less more
66 (* * GNU Lesser General Public License Version 2.1 *)
77 (************************************************************************)
88
9 (*i $Id: ChoiceFacts.v 8892 2006-06-04 17:59:53Z herbelin $ i*)
9 (*i $Id: ChoiceFacts.v 8999 2006-07-04 12:46:04Z notin $ i*)
1010
1111 (** ** Some facts and definitions concerning choice and description in
1212 intuitionistic logic.
7777 [Bell93] John L. Bell, Hilbert's Epsilon Operator in Intuitionistic
7878 Type Theories, Mathematical Logic Quarterly, volume 39, 1993.
7979
80 [Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in
80 [Carlstrøm05] Jesper Carlstrøm, Interpreting descriptions in
8181 intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
8282 *)
8383
124124
125125 (** ID_epsilon (constructive version of indefinite description;
126126 combined with proof-irrelevance, it may be connected to
127 Carlstrøm's type theory with a constructive indefinite description
127 Carlstrøm's type theory with a constructive indefinite description
128128 operator) *)
129129
130130 Definition ConstructiveIndefiniteDescription_on :=
132132 (exists x, P x) -> { x:A | P x }.
133133
134134 (** ID_iota (constructive version of definite description; combined
135 with proof-irrelevance, it may be connected to Carlstrøm's and
135 with proof-irrelevance, it may be connected to Carlstrøm's and
136136 Stenlund's type theory with a constructive definite description
137137 operator) *)
138138
693693 We adapt the proof to show that constructive definite description
694694 transports excluded-middle from [Prop] to [Set].
695695
696 [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
696 [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
697697 Simpson, Mathematical Quotients and Quotient Types in Coq,
698698 Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
699699 Springer Verlag. *)
+3
-3
theories/Logic/ClassicalUniqueChoice.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: ClassicalUniqueChoice.v 8893 2006-06-04 18:04:53Z herbelin $ i*)
8 (*i $Id: ClassicalUniqueChoice.v 9026 2006-07-06 15:16:20Z herbelin $ i*)
99
1010 (** This file provides classical logic and unique choice *)
1111
1414 excluded-middle in [Set], hence it implies a strongly classical
1515 world. Especially it conflicts with the impredicativity of [Set].
1616
17 [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
17 [ChicliPottierSimpson02] Laurent Chicli, Loïc Pottier, Carlos
1818 Simpson, Mathematical Quotients and Quotient Types in Coq,
1919 Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
2020 Springer Verlag. *)
3838 apply (dependent_unique_choice A (fun _ => B)).
3939 Qed.
4040
41 (** The followig proof comes from [ChicliPottierSimpson02] *)
41 (** The following proof comes from [ChicliPottierSimpson02] *)
4242
4343 Require Import Setoid.
4444
+58
-4
theories/QArith/QArith_base.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: QArith_base.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
8 (*i $Id: QArith_base.v 8989 2006-06-25 22:17:49Z letouzey $ i*)
99
1010 Require Export ZArith.
1111 Require Export ZArithRing.
4242
4343 Infix "==" := Qeq (at level 70, no associativity) : Q_scope.
4444 Infix "<" := Qlt : Q_scope.
45 Infix ">" := Qgt : Q_scope.
4546 Infix "<=" := Qle : Q_scope.
46 Infix ">" := Qgt : Q_scope.
47 Infix ">=" := Qge : Q_scope.
47 Infix ">=" := Qge : Q_scope.
4848 Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.
4949
50 Hint Unfold Qeq Qle Qlt: qarith.
50 (** Another approach : using Qcompare for defining order relations. *)
51
52 Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
53 Notation "p ?= q" := (Qcompare p q) : Q_scope.
54
55 Lemma Qeq_alt : forall p q, (p == q) <-> (p ?= q) = Eq.
56 Proof.
57 unfold Qeq, Qcompare; intros; split; intros.
58 rewrite H; apply Zcompare_refl.
59 apply Zcompare_Eq_eq; auto.
60 Qed.
61
62 Lemma Qlt_alt : forall p q, (p<q) <-> (p?=q = Lt).
63 Proof.
64 unfold Qlt, Qcompare, Zlt; split; auto.
65 Qed.
66
67 Lemma Qgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
68 Proof.
69 unfold Qlt, Qcompare, Zlt.
70 intros; rewrite Zcompare_Gt_Lt_antisym; split; auto.
71 Qed.
72
73 Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
74 Proof.
75 unfold Qle, Qcompare, Zle; split; auto.
76 Qed.
77
78 Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
79 Proof.
80 unfold Qle, Qcompare, Zle.
81 split; intros; swap H.
82 rewrite Zcompare_Gt_Lt_antisym; auto.
83 rewrite Zcompare_Gt_Lt_antisym in H0; auto.
84 Qed.
85
86 Hint Unfold Qeq Qlt Qle: qarith.
5187 Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.
5288
5389 (** Properties of equality. *)
235271 Open Scope Q_scope.
236272 Qed.
237273
274
275 Lemma Qcompare_egal_dec: forall n m p q : Q,
276 (n<m -> p<q) -> (n==m -> p==q) -> (n>m -> p>q) -> ((n?=m) = (p?=q)).
277 Proof.
278 intros.
279 do 2 rewrite Qeq_alt in H0.
280 unfold Qeq, Qlt, Qcompare in *.
281 apply Zcompare_egal_dec; auto.
282 omega.
283 Qed.
284
285
286 Add Morphism Qcompare : Qcompare_comp.
287 Proof.
288 intros; apply Qcompare_egal_dec; rewrite H; rewrite H0; auto.
289 Qed.
290
291
238292 (** [0] and [1] are apart *)
239293
240294 Lemma Q_apart_0_1 : ~ 1 == 0.
+526
-0
theories/QArith/Qcanon.v less more
0 (************************************************************************)
1 (* v * The Coq Proof Assistant / The Coq Development Team *)
2 (* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
3 (* \VV/ **************************************************************)
4 (* // * This file is distributed under the terms of the *)
5 (* * GNU Lesser General Public License Version 2.1 *)
6 (************************************************************************)
7
8 (*i $Id: Qcanon.v 8989 2006-06-25 22:17:49Z letouzey $ i*)
9
10 Require Import QArith.
11 Require Import Eqdep_dec.
12
13 (** [Qc] : A canonical representation of rational numbers.
14 based on the setoid representation [Q]. *)
15
16 Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }.
17
18 Delimit Scope Qc_scope with Qc.
19 Bind Scope Qc_scope with Qc.
20 Arguments Scope Qcmake [Q_scope].
21 Open Scope Qc_scope.
22
23 Lemma Qred_identity :
24 forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
25 Proof.
26 unfold Qred; intros (a,b); simpl.
27 generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)).
28 intros.
29 rewrite H1 in H; clear H1.
30 destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
31 destruct H0.
32 rewrite Zmult_1_l in H, H0.
33 subst; simpl; auto.
34 Qed.
35
36 Lemma Qred_identity2 :
37 forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z.
38 Proof.
39 unfold Qred; intros (a,b); simpl.
40 generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)) (Zgcd_is_pos a ('b)).
41 intros.
42 rewrite <- H; rewrite <- H in H1; clear H.
43 destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
44 injection H2; intros; clear H2.
45 destruct H0.
46 clear H0 H3.
47 destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate.
48 f_equal.
49 apply Pmult_reg_r with bb.
50 injection H2; intros.
51 rewrite <- H0.
52 rewrite H; simpl; auto.
53 elim H1; auto.
54 Qed.
55
56 Lemma Qred_iff : forall q:Q, Qred q = q <-> Zgcd (Qnum q) (QDen q) = 1%Z.
57 Proof.
58 split; intros.
59 apply Qred_identity2; auto.
60 apply Qred_identity; auto.
61 Qed.
62
63
64 Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q.
65 Proof.
66 intros; apply Qred_complete.
67 apply Qred_correct.
68 Qed.
69
70 Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q).
71 Arguments Scope Q2Qc [Q_scope].
72 Notation " !! " := Q2Qc : Qc_scope.
73
74 Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
75 Proof.
76 intros (q,proof_q) (q',proof_q').
77 simpl.
78 intros H.
79 assert (H0:=Qred_complete _ _ H).
80 assert (q = q') by congruence.
81 subst q'.
82 assert (proof_q = proof_q').
83 apply eq_proofs_unicity; auto; intros.
84 repeat decide equality.
85 congruence.
86 Qed.
87 Hint Resolve Qc_is_canon.
88
89 Notation " 0 " := (!!0) : Qc_scope.
90 Notation " 1 " := (!!1) : Qc_scope.
91
92 Definition Qcle (x y : Qc) := (x <= y)%Q.
93 Definition Qclt (x y : Qc) := (x < y)%Q.
94 Notation Qcgt := (fun x y : Qc => Qlt y x).
95 Notation Qcge := (fun x y : Qc => Qle y x).
96 Infix "<" := Qclt : Qc_scope.
97 Infix "<=" := Qcle : Qc_scope.
98 Infix ">" := Qcgt : Qc_scope.
99 Infix ">=" := Qcge : Qc_scope.
100 Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope.
101
102 Definition Qccompare (p q : Qc) := (Qcompare p q).
103 Notation "p ?= q" := (Qccompare p q) : Qc_scope.
104
105 Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq.
106 Proof.
107 unfold Qccompare.
108 intros; rewrite <- Qeq_alt.
109 split; auto.
110 intro H; rewrite H; auto with qarith.
111 Qed.
112
113 Lemma Qclt_alt : forall p q, (p<q) <-> (p?=q = Lt).
114 Proof.
115 intros; exact (Qlt_alt p q).
116 Qed.
117
118 Lemma Qcgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
119 Proof.
120 intros; exact (Qgt_alt p q).
121 Qed.
122
123 Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
124 Proof.
125 intros; exact (Qle_alt p q).
126 Qed.
127
128 Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
129 Proof.
130 intros; exact (Qge_alt p q).
131 Qed.
132
133 (** equality on [Qc] is decidable: *)
134
135 Theorem Qc_eq_dec : forall x y:Qc, {x=y} + {x<>y}.
136 Proof.
137 intros.
138 destruct (Qeq_dec x y) as [H|H]; auto.
139 right; swap H; subst; auto with qarith.
140 Defined.
141
142 (** The addition, multiplication and opposite are defined
143 in the straightforward way: *)
144
145 Definition Qcplus (x y : Qc) := !!(x+y).
146 Infix "+" := Qcplus : Qc_scope.
147 Definition Qcmult (x y : Qc) := !!(x*y).
148 Infix "*" := Qcmult : Qc_scope.
149 Definition Qcopp (x : Qc) := !!(-x).
150 Notation "- x" := (Qcopp x) : Qc_scope.
151 Definition Qcminus (x y : Qc) := x+-y.
152 Infix "-" := Qcminus : Qc_scope.
153 Definition Qcinv (x : Qc) := !!(/x).
154 Notation "/ x" := (Qcinv x) : Qc_scope.
155 Definition Qcdiv (x y : Qc) := x*/y.
156 Infix "/" := Qcdiv : Qc_scope.
157
158 (** [0] and [1] are apart *)
159
160 Lemma Q_apart_0_1 : 1 <> 0.
161 Proof.
162 unfold Q2Qc.
163 intros H; discriminate H.
164 Qed.
165
166 Ltac qc := match goal with
167 | q:Qc |- _ => destruct q; qc
168 | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct
169 end.
170
171 Opaque Qred.
172
173 (** Addition is associative: *)
174
175 Theorem Qcplus_assoc : forall x y z, x+(y+z)=(x+y)+z.
176 Proof.
177 intros; qc; apply Qplus_assoc.
178 Qed.
179
180 (** [0] is a neutral element for addition: *)
181
182 Lemma Qcplus_0_l : forall x, 0+x = x.
183 Proof.
184 intros; qc; apply Qplus_0_l.
185 Qed.
186
187 Lemma Qcplus_0_r : forall x, x+0 = x.
188 Proof.
189 intros; qc; apply Qplus_0_r.
190 Qed.
191
192 (** Commutativity of addition: *)
193
194 Theorem Qcplus_comm : forall x y, x+y = y+x.
195 Proof.
196 intros; qc; apply Qplus_comm.
197 Qed.
198
199 (** Properties of [Qopp] *)
200
201 Lemma Qcopp_involutive : forall q, - -q = q.
202 Proof.
203 intros; qc; apply Qopp_involutive.
204 Qed.
205
206 Theorem Qcplus_opp_r : forall q, q+(-q) = 0.
207 Proof.
208 intros; qc; apply Qplus_opp_r.
209 Qed.
210
211 (** Multiplication is associative: *)
212
213 Theorem Qcmult_assoc : forall n m p, n*(m*p)=(n*m)*p.
214 Proof.
215 intros; qc; apply Qmult_assoc.
216 Qed.
217
218 (** [1] is a neutral element for multiplication: *)
219
220 Lemma Qcmult_1_l : forall n, 1*n = n.
221 Proof.
222 intros; qc; apply Qmult_1_l.
223 Qed.
224
225 Theorem Qcmult_1_r : forall n, n*1=n.
226 Proof.
227 intros; qc; apply Qmult_1_r.
228 Qed.
229
230 (** Commutativity of multiplication *)
231
232 Theorem Qcmult_comm : forall x y, x*y=y*x.
233 Proof.
234 intros; qc; apply Qmult_comm.
235 Qed.
236
237 (** Distributivity *)
238
239 Theorem Qcmult_plus_distr_r : forall x y z, x*(y+z)=(x*y)+(x*z).
240 Proof.
241 intros; qc; apply Qmult_plus_distr_r.
242 Qed.
243
244 Theorem Qcmult_plus_distr_l : forall x y z, (x+y)*z=(x*z)+(y*z).
245 Proof.
246 intros; qc; apply Qmult_plus_distr_l.
247 Qed.
248
249 (** Integrality *)
250
251 Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0.
252 Proof.
253 intros.
254 destruct (Qmult_integral x y); try qc; auto.
255 injection H; clear H; intros.
256 rewrite <- (Qred_correct (x*y)).
257 rewrite <- (Qred_correct 0).
258 rewrite H; auto with qarith.
259 Qed.
260
261 Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0.
262 Proof.
263 intros; destruct (Qcmult_integral _ _ H0); tauto.
264 Qed.
265
266 (** Inverse and division. *)
267
268 Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1.
269 Proof.
270 intros; qc; apply Qmult_inv_r; auto.
271 Qed.
272
273 Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1.
274 Proof.
275 intros.
276 rewrite Qcmult_comm.
277 apply Qcmult_inv_r; auto.
278 Qed.
279
280 Lemma Qcinv_mult_distr : forall p q, / (p * q) = /p * /q.
281 Proof.
282 intros; qc; apply Qinv_mult_distr.
283 Qed.
284
285 Theorem Qcdiv_mult_l : forall x y, y<>0 -> (x*y)/y = x.
286 Proof.
287 unfold Qcdiv.
288 intros.
289 rewrite <- Qcmult_assoc.
290 rewrite Qcmult_inv_r; auto.
291 apply Qcmult_1_r.
292 Qed.
293
294 Theorem Qcmult_div_r : forall x y, ~ y = 0 -> y*(x/y) = x.
295 Proof.
296 unfold Qcdiv.
297 intros.
298 rewrite Qcmult_assoc.
299 rewrite Qcmult_comm.
300 rewrite Qcmult_assoc.
301 rewrite Qcmult_inv_l; auto.
302 apply Qcmult_1_l.
303 Qed.
304
305 (** Properties of order upon Q. *)
306
307 Lemma Qcle_refl : forall x, x<=x.
308 Proof.
309 unfold Qcle; intros; simpl; apply Qle_refl.
310 Qed.
311
312 Lemma Qcle_antisym : forall x y, x<=y -> y<=x -> x=y.
313 Proof.
314 unfold Qcle; intros; simpl in *.
315 apply Qc_is_canon; apply Qle_antisym; auto.
316 Qed.
317
318 Lemma Qcle_trans : forall x y z, x<=y -> y<=z -> x<=z.
319 Proof.
320 unfold Qcle; intros; eapply Qle_trans; eauto.
321 Qed.
322
323 Lemma Qclt_not_eq : forall x y, x<y -> x<>y.
324 Proof.
325 unfold Qclt; intros; simpl in *.
326 intro; destruct (Qlt_not_eq _ _ H).
327 subst; auto with qarith.
328 Qed.
329
330 (** Large = strict or equal *)
331
332 Lemma Qclt_le_weak : forall x y, x<y -> x<=y.
333 Proof.
334 unfold Qcle, Qclt; intros; apply Qlt_le_weak; auto.
335 Qed.
336
337 Lemma Qcle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
338 Proof.
339 unfold Qcle, Qclt; intros; eapply Qle_lt_trans; eauto.
340 Qed.
341
342 Lemma Qclt_le_trans : forall x y z, x<y -> y<=z -> x<z.
343 Proof.
344 unfold Qcle, Qclt; intros; eapply Qlt_le_trans; eauto.
345 Qed.
346
347 Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
348 Proof.
349 unfold Qclt; intros; eapply Qlt_trans; eauto.
350 Qed.
351
352 (** [x<y] iff [~(y<=x)] *)
353
354 Lemma Qcnot_lt_le : forall x y, ~ x<y -> y<=x.
355 Proof.
356 unfold Qcle, Qclt; intros; apply Qnot_lt_le; auto.
357 Qed.
358
359 Lemma Qcnot_le_lt : forall x y, ~ x<=y -> y<x.
360 Proof.
361 unfold Qcle, Qclt; intros; apply Qnot_le_lt; auto.
362 Qed.
363
364 Lemma Qclt_not_le : forall x y, x<y -> ~ y<=x.
365 Proof.
366 unfold Qcle, Qclt; intros; apply Qlt_not_le; auto.
367 Qed.
368
369 Lemma Qcle_not_lt : forall x y, x<=y -> ~ y<x.
370 Proof.
371 unfold Qcle, Qclt; intros; apply Qle_not_lt; auto.
372 Qed.
373
374 Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
375 Proof.
376 unfold Qcle, Qclt; intros; apply Qle_lt_or_eq; auto.
377 Qed.
378
379 (** Some decidability results about orders. *)
380
381 Lemma Qc_dec : forall x y, {x<y} + {y<x} + {x=y}.
382 Proof.
383 unfold Qclt, Qcle; intros.
384 destruct (Q_dec x y) as [H|H].
385 left; auto.
386 right; apply Qc_is_canon; auto.
387 Defined.
388
389 Lemma Qclt_le_dec : forall x y, {x<y} + {y<=x}.
390 Proof.
391 unfold Qclt, Qcle; intros; apply Qlt_le_dec; auto.
392 Defined.
393
394 (** Compatibility of operations with respect to order. *)
395
396 Lemma Qcopp_le_compat : forall p q, p<=q -> -q <= -p.
397 Proof.
398 unfold Qcle, Qcopp; intros; simpl in *.
399 repeat rewrite Qred_correct.
400 apply Qopp_le_compat; auto.
401 Qed.
402
403 Lemma Qcle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
404 Proof.
405 unfold Qcle, Qcminus; intros; simpl in *.
406 repeat rewrite Qred_correct.
407 apply Qle_minus_iff; auto.
408 Qed.
409
410 Lemma Qclt_minus_iff : forall p q, p < q <-> 0 < q+-p.
411 Proof.
412 unfold Qclt, Qcplus, Qcopp; intros; simpl in *.
413 repeat rewrite Qred_correct.
414 apply Qlt_minus_iff; auto.
415 Qed.
416
417 Lemma Qcplus_le_compat :
418 forall x y z t, x<=y -> z<=t -> x+z <= y+t.
419 Proof.
420 unfold Qcplus, Qcle; intros; simpl in *.
421 repeat rewrite Qred_correct.
422 apply Qplus_le_compat; auto.
423 Qed.
424
425 Lemma Qcmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
426 Proof.
427 unfold Qcmult, Qcle; intros; simpl in *.
428 repeat rewrite Qred_correct.
429 apply Qmult_le_compat_r; auto.
430 Qed.
431
432 Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y.
433 Proof.
434 unfold Qcmult, Qcle, Qclt; intros; simpl in *.
435 repeat progress rewrite Qred_correct in * |-.
436 eapply Qmult_lt_0_le_reg_r; eauto.
437 Qed.
438
439 Lemma Qcmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z.
440 Proof.
441 unfold Qcmult, Qclt; intros; simpl in *.
442 repeat progress rewrite Qred_correct in *.
443 eapply Qmult_lt_compat_r; eauto.
444 Qed.
445
446 (** Rational to the n-th power *)
447
448 Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc :=
449 match n with
450 | O => 1
451 | S n => q * (Qcpower q n)
452 end.
453
454 Notation " q ^ n " := (Qcpower q n) : Qc_scope.
455
456 Lemma Qcpower_1 : forall n, 1^n = 1.
457 Proof.
458 induction n; simpl; auto with qarith.
459 rewrite IHn; auto with qarith.
460 Qed.
461
462 Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0.
463 Proof.
464 destruct n; simpl.
465 destruct 1; auto.
466 intros.
467 apply Qc_is_canon.
468 simpl.
469 compute; auto.
470 Qed.
471
472 Lemma Qpower_pos : forall p n, 0 <= p -> 0 <= p^n.
473 Proof.
474 induction n; simpl; auto with qarith.
475 intros; compute; intro; discriminate.
476 intros.
477 apply Qcle_trans with (0*(p^n)).
478 compute; intro; discriminate.
479 apply Qcmult_le_compat_r; auto.
480 Qed.
481
482 (** And now everything is easier concerning tactics: *)
483
484 (** A ring tactic for rational numbers *)
485
486 Definition Qc_eq_bool (x y : Qc) :=
487 if Qc_eq_dec x y then true else false.
488
489 Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y.
490 intros x y; unfold Qc_eq_bool in |- *; case (Qc_eq_dec x y); simpl in |- *; auto.
491 intros _ H; inversion H.
492 Qed.
493
494 Definition Qcrt : Ring_Theory Qcplus Qcmult 1 0 Qcopp Qc_eq_bool.
495 Proof.
496 constructor.
497 exact Qcplus_comm.
498 exact Qcplus_assoc.
499 exact Qcmult_comm.
500 exact Qcmult_assoc.
501 exact Qcplus_0_l.
502 exact Qcmult_1_l.
503 exact Qcplus_opp_r.
504 exact Qcmult_plus_distr_l.
505 unfold Is_true; intros x y; generalize (Qc_eq_bool_correct x y);
506 case (Qc_eq_bool x y); auto.
507 Qed.
508
509 Add Ring Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcrt [ Qcmake ].
510
511 (** A field tactic for rational numbers *)
512
513 Require Import Field.
514
515 Add Field Qc Qcplus Qcmult 1 0 Qcopp Qc_eq_bool Qcinv Qcrt Qcmult_inv_l
516 with div:=Qcdiv.
517
518 Example test_field : forall x y : Qc, y<>0 -> (x/y)*y = x.
519 intros.
520 field.
521 auto.
522 Qed.
523
524
525
+7
-104
theories/QArith/Qreduction.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: Qreduction.v 8883 2006-05-31 21:56:37Z letouzey $ i*)
8 (*i $Id: Qreduction.v 8989 2006-06-25 22:17:49Z letouzey $ i*)
99
1010 (** * Normalisation functions for rational numbers. *)
1111
3131 simple destruct z; simpl in |- *; auto; intros; elim H; auto.
3232 Qed.
3333
34 (** A simple cancelation by powers of two *)
35
36 Fixpoint Pfactor_twos (p p':positive) {struct p} : (positive*positive) :=
37 match p, p' with
38 | xO p, xO p' => Pfactor_twos p p'
39 | _, _ => (p,p')
40 end.
41
42 Definition Qfactor_twos (q:Q) :=
43 let (p,q) := q in
44 match p with
45 | Z0 => 0
46 | Zpos p => let (p,q) := Pfactor_twos p q in (Zpos p)#q
47 | Zneg p => let (p,q) := Pfactor_twos p q in (Zneg p)#q
48 end.
49
50 Lemma Pfactor_twos_correct : forall p p',
51 (p*(snd (Pfactor_twos p p')))%positive =
52 (p'*(fst (Pfactor_twos p p')))%positive.
53 Proof.
54 induction p; intros.
55 simpl snd; simpl fst; rewrite Pmult_comm; auto.
56 destruct p'.
57 simpl snd; simpl fst; rewrite Pmult_comm; auto.
58 simpl; f_equal; auto.
59 simpl snd; simpl fst; rewrite Pmult_comm; auto.
60 simpl snd; simpl fst; rewrite Pmult_comm; auto.
61 Qed.
62
63 Lemma Qfactor_twos_correct : forall q, Qfactor_twos q == q.
64 Proof.
65 intros (p,q).
66 destruct p.
67 red; simpl; auto.
68 simpl.
69 generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
70 red; simpl.
71 intros; f_equal.
72 rewrite H; apply Pmult_comm.
73 simpl.
74 generalize (Pfactor_twos_correct p q); destruct (Pfactor_twos p q).
75 red; simpl.
76 intros; f_equal.
77 rewrite H; apply Pmult_comm.
78 Qed.
79 Hint Resolve Qfactor_twos_correct.
80
8134 (** Simplification of fractions using [Zgcd].
8235 This version can compute within Coq. *)
8336
8437 Definition Qred (q:Q) :=
85 let (q1,q2) := Qfactor_twos q in
86 let (r1,r2) := snd (Zggcd q1 (Zpos q2)) in r1#(Z2P r2).
38 let (q1,q2) := q in
39 let (r1,r2) := snd (Zggcd q1 ('q2))
40 in r1#(Z2P r2).
8741
8842 Lemma Qred_correct : forall q, (Qred q) == q.
8943 Proof.
90 intros; apply Qeq_trans with (Qfactor_twos q); auto.
91 unfold Qred.
92 destruct (Qfactor_twos q) as (n,d); red; simpl.
44 unfold Qred, Qeq; intros (n,d); simpl.
9345 generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d))
9446 (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
9547 destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
11163
11264 Lemma Qred_complete : forall p q, p==q -> Qred p = Qred q.
11365 Proof.
114 intros.
115 assert (Qfactor_twos p == Qfactor_twos q).
116 apply Qeq_trans with p; auto.
117 apply Qeq_trans with q; auto.
118 symmetry; auto.
119 clear H.
120 unfold Qred.
121 destruct (Qfactor_twos p) as (a,b);
122 destruct (Qfactor_twos q) as (c,d); clear p q.
123 unfold Qeq in *; simpl in *.
66 intros (a,b) (c,d).
67 unfold Qred, Qeq in *; simpl in *.
12468 Open Scope Z_scope.
12569 generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
12670 (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
197141 rewrite (Qred_correct q'); auto.
198142 Qed.
199143
200 (** Another version, dedicated to extraction *)
201
202 Definition Qred_extr (q : Q) :=
203 let (q1, q2) := Qfactor_twos q in
204 let (p,_) := Zggcd_spec_pos (Zpos q2) (Zle_0_pos q2) q1 in
205 let (r2,r1) := snd p in r1#(Z2P r2).
206
207 Lemma Qred_extr_Qred : forall q, Qred_extr q = Qred q.
208 Proof.
209 unfold Qred, Qred_extr.
210 intro q; destruct (Qfactor_twos q) as (n,p); clear q.
211 Open Scope Z_scope.
212 destruct (Zggcd_spec_pos (' p) (Zle_0_pos p) n) as ((g,(pp,nn)),H).
213 generalize (H (Zle_0_pos p)); clear H; intros (Hg1,(Hg2,(Hg4,Hg3))).
214 simpl.
215 generalize (Zggcd_gcd n ('p)) (Zgcd_is_gcd n ('p))
216 (Zgcd_is_pos n ('p)) (Zggcd_correct_divisors n ('p)).
217 destruct (Zggcd n (Zpos p)) as (g',(nn',pp')); simpl.
218 intro H; rewrite <- H; clear H.
219 intros Hg'1 Hg'2 (Hg'3,Hg'4).
220 assert (g<>0).
221 intro; subst g; discriminate.
222 destruct (Zis_gcd_uniqueness_apart_sign n ('p) g g'); auto.
223 apply Zis_gcd_sym; auto.
224 subst g'.
225 f_equal.
226 apply Zmult_reg_l with g; auto; congruence.
227 f_equal.
228 apply Zmult_reg_l with g; auto; congruence.
229 elimtype False; omega.
230 Open Scope Q_scope.
231 Qed.
232
233 Add Morphism Qred_extr : Qred_extr_comp.
234 Proof.
235 intros q q' H.
236 do 2 rewrite Qred_extr_Qred.
237 rewrite (Qred_correct q); auto.
238 rewrite (Qred_correct q'); auto.
239 Qed.
240
241144 Definition Qplus' (p q : Q) := Qred (Qplus p q).
242145 Definition Qmult' (p q : Q) := Qred (Qmult p q).
243146
+13
-3
theories/Reals/Ranalysis1.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: Ranalysis1.v 8670 2006-03-28 22:16:14Z herbelin $ i*)
8 (*i $Id: Ranalysis1.v 9042 2006-07-11 22:06:48Z herbelin $ i*)
99
1010 Require Import Rbase.
1111 Require Import Rfunctions.
2626 Definition comp f1 f2 (x:R) : R := f1 (f2 x).
2727 Definition inv_fct f (x:R) : R := / f x.
2828
29 Delimit Scope Rfun_scope with F.
30
31 Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope].
32 Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope].
33 Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope].
34 Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope].
35 Arguments Scope inv_fct [Rfun_scope R_scope].
36 Arguments Scope opp_fct [Rfun_scope R_scope].
37 Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope].
38 Arguments Scope div_real_fct [R_scope Rfun_scope R_scope].
39 Arguments Scope comp [Rfun_scope Rfun_scope R_scope].
40
2941 Infix "+" := plus_fct : Rfun_scope.
3042 Notation "- x" := (opp_fct x) : Rfun_scope.
3143 Infix "*" := mult_fct : Rfun_scope.
3446 Notation Local "f1 'o' f2" := (comp f1 f2)
3547 (at level 20, right associativity) : Rfun_scope.
3648 Notation "/ x" := (inv_fct x) : Rfun_scope.
37
38 Delimit Scope Rfun_scope with F.
3949
4050 Definition fct_cte (a x:R) : R := a.
4151 Definition id (x:R) := x.
+388
-498
theories/ZArith/Znumtheory.v less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: Znumtheory.v 8853 2006-05-23 18:17:38Z herbelin $ i*)
8 (*i $Id: Znumtheory.v 8990 2006-06-26 13:57:44Z notin $ i*)
99
1010 Require Import ZArith_base.
1111 Require Import ZArithRing.
1212 Require Import Zcomplements.
1313 Require Import Zdiv.
14 Require Import Ndigits.
15 Require Import Wf_nat.
1416 Open Local Scope Z_scope.
1517
1618 (** This file contains some notions of number theory upon Z numbers:
1719 - a divisibility predicate [Zdivide]
1820 - a gcd predicate [gcd]
1921 - Euclid algorithm [euclid]
20 - an efficient [Zgcd] function
2122 - a relatively prime predicate [rel_prime]
2223 - a prime predicate [prime]
24 - an efficient [Zgcd] function
2325 *)
2426
2527 (** * Divisibility *)
214216 constructor; auto with zarith.
215217 Qed.
216218
219 Lemma Zis_gcd_1 : forall a, Zis_gcd a 1 1.
220 Proof.
221 constructor; auto with zarith.
222 Qed.
223
224 Lemma Zis_gcd_refl : forall a, Zis_gcd a a a.
225 Proof.
226 constructor; auto with zarith.
227 Qed.
228
217229 Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d.
218230 Proof.
219231 simple induction 1; constructor; intuition.
222234 Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d).
223235 Proof.
224236 simple induction 1; constructor; intuition.
237 Qed.
238
239 Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a).
240 Proof.
241 intros a.
242 apply Zabs_ind.
243 intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
244 intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
225245 Qed.
226246
227247 Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
365385 rewrite H6; rewrite H7; ring.
366386 ring.
367387 Qed.
368
369 Lemma Zis_gcd_0_abs : forall b,
370 Zis_gcd 0 b (Zabs b) /\ Zabs b >= 0 /\ 0 = Zabs b * 0 /\ b = Zabs b * Zsgn b.
371 Proof.
372 intro b.
373 elim (Z_le_lt_eq_dec _ _ (Zabs_pos b)).
374 intros H0; split.
375 apply Zabs_ind.
376 intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
377 intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
378 repeat split; auto with zarith.
379 symmetry; apply Zabs_Zsgn.
380
381 intros H0; rewrite <- H0.
382 rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *.
383 split; [ apply Zis_gcd_0 | idtac ]; auto with zarith.
384 Qed.
385388
386
387 (** We could obtain a [Zgcd] function via [euclid]. But we propose
388 here a more direct version of a [Zgcd], that can compute within Coq.
389 For that, we use an explicit measure in [nat], and we proved later
390 that using [2(d+1)] is enough, where [d] is the number of binary digits
391 of the first argument. *)
392
393 Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b =>
394 match n with
395 | O => 1 (* arbitrary, since n should be big enough *)
396 | S n => match a with
397 | Z0 => Zabs b
398 | Zpos _ => Zgcdn n (Zmod b a) a
399 | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a)
400 end
401 end.
402
403 (* For technical reason, we don't use [Ndigit.Psize] but this
404 ad-hoc version: [Psize p = S (Psiz p)]. *)
405
406 Fixpoint Psiz (p:positive) : nat :=
407 match p with
408 | xH => O
409 | xI p => S (Psiz p)
410 | xO p => S (Psiz p)
411 end.
412
413 Definition Zgcd_bound (a:Z) := match a with
414 | Z0 => S O
415 | Zpos p => let n := Psiz p in S (S (n+n))
416 | Zneg p => let n := Psiz p in S (S (n+n))
417 end.
418
419 Definition Zgcd a b := Zgcdn (Zgcd_bound a) a b.
420
421 (** A first obvious fact : [Zgcd a b] is positive. *)
422
423 Lemma Zgcdn_is_pos : forall n a b,
424 0 <= Zgcdn n a b.
425 Proof.
426 induction n.
427 simpl; auto with zarith.
428 destruct a; simpl; intros; auto with zarith; auto.
429 Qed.
430
431 Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
432 Proof.
433 intros; unfold Zgcd; apply Zgcdn_is_pos; auto.
434 Qed.
435
436 (** We now prove that Zgcd is indeed a gcd. *)
437
438 (** 1) We prove a weaker & easier bound. *)
439
440 Lemma Zgcdn_linear_bound : forall n a b,
441 Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b).
442 Proof.
443 induction n.
444 simpl; intros.
445 elimtype False; generalize (Zabs_pos a); omega.
446 destruct a; intros; simpl;
447 [ generalize (Zis_gcd_0_abs b); intuition | | ];
448 unfold Zmod;
449 generalize (Z_div_mod b (Zpos p) (refl_equal Gt));
450 destruct (Zdiv_eucl b (Zpos p)) as (q,r);
451 intros (H0,H1);
452 rewrite inj_S in H; simpl Zabs in H;
453 assert (H2: Zabs r < Z_of_nat n) by (rewrite Zabs_eq; auto with zarith);
454 assert (IH:=IHn r (Zpos p) H2); clear IHn;
455 simpl in IH |- *;
456 rewrite H0.
457 apply Zis_gcd_for_euclid2; auto.
458 apply Zis_gcd_minus; apply Zis_gcd_sym.
459 apply Zis_gcd_for_euclid2; auto.
460 Qed.
461
462 (** 2) For Euclid's algorithm, the worst-case situation corresponds
463 to Fibonacci numbers. Let's define them: *)
464
465 Fixpoint fibonacci (n:nat) : Z :=
466 match n with
467 | O => 1
468 | S O => 1
469 | S (S n as p) => fibonacci p + fibonacci n
470 end.
471
472 Lemma fibonacci_pos : forall n, 0 <= fibonacci n.
473 Proof.
474 cut (forall N n, (n<N)%nat -> 0<=fibonacci n).
475 eauto.
476 induction N.
477 inversion 1.
478 intros.
479 destruct n.
480 simpl; auto with zarith.
481 destruct n.
482 simpl; auto with zarith.
483 change (0 <= fibonacci (S n) + fibonacci n).
484 generalize (IHN n) (IHN (S n)); omega.
485 Qed.
486
487 Lemma fibonacci_incr :
488 forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m.
489 Proof.
490 induction 1.
491 auto with zarith.
492 apply Zle_trans with (fibonacci m); auto.
493 clear.
494 destruct m.
495 simpl; auto with zarith.
496 change (fibonacci (S m) <= fibonacci (S m)+fibonacci m).
497 generalize (fibonacci_pos m); omega.
498 Qed.
499
500 (** 3) We prove that fibonacci numbers are indeed worst-case:
501 for a given number [n], if we reach a conclusion about [gcd(a,b)] in
502 exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *)
503
504 Lemma Zgcdn_worst_is_fibonacci : forall n a b,
505 0 < a < b ->
506 Zis_gcd a b (Zgcdn (S n) a b) ->
507 Zgcdn n a b <> Zgcdn (S n) a b ->
508 fibonacci (S n) <= a /\
509 fibonacci (S (S n)) <= b.
510 Proof.
511 induction n.
512 simpl; intros.
513 destruct a; omega.
514 intros.
515 destruct a; [simpl in *; omega| | destruct H; discriminate].
516 revert H1; revert H0.
517 set (m:=S n) in *; (assert (m=S n) by auto); clearbody m.
518 pattern m at 2; rewrite H0.
519 simpl Zgcdn.
520 unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
521 destruct (Zdiv_eucl b (Zpos p)) as (q,r).
522 intros (H1,H2).
523 destruct H2.
524 destruct (Zle_lt_or_eq _ _ H2).
525 generalize (IHn _ _ (conj H4 H3)).
526 intros H5 H6 H7.
527 replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto.
528 assert (r = Zpos p * (-q) + b) by (rewrite H1; ring).
529 destruct H5; auto.
530 pattern r at 1; rewrite H8.
531 apply Zis_gcd_sym.
532 apply Zis_gcd_for_euclid2; auto.
533 apply Zis_gcd_sym; auto.
534 split; auto.
535 rewrite H1.
536 apply Zplus_le_compat; auto.
537 apply Zle_trans with (Zpos p * 1); auto.
538 ring (Zpos p * 1); auto.
539 apply Zmult_le_compat_l.
540 destruct q.
541 omega.
542 assert (0 < Zpos p0) by (compute; auto).
543 omega.
544 assert (Zpos p * Zneg p0 < 0) by (compute; auto).
545 omega.
546 compute; intros; discriminate.
547 (* r=0 *)
548 subst r.
549 simpl; rewrite H0.
550 intros.
551 simpl in H4.
552 simpl in H5.
553 destruct n.
554 simpl in H5.
555 simpl.
556 omega.
557 simpl in H5.
558 elim H5; auto.
559 Qed.
560
561 (** 3b) We reformulate the previous result in a more positive way. *)
562
563 Lemma Zgcdn_ok_before_fibonacci : forall n a b,
564 0 < a < b -> a < fibonacci (S n) ->
565 Zis_gcd a b (Zgcdn n a b).
566 Proof.
567 destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate].
568 cut (forall k n b,
569 k = (S (nat_of_P p) - n)%nat ->
570 0 < Zpos p < b -> Zpos p < fibonacci (S n) ->
571 Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)).
572 destruct 2; eauto.
573 clear n; induction k.
574 intros.
575 assert (nat_of_P p < n)%nat by omega.
576 apply Zgcdn_linear_bound.
577 simpl.
578 generalize (inj_le _ _ H2).
579 rewrite inj_S.
580 rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto.
581 omega.
582 intros.
583 generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros.
584 assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)).
585 apply IHk; auto.
586 omega.
587 replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto.
588 generalize (fibonacci_pos n); omega.
589 replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto.
590 generalize (H2 H3); clear H2 H3; omega.
591 Qed.
592
593 (** 4) The proposed bound leads to a fibonacci number that is big enough. *)
594
595 Lemma Zgcd_bound_fibonacci :
596 forall a, 0 < a -> a < fibonacci (Zgcd_bound a).
597 Proof.
598 destruct a; [omega| | intro H; discriminate].
599 intros _.
600 induction p.
601 simpl Zgcd_bound in *.
602 rewrite Zpos_xI.
603 rewrite plus_comm; simpl plus.
604 set (n:=S (Psiz p+Psiz p)) in *.
605 change (2*Zpos p+1 <
606 fibonacci (S n) + fibonacci n + fibonacci (S n)).
607 generalize (fibonacci_pos n).
608 omega.
609 simpl Zgcd_bound in *.
610 rewrite Zpos_xO.
611 rewrite plus_comm; simpl plus.
612 set (n:= S (Psiz p +Psiz p)) in *.
613 change (2*Zpos p <
614 fibonacci (S n) + fibonacci n + fibonacci (S n)).
615 generalize (fibonacci_pos n).
616 omega.
617 simpl; auto with zarith.
618 Qed.
619
620 (* 5) the end: we glue everything together and take care of
621 situations not corresponding to [0<a<b]. *)
622
623 Lemma Zgcd_is_gcd :
624 forall a b, Zis_gcd a b (Zgcd a b).
625 Proof.
626 unfold Zgcd; destruct a; intros.
627 simpl; generalize (Zis_gcd_0_abs b); intuition.
628 (*Zpos*)
629 generalize (Zgcd_bound_fibonacci (Zpos p)).
630 simpl Zgcd_bound.
631 set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
632 simpl Zgcdn.
633 unfold Zmod.
634 generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
635 destruct (Zdiv_eucl b (Zpos p)) as (q,r).
636 intros (H1,H2) H3.
637 rewrite H1.
638 apply Zis_gcd_for_euclid2.
639 destruct H2.
640 destruct (Zle_lt_or_eq _ _ H0).
641 apply Zgcdn_ok_before_fibonacci; auto; omega.
642 subst r n; simpl.
643 apply Zis_gcd_sym; apply Zis_gcd_0.
644 (*Zneg*)
645 generalize (Zgcd_bound_fibonacci (Zpos p)).
646 simpl Zgcd_bound.
647 set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
648 simpl Zgcdn.
649 unfold Zmod.
650 generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
651 destruct (Zdiv_eucl b (Zpos p)) as (q,r).
652 intros (H1,H2) H3.
653 rewrite H1.
654 apply Zis_gcd_minus.
655 apply Zis_gcd_sym.
656 apply Zis_gcd_for_euclid2.
657 destruct H2.
658 destruct (Zle_lt_or_eq _ _ H0).
659 apply Zgcdn_ok_before_fibonacci; auto; omega.
660 subst r n; simpl.
661 apply Zis_gcd_sym; apply Zis_gcd_0.
662 Qed.
663
664 (** A generalized gcd: it additionnally keeps track of the divisors. *)
665
666 Fixpoint Zggcdn (n:nat) : Z -> Z -> (Z*(Z*Z)) := fun a b =>
667 match n with
668 | O => (1,(a,b)) (*(Zabs b,(0,Zsgn b))*)
669 | S n => match a with
670 | Z0 => (Zabs b,(0,Zsgn b))
671 | Zpos _ =>
672 let (q,r) := Zdiv_eucl b a in (* b = q*a+r *)
673 let (g,p) := Zggcdn n r a in
674 let (rr,aa) := p in (* r = g *rr /\ a = g * aa *)
675 (g,(aa,q*aa+rr))
676 | Zneg a =>
677 let (q,r) := Zdiv_eucl b (Zpos a) in (* b = q*(-a)+r *)
678 let (g,p) := Zggcdn n r (Zpos a) in
679 let (rr,aa) := p in (* r = g*rr /\ (-a) = g * aa *)
680 (g,(-aa,q*aa+rr))
681 end
682 end.
683
684 Definition Zggcd a b : Z * (Z * Z) := Zggcdn (Zgcd_bound a) a b.
685
686 (** The first component of [Zggcd] is [Zgcd] *)
687
688 Lemma Zggcdn_gcdn : forall n a b,
689 fst (Zggcdn n a b) = Zgcdn n a b.
690 Proof.
691 induction n; simpl; auto.
692 destruct a; unfold Zmod; simpl; intros; auto;
693 destruct (Zdiv_eucl b (Zpos p)) as (q,r);
694 rewrite <- IHn;
695 destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)); simpl; auto.
696 Qed.
697
698 Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
699 Proof.
700 intros; unfold Zggcd, Zgcd; apply Zggcdn_gcdn; auto.
701 Qed.
702
703 (** [Zggcd] always returns divisors that are coherent with its
704 first output. *)
705
706 Lemma Zggcdn_correct_divisors : forall n a b,
707 let (g,p) := Zggcdn n a b in
708 let (aa,bb):=p in
709 a=g*aa /\ b=g*bb.
710 Proof.
711 induction n.
712 simpl.
713 split; [destruct a|destruct b]; auto.
714 intros.
715 simpl.
716 destruct a.
717 rewrite Zmult_comm; simpl.
718 split; auto.
719 symmetry; apply Zabs_Zsgn.
720 generalize (Z_div_mod b (Zpos p));
721 destruct (Zdiv_eucl b (Zpos p)) as (q,r).
722 generalize (IHn r (Zpos p));
723 destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
724 intuition.
725 destruct H0.
726 compute; auto.
727 rewrite H; rewrite H1; rewrite H2; ring.
728 generalize (Z_div_mod b (Zpos p));
729 destruct (Zdiv_eucl b (Zpos p)) as (q,r).
730 destruct 1.
731 compute; auto.
732 generalize (IHn r (Zpos p));
733 destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
734 intuition.
735 destruct H0.
736 replace (Zneg p) with (-Zpos p) by compute; auto.
737 rewrite H4; ring.
738 rewrite H; rewrite H4; rewrite H0; ring.
739 Qed.
740
741 Lemma Zggcd_correct_divisors : forall a b,
742 let (g,p) := Zggcd a b in
743 let (aa,bb):=p in
744 a=g*aa /\ b=g*bb.
745 Proof.
746 unfold Zggcd; intros; apply Zggcdn_correct_divisors; auto.
747 Qed.
748
749 (** Due to the use of an explicit measure, the extraction of [Zgcd]
750 isn't optimal. We propose here another version [Zgcd_spec] that
751 doesn't suffer from this problem (but doesn't compute in Coq). *)
752
753 Definition Zgcd_spec_pos :
754 forall a:Z,
755 0 <= a -> forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}.
756 Proof.
757 intros a Ha.
758 apply
759 (Zlt_0_rec
760 (fun a:Z => forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}));
761 try assumption.
762 intro x; case x.
763 intros _ _ b; exists (Zabs b).
764 generalize (Zis_gcd_0_abs b); intuition.
765
766 intros p Hrec _ b.
767 generalize (Z_div_mod b (Zpos p)).
768 case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
769 elim Hqr; clear Hqr; intros; auto with zarith.
770 elim (Hrec r H0 (Zpos p)); intros g Hgkl.
771 inversion_clear H0.
772 elim (Hgkl H1); clear Hgkl; intros H3 H4.
773 exists g; intros.
774 split; auto.
775 rewrite H.
776 apply Zis_gcd_for_euclid2; auto.
777
778 intros p _ H b.
779 elim H; auto.
780 Defined.
781
782 Definition Zgcd_spec : forall a b:Z, {g : Z | Zis_gcd a b g /\ g >= 0}.
783 Proof.
784 intros a; case (Z_gt_le_dec 0 a).
785 intros; assert (0 <= - a).
786 omega.
787 elim (Zgcd_spec_pos (- a) H b); intros g Hgkl.
788 exists g.
789 intuition.
790 intros Ha b; elim (Zgcd_spec_pos a Ha b); intros g; exists g; intuition.
791 Defined.
792
793 (** A last version aimed at extraction that also returns the divisors. *)
794
795 Definition Zggcd_spec_pos :
796 forall a:Z,
797 0 <= a -> forall b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in
798 0 <= a -> Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
799 Proof.
800 intros a Ha.
801 pattern a; apply Zlt_0_rec; try assumption.
802 intro x; case x.
803 intros _ _ b; exists (Zabs b,(0,Zsgn b)).
804 intros _; apply Zis_gcd_0_abs.
805
806 intros p Hrec _ b.
807 generalize (Z_div_mod b (Zpos p)).
808 case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
809 elim Hqr; clear Hqr; intros; auto with zarith.
810 destruct (Hrec r H0 (Zpos p)) as ((g,(rr,pp)),Hgkl).
811 destruct H0.
812 destruct (Hgkl H0) as (H3,(H4,(H5,H6))).
813 exists (g,(pp,pp*q+rr)); intros.
814 split; auto.
815 rewrite H.
816 apply Zis_gcd_for_euclid2; auto.
817 repeat split; auto.
818 rewrite H; rewrite H6; rewrite H5; ring.
819
820 intros p _ H b.
821 elim H; auto.
822 Defined.
823
824 Definition Zggcd_spec :
825 forall a b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in
826 Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
827 Proof.
828 intros a; case (Z_gt_le_dec 0 a).
829 intros; assert (0 <= - a).
830 omega.
831 destruct (Zggcd_spec_pos (- a) H b) as ((g,(aa,bb)),Hgkl).
832 exists (g,(-aa,bb)).
833 intuition.
834 rewrite <- Zopp_mult_distr_r.
835 rewrite <- H2; auto with zarith.
836 intros Ha b; elim (Zggcd_spec_pos a Ha b); intros p; exists p.
837 repeat destruct p; intuition.
838 Defined.
839389
840390 (** * Relative primality *)
841391
919469 elim H4; intros.
920470 rewrite H2 in H6; subst b; omega.
921471 unfold rel_prime in |- *.
922 elim (Zgcd_spec (a / g) (b / g)); intros g' [H3 H4].
923 assert (H5 := Zis_gcd_mult _ _ g _ H3).
924 rewrite <- Z_div_exact_2 in H5; auto with zarith.
925 rewrite <- Z_div_exact_2 in H5; auto with zarith.
926 elim (Zis_gcd_uniqueness_apart_sign _ _ _ _ H1 H5).
927 intros; rewrite (Zmult_reg_l 1 g' g); auto with zarith.
928 intros; rewrite (Zmult_reg_l 1 (- g') g); auto with zarith.
929 pattern g at 1 in |- *; rewrite H6; ring.
930
931 elim H1; intros.
932 elim H7; intros.
933 rewrite H9.
934 replace (q * g) with (0 + q * g).
935 rewrite Z_mod_plus.
936 compute in |- *; auto.
937 omega.
938 ring.
939
940 elim H1; intros.
941 elim H6; intros.
942 rewrite H9.
943 replace (q * g) with (0 + q * g).
944 rewrite Z_mod_plus.
945 compute in |- *; auto.
946 omega.
947 ring.
472 destruct H1.
473 destruct H1 as (a',H1).
474 destruct H3 as (b',H3).
475 replace (a/g) with a';
476 [|rewrite H1; rewrite Z_div_mult; auto with zarith].
477 replace (b/g) with b';
478 [|rewrite H3; rewrite Z_div_mult; auto with zarith].
479 constructor.
480 exists a'; auto with zarith.
481 exists b'; auto with zarith.
482 intros x (xa,H5) (xb,H6).
483 destruct (H4 (x*g)).
484 exists xa; rewrite Zmult_assoc; rewrite <- H5; auto.
485 exists xb; rewrite Zmult_assoc; rewrite <- H6; auto.
486 replace g with (1*g) in H7; auto with zarith.
487 do 2 rewrite Zmult_assoc in H7.
488 generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros.
489 rewrite Zmult_1_r in H7.
490 exists q; auto with zarith.
948491 Qed.
949492
950493 (** * Primality *)
1044587 right; apply Gauss with a; auto with zarith.
1045588 Qed.
1046589
590
591 (** We could obtain a [Zgcd] function via Euclid algorithm. But we propose
592 here a binary version of [Zgcd], faster and executable within Coq.
593
594 Algorithm:
595
596 gcd 0 b = b
597 gcd a 0 = a
598 gcd (2a) (2b) = 2(gcd a b)
599 gcd (2a+1) (2b) = gcd (2a+1) b
600 gcd (2a) (2b+1) = gcd a (2b+1)
601 gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1)
602 or gcd (a-b) (2*b+1), depending on whether a<b
603 *)
604
605 Open Scope positive_scope.
606
607 Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive :=
608 match n with
609 | O => 1
610 | S n =>
611 match a,b with
612 | xH, _ => 1
613 | _, xH => 1
614 | xO a, xO b => xO (Pgcdn n a b)
615 | a, xO b => Pgcdn n a b
616 | xO a, b => Pgcdn n a b
617 | xI a', xI b' => match Pcompare a' b' Eq with
618 | Eq => a
619 | Lt => Pgcdn n (b'-a') a
620 | Gt => Pgcdn n (a'-b') b
621 end
622 end
623 end.
624
625 Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) :=
626 match n with
627 | O => (1,(a,b))
628 | S n =>
629 match a,b with
630 | xH, b => (1,(1,b))
631 | a, xH => (1,(a,1))
632 | xO a, xO b =>
633 let (g,p) := Pggcdn n a b in
634 (xO g,p)
635 | a, xO b =>
636 let (g,p) := Pggcdn n a b in
637 let (aa,bb) := p in
638 (g,(aa, xO bb))
639 | xO a, b =>
640 let (g,p) := Pggcdn n a b in
641 let (aa,bb) := p in
642 (g,(xO aa, bb))
643 | xI a', xI b' => match Pcompare a' b' Eq with
644 | Eq => (a,(1,1))
645 | Lt =>
646 let (g,p) := Pggcdn n (b'-a') a in
647 let (ba,aa) := p in
648 (g,(aa, aa + xO ba))
649 | Gt =>
650 let (g,p) := Pggcdn n (a'-b') b in
651 let (ab,bb) := p in
652 (g,(bb+xO ab, bb))
653 end
654 end
655 end.
656
657 Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b.
658 Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b.
659
660 Open Scope Z_scope.
661
662 Definition Zgcd (a b : Z) : Z := match a,b with
663 | Z0, _ => Zabs b
664 | _, Z0 => Zabs a
665 | Zpos a, Zpos b => Zpos (Pgcd a b)
666 | Zpos a, Zneg b => Zpos (Pgcd a b)
667 | Zneg a, Zpos b => Zpos (Pgcd a b)
668 | Zneg a, Zneg b => Zpos (Pgcd a b)
669 end.
670
671 Definition Zggcd (a b : Z) : Z*(Z*Z) := match a,b with
672 | Z0, _ => (Zabs b,(0, Zsgn b))
673 | _, Z0 => (Zabs a,(Zsgn a, 0))
674 | Zpos a, Zpos b =>
675 let (g,p) := Pggcd a b in
676 let (aa,bb) := p in
677 (Zpos g, (Zpos aa, Zpos bb))
678 | Zpos a, Zneg b =>
679 let (g,p) := Pggcd a b in
680 let (aa,bb) := p in
681 (Zpos g, (Zpos aa, Zneg bb))
682 | Zneg a, Zpos b =>
683 let (g,p) := Pggcd a b in
684 let (aa,bb) := p in
685 (Zpos g, (Zneg aa, Zpos bb))
686 | Zneg a, Zneg b =>
687 let (g,p) := Pggcd a b in
688 let (aa,bb) := p in
689 (Zpos g, (Zneg aa, Zneg bb))
690 end.
691
692 Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
693 Proof.
694 unfold Zgcd; destruct a; destruct b; auto with zarith.
695 Qed.
696
697 Lemma Psize_monotone : forall p q, Pcompare p q Eq = Lt -> (Psize p <= Psize q)%nat.
698 Proof.
699 induction p; destruct q; simpl; auto with arith; intros; try discriminate.
700 intros; generalize (Pcompare_Gt_Lt _ _ H); auto with arith.
701 intros; destruct (Pcompare_Lt_Lt _ _ H); auto with arith; subst; auto.
702 Qed.
703
704 Lemma Pminus_Zminus : forall a b, Pcompare a b Eq = Lt ->
705 Zpos (b-a) = Zpos b - Zpos a.
706 Proof.
707 intros.
708 repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
709 rewrite nat_of_P_minus_morphism.
710 apply inj_minus1.
711 apply lt_le_weak.
712 apply nat_of_P_lt_Lt_compare_morphism; auto.
713 rewrite ZC4; rewrite H; auto.
714 Qed.
715
716 Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g ->
717 Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g.
718 Proof.
719 intros.
720 destruct H.
721 constructor; auto.
722 destruct H as (e,H2); exists (2*e); auto with zarith.
723 rewrite Zpos_xO; rewrite H2; ring.
724 intros.
725 apply H1; auto.
726 rewrite Zpos_xO in H2.
727 rewrite Zpos_xI in H3.
728 apply Gauss with 2; auto.
729 apply bezout_rel_prime.
730 destruct H3 as (bb, H3).
731 apply Bezout_intro with bb (-Zpos b).
732 omega.
733 Qed.
734
735 Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat ->
736 Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)).
737 Proof.
738 intro n; pattern n; apply lt_wf_ind; clear n; intros.
739 destruct n.
740 simpl.
741 destruct a; simpl in *; try inversion H0.
742 destruct a.
743 destruct b; simpl.
744 case_eq (Pcompare a b Eq); intros.
745 (* a = xI, b = xI, compare = Eq *)
746 rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl.
747 (* a = xI, b = xI, compare = Lt *)
748 apply Zis_gcd_sym.
749 apply Zis_gcd_for_euclid with 1.
750 apply Zis_gcd_sym.
751 replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))).
752 apply Zis_gcd_even_odd.
753 apply H; auto.
754 simpl in *.
755 assert (Psize (b-a) <= Psize b)%nat.
756 apply Psize_monotone.
757 change (Zpos (b-a) < Zpos b).
758 rewrite (Pminus_Zminus _ _ H1).
759 assert (0 < Zpos a) by (compute; auto).
760 omega.
761 omega.
762 rewrite Zpos_xO; do 2 rewrite Zpos_xI.
763 rewrite Pminus_Zminus; auto.
764 omega.
765 (* a = xI, b = xI, compare = Gt *)
766 apply Zis_gcd_for_euclid with 1.
767 replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))).
768 apply Zis_gcd_sym.
769 apply Zis_gcd_even_odd.
770 apply H; auto.
771 simpl in *.
772 assert (Psize (a-b) <= Psize a)%nat.
773 apply Psize_monotone.
774 change (Zpos (a-b) < Zpos a).
775 rewrite (Pminus_Zminus b a).
776 assert (0 < Zpos b) by (compute; auto).
777 omega.
778 rewrite ZC4; rewrite H1; auto.
779 omega.
780 rewrite Zpos_xO; do 2 rewrite Zpos_xI.
781 rewrite Pminus_Zminus; auto.
782 omega.
783 rewrite ZC4; rewrite H1; auto.
784 (* a = xI, b = xO *)
785 apply Zis_gcd_sym.
786 apply Zis_gcd_even_odd.
787 apply Zis_gcd_sym.
788 apply H; auto.
789 simpl in *; omega.
790 (* a = xI, b = xH *)
791 apply Zis_gcd_1.
792 destruct b; simpl.
793 (* a = xO, b = xI *)
794 apply Zis_gcd_even_odd.
795 apply H; auto.
796 simpl in *; omega.
797 (* a = xO, b = xO *)
798 rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)).
799 apply Zis_gcd_mult.
800 apply H; auto.
801 simpl in *; omega.
802 (* a = xO, b = xH *)
803 apply Zis_gcd_1.
804 (* a = xH *)
805 simpl; apply Zis_gcd_sym; apply Zis_gcd_1.
806 Qed.
807
808 Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)).
809 Proof.
810 unfold Pgcd; intros.
811 apply Pgcdn_correct; auto.
812 Qed.
813
814 Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b).
815 Proof.
816 destruct a.
817 intros.
818 simpl.
819 apply Zis_gcd_0_abs.
820 destruct b; simpl.
821 apply Zis_gcd_0.
822 apply Pgcd_correct.
823 apply Zis_gcd_sym.
824 apply Zis_gcd_minus; simpl.
825 apply Pgcd_correct.
826 destruct b; simpl.
827 apply Zis_gcd_minus; simpl.
828 apply Zis_gcd_sym.
829 apply Zis_gcd_0.
830 apply Zis_gcd_minus; simpl.
831 apply Zis_gcd_sym.
832 apply Pgcd_correct.
833 apply Zis_gcd_sym.
834 apply Zis_gcd_minus; simpl.
835 apply Zis_gcd_minus; simpl.
836 apply Zis_gcd_sym.
837 apply Pgcd_correct.
838 Qed.
839
840
841 Lemma Pggcdn_gcdn : forall n a b,
842 fst (Pggcdn n a b) = Pgcdn n a b.
843 Proof.
844 induction n.
845 simpl; auto.
846 destruct a; destruct b; simpl; auto.
847 destruct (Pcompare a b Eq); simpl; auto.
848 rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto.
849 rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto.
850 rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto.
851 rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto.
852 rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto.
853 Qed.
854
855 Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b.
856 Proof.
857 intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b).
858 Qed.
859
860 Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
861 Proof.
862 destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd;
863 destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto.
864 Qed.
865
866 Open Scope positive_scope.
867
868 Lemma Pggcdn_correct_divisors : forall n a b,
869 let (g,p) := Pggcdn n a b in
870 let (aa,bb):=p in
871 (a=g*aa) /\ (b=g*bb).
872 Proof.
873 induction n.
874 simpl; auto.
875 destruct a; destruct b; simpl; auto.
876 case_eq (Pcompare a b Eq); intros.
877 (* Eq *)
878 rewrite Pmult_comm; simpl; auto.
879 rewrite (Pcompare_Eq_eq _ _ H); auto.
880 (* Lt *)
881 generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl.
882 intros (H0,H1); split; auto.
883 rewrite Pmult_plus_distr_l.
884 rewrite Pmult_xO_permute_r.
885 rewrite <- H1; rewrite <- H0.
886 simpl; f_equal; symmetry.
887 apply Pplus_minus; auto.
888 rewrite ZC4; rewrite H; auto.
889 (* Gt *)
890 generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl.
891 intros (H0,H1); split; auto.
892 rewrite Pmult_plus_distr_l.
893 rewrite Pmult_xO_permute_r.
894 rewrite <- H1; rewrite <- H0.
895 simpl; f_equal; symmetry.
896 apply Pplus_minus; auto.
897 (* Then... *)
898 generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl.
899 intros (H0,H1); split; auto.
900 rewrite Pmult_xO_permute_r; rewrite H1; auto.
901 generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl.
902 intros (H0,H1); split; auto.
903 rewrite Pmult_xO_permute_r; rewrite H0; auto.
904 generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl.
905 intros (H0,H1); split; subst; auto.
906 Qed.
907
908 Lemma Pggcd_correct_divisors : forall a b,
909 let (g,p) := Pggcd a b in
910 let (aa,bb):=p in
911 (a=g*aa) /\ (b=g*bb).
912 Proof.
913 intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b).
914 Qed.
915
916 Open Scope Z_scope.
917
918 Lemma Zggcd_correct_divisors : forall a b,
919 let (g,p) := Zggcd a b in
920 let (aa,bb):=p in
921 (a=g*aa) /\ (b=g*bb).
922 Proof.
923 destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto];
924 generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb));
925 destruct 1; subst; auto.
926 Qed.
927
928 Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}.
929 Proof.
930 intros x y; exists (Zgcd x y).
931 split; [apply Zgcd_is_gcd | apply Zgcd_is_pos].
932 Qed.
933
934
935
936
+12
-5
toplevel/vernacentries.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: vernacentries.ml 8751 2006-04-27 16:17:51Z courtieu $ i*)
8 (*i $Id: vernacentries.ml 9017 2006-07-05 17:27:34Z herbelin $ i*)
99
1010 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
1111
787787 optname="the printing width";
788788 optread=Pp_control.get_margin;
789789 optwrite=Pp_control.set_margin }
790
791 let vernac_debug b =
792 set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
793
794 let _ =
795 declare_bool_option
796 { optsync=false;
797 optkey=SecondaryTable("Ltac","Debug");
798 optname="Ltac debug";
799 optread=(fun () -> get_debug () <> Tactic_debug.DebugOff);
800 optwrite=vernac_debug }
790801
791802 let vernac_set_opacity opaq locqid =
792803 match Nametab.global locqid with
10681079 in
10691080 msgnl message
10701081
1071 let vernac_debug b =
1072 set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
1073
10741082 let interp c = match c with
10751083 (* Control (done in vernac) *)
10761084 | (VernacTime _ | VernacVar _ | VernacList _ | VernacLoad _) -> assert false
11741182 | VernacGo g -> vernac_go g
11751183 | VernacShow s -> vernac_show s
11761184 | VernacCheckGuard -> vernac_check_guard ()
1177 | VernacDebug b -> vernac_debug b
11781185 | VernacProof tac -> vernac_set_end_tac tac
11791186 (* Toplevel control *)
11801187 | VernacToplevelControl e -> raise e
+1
-2
toplevel/vernacexpr.ml less more
55 (* * GNU Lesser General Public License Version 2.1 *)
66 (************************************************************************)
77
8 (*i $Id: vernacexpr.ml 7936 2006-01-28 18:36:54Z herbelin $ i*)
8 (*i $Id: vernacexpr.ml 9017 2006-07-05 17:27:34Z herbelin $ i*)
99
1010 open Util
1111 open Names
280280 | VernacGo of goable
281281 | VernacShow of showable
282282 | VernacCheckGuard
283 | VernacDebug of bool
284283 | VernacProof of raw_tactic_expr
285284 (* Toplevel control *)
286285 | VernacToplevelControl of exn